[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: JS: Linker: use saturated JExpr
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Apr 2 20:39:37 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
6e2eb275 by doyougnu at 2023-04-01T18:27:56-04:00
JS: Linker: use saturated JExpr
Follow on to MR!10142 in pursuit of #22736
- - - - -
3da69346 by sheaf at 2023-04-01T18:28:37-04:00
Improve haddocks of template-haskell Con datatype
This adds a bit more information, in particular about the lists of
constructors in the GadtC and RecGadtC cases.
- - - - -
3b7bbb39 by sheaf at 2023-04-01T18:28:37-04:00
TH: revert changes to GadtC & RecGadtC
Commit 3f374399 included a breaking-change to the template-haskell
library when it made the GadtC and RecGadtC constructors take non-empty
lists of names. As this has the potential to break many users' packages,
we decided to revert these changes for now.
- - - - -
f842bac2 by Bodigrim at 2023-04-02T16:39:21-04:00
Rework documentation for data Char
- - - - -
815449c7 by Bodigrim at 2023-04-02T16:39:22-04:00
cmm: implement parsing of MO_AtomicRMW from hand-written CMM files
Fixes #23206
- - - - -
23 changed files:
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/JS/Transform.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Error/Codes.hs
- docs/users_guide/9.8.1-notes.rst
- libraries/ghc-prim/GHC/Types.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- + testsuite/tests/cmm/should_run/AtomicFetch.hs
- + testsuite/tests/cmm/should_run/AtomicFetch.stdout
- + testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
- testsuite/tests/cmm/should_run/all.T
- testsuite/tests/th/T10828.hs
- testsuite/tests/th/T10828b.hs
- testsuite/tests/th/T10828b.stderr
- testsuite/tests/th/T11345.hs
Changes:
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1137,6 +1137,12 @@ callishMachOps platform = listToUFM $
, allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst)
, allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease)
, allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst)
+ , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add)
+ , allWidths "fetch_sub" (\w -> MO_AtomicRMW w AMO_Sub)
+ , allWidths "fetch_and" (\w -> MO_AtomicRMW w AMO_And)
+ , allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand)
+ , allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or)
+ , allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor)
]
where
allWidths
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -95,7 +95,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Data.ByteString ( unpack )
import Control.Monad
import Data.List (sort, sortBy)
-import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.List.NonEmpty ( NonEmpty(..), toList )
import Data.Function
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class
@@ -2742,19 +2742,16 @@ repGadtDataCons :: NonEmpty (LocatedN Name)
-> LHsType GhcRn
-> MetaM (Core (M TH.Con))
repGadtDataCons cons details res_ty
- = do ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName
- name_tycon <- lift $ dsLookupTyCon nameTyConName
- let mk_nonEmpty = coreListNonEmpty ne_tycon (mkTyConTy name_tycon)
- cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+ = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
case details of
PrefixConGADT ps -> do
arg_tys <- repPrefixConArgs ps
res_ty' <- repLTy res_ty
- rep2 gadtCName [unC (mk_nonEmpty cons'), unC arg_tys, unC res_ty']
+ rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty']
RecConGADT ips _ -> do
arg_vtys <- repRecConArgs ips
res_ty' <- repLTy res_ty
- rep2 recGadtCName [unC (mk_nonEmpty cons'), unC arg_vtys,
+ rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys,
unC res_ty']
-- TH currently only supports linear constructors.
@@ -3060,6 +3057,9 @@ nonEmptyCoreList :: [Core a] -> Core [a]
nonEmptyCoreList [] = panic "coreList: empty argument"
nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a]
+nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs))
+
coreStringLit :: MonadThings m => FastString -> m (Core String)
coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) }
=====================================
compiler/GHC/JS/Transform.hs
=====================================
@@ -23,7 +23,6 @@ module GHC.JS.Transform
, composOpFold
, satJExpr
, satJStat
- , unsatJStat
)
where
@@ -321,98 +320,3 @@ satJVal = go
go (JHash m) = Sat.JHash (satJExpr <$> m)
go (JFunc args body) = Sat.JFunc args (satJStat body)
go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly"
-
-unsatJStat :: Sat.JStat -> JStat
-unsatJStat = go_back
- where
- -- This is an Applicative but we can't use it because no type variables :(
- go_back :: Sat.JStat -> JStat
- go_back (Sat.DeclStat i rhs) = DeclStat i (fmap unsatJExpr rhs)
- go_back (Sat.ReturnStat e) = ReturnStat (unsatJExpr e)
- go_back (Sat.IfStat c t e) = IfStat (unsatJExpr c) (go_back t) (go_back e)
- go_back (Sat.WhileStat is_do c e) = WhileStat is_do (unsatJExpr c) (go_back e)
- go_back (Sat.ForInStat is_each i iter body) = ForInStat is_each i
- (unsatJExpr iter)
- (go_back body)
- go_back (Sat.SwitchStat struct ps def) = SwitchStat
- (unsatJExpr struct)
- (map (unsatJExpr *** go_back) ps)
- (go_back def)
- go_back (Sat.TryStat t i c f) = TryStat (go_back t) i (go_back c) (go_back f)
- go_back (Sat.BlockStat bs) = BlockStat $! fmap go_back bs
- go_back (Sat.ApplStat rator rand) = ApplStat (unsatJExpr rator) (unsatJExpr <$> rand)
- go_back (Sat.UOpStat rator rand) = UOpStat (unsatJUOp rator) (unsatJExpr rand)
- go_back (Sat.AssignStat lhs rhs) = AssignStat (unsatJExpr lhs) (unsatJExpr rhs)
- go_back (Sat.LabelStat lbl stmt) = LabelStat lbl (go_back stmt)
- go_back (Sat.BreakStat Nothing) = BreakStat Nothing
- go_back (Sat.BreakStat (Just l)) = BreakStat $! Just l
- go_back (Sat.ContinueStat Nothing) = ContinueStat Nothing
- go_back (Sat.ContinueStat (Just l)) = ContinueStat $! Just l
-
-
-unsatJExpr :: Sat.JExpr -> JExpr
-unsatJExpr = go
- where
- go (Sat.ValExpr v) = ValExpr (unsatJVal v)
- go (Sat.SelExpr obj i) = SelExpr (unsatJExpr obj) i
- go (Sat.IdxExpr o i) = IdxExpr (unsatJExpr o) (unsatJExpr i)
- go (Sat.InfixExpr op l r) = InfixExpr (satOpToJOp op) (unsatJExpr l) (unsatJExpr r)
- go (Sat.UOpExpr op r) = UOpExpr (unsatJUOp op) (unsatJExpr r)
- go (Sat.IfExpr c t e) = IfExpr (unsatJExpr c) (unsatJExpr t) (unsatJExpr e)
- go (Sat.ApplExpr rator rands) = ApplExpr (unsatJExpr rator) (unsatJExpr <$> rands)
-
-satOpToJOp :: Sat.Op -> JOp
-satOpToJOp = go
- where
- go Sat.EqOp = EqOp
- go Sat.StrictEqOp = StrictEqOp
- go Sat.NeqOp = NeqOp
- go Sat.StrictNeqOp = StrictNeqOp
- go Sat.GtOp = GtOp
- go Sat.GeOp = GeOp
- go Sat.LtOp = LtOp
- go Sat.LeOp = LeOp
- go Sat.AddOp = AddOp
- go Sat.SubOp = SubOp
- go Sat.MulOp = MulOp
- go Sat.DivOp = DivOp
- go Sat.ModOp = ModOp
- go Sat.LeftShiftOp = LeftShiftOp
- go Sat.RightShiftOp = RightShiftOp
- go Sat.ZRightShiftOp = ZRightShiftOp
- go Sat.BAndOp = BAndOp
- go Sat.BOrOp = BOrOp
- go Sat.BXorOp = BXorOp
- go Sat.LAndOp = LAndOp
- go Sat.LOrOp = LOrOp
- go Sat.InstanceofOp = InstanceofOp
- go Sat.InOp = InOp
-
-unsatJUOp :: Sat.UOp -> JUOp
-unsatJUOp = go
- where
- go Sat.NotOp = NotOp
- go Sat.BNotOp = BNotOp
- go Sat.NegOp = NegOp
- go Sat.PlusOp = PlusOp
- go Sat.NewOp = NewOp
- go Sat.TypeofOp = TypeofOp
- go Sat.DeleteOp = DeleteOp
- go Sat.YieldOp = YieldOp
- go Sat.VoidOp = VoidOp
- go Sat.PreIncOp = PreIncOp
- go Sat.PostIncOp = PostIncOp
- go Sat.PreDecOp = PreDecOp
- go Sat.PostDecOp = PostDecOp
-
-unsatJVal :: Sat.JVal -> JVal
-unsatJVal = go
- where
- go (Sat.JVar i) = JVar i
- go (Sat.JList xs) = JList (unsatJExpr <$> xs)
- go (Sat.JDouble d) = JDouble (SaneDouble (Sat.unSaneDouble d))
- go (Sat.JInt i) = JInt i
- go (Sat.JStr f) = JStr f
- go (Sat.JRegEx f) = JRegEx f
- go (Sat.JHash m) = JHash (unsatJExpr <$> m)
- go (Sat.JFunc args body) = JFunc args (unsatJStat body)
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.Platform.Host (hostPlatformArchOS)
import GHC.JS.Make
import GHC.JS.Unsat.Syntax
+import qualified GHC.JS.Syntax as Sat
import GHC.JS.Transform
import GHC.Driver.Session (DynFlags(..))
@@ -280,7 +281,7 @@ computeLinkDependencies cfg logger target unit_env units objFiles extraStaticDep
-- | Compiled module
data ModuleCode = ModuleCode
{ mc_module :: !Module
- , mc_js_code :: !JStat
+ , mc_js_code :: !Sat.JStat
, mc_exports :: !B.ByteString -- ^ rendered exports
, mc_closures :: ![ClosureInfo]
, mc_statics :: ![StaticInfo]
@@ -293,7 +294,7 @@ data ModuleCode = ModuleCode
-- up into global "metadata" for the whole link.
data CompactedModuleCode = CompactedModuleCode
{ cmc_module :: !Module
- , cmc_js_code :: !JStat
+ , cmc_js_code :: !Sat.JStat
, cmc_exports :: !B.ByteString -- ^ rendered exports
}
@@ -326,7 +327,7 @@ renderLinker h mods jsFiles = do
-- modules themselves
mod_sizes <- forM compacted_mods $ \m -> do
- !mod_size <- fromIntegral <$> putJS (satJStat $! cmc_js_code m)
+ !mod_size <- fromIntegral <$> putJS (cmc_js_code m)
let !mod_mod = cmc_module m
pure (mod_mod, mod_size)
@@ -565,7 +566,7 @@ extractDeps ar_state units deps loc =
mod = depsModule deps
newline = BC.pack "\n"
mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw
- mk_js_code = mconcat . map (unsatJStat . oiStat)
+ mk_js_code = mconcat . map oiStat
collectCode l = ModuleCode
{ mc_module = mod
, mc_js_code = mk_js_code l
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -4831,6 +4831,10 @@ pprConversionFailReason = \case
text "Implicit parameters mixed with other bindings"
InvalidCCallImpent from ->
text (show from) <+> text "is not a valid ccall impent"
+ RecGadtNoCons ->
+ quotes (text "RecGadtC") <+> text "must have at least one constructor name"
+ GadtNoCons ->
+ quotes (text "GadtC") <+> text "must have at least one constructor name"
InvalidTypeInstanceHeader tys ->
text "Invalid type instance header:"
<+> text (show tys)
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3683,6 +3683,8 @@ data ConversionFailReason
| CasesExprWithoutAlts
| ImplicitParamsWithOtherBinds
| InvalidCCallImpent !String -- ^ Source
+ | RecGadtNoCons
+ | GadtNoCons
| InvalidTypeInstanceHeader !TH.Type
| InvalidTyFamInstLHS !TH.Type
| InvalidImplicitParamBinding
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -143,7 +143,6 @@ import Unsafe.Coerce ( unsafeCoerce )
import Control.Monad
import Data.Binary
import Data.Binary.Get
-import qualified Data.List.NonEmpty as NE ( singleton )
import Data.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
@@ -2235,7 +2234,7 @@ reifyDataCon isGadtDataCon tys dc
dcdBangs r_arg_tys)
| not (null fields) -> do
{ res_ty <- reifyType g_res_ty
- ; return $ TH.RecGadtC (NE.singleton name)
+ ; return $ TH.RecGadtC [name]
(zip3 (map reifyFieldLabel fields)
dcdBangs r_arg_tys) res_ty }
-- We need to check not isGadtDataCon here because GADT
@@ -2248,7 +2247,7 @@ reifyDataCon isGadtDataCon tys dc
; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
| isGadtDataCon -> do
{ res_ty <- reifyType g_res_ty
- ; return $ TH.GadtC (NE.singleton name)
+ ; return $ TH.GadtC [name]
(dcdBangs `zip` r_arg_tys) res_ty }
| otherwise ->
return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -276,7 +276,11 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; ksig' <- cvtKind `traverse` ksig
- ; con' <- cvtConstr (NE.head $ get_cons_names constr) cNameN constr
+ ; let first_datacon =
+ case get_cons_names constr of
+ [] -> panic "cvtDec: empty list of constructors"
+ c:_ -> c
+ ; con' <- cvtConstr first_datacon cNameN constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_cType = Nothing
@@ -348,8 +352,10 @@ cvtDec (DataFamilyD tc tvs kind)
cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
; ksig' <- cvtKind `traverse` ksig
-
- ; let first_datacon = NE.head $ get_cons_names $ head constrs
+ ; let first_datacon =
+ case get_cons_names $ head constrs of
+ [] -> panic "cvtDec: empty list of constructors"
+ c:_ -> c
; cons' <- mapM (cvtConstr first_datacon cNameN) constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
@@ -372,7 +378,11 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
; ksig' <- cvtKind `traverse` ksig
- ; con' <- cvtConstr (NE.head $ get_cons_names $ constr) cNameN constr
+ ; let first_datacon =
+ case get_cons_names constr of
+ [] -> panic "cvtDec: empty list of constructors"
+ c:_ -> c
+ ; con' <- cvtConstr first_datacon cNameN constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ext = noExtField
, dd_cType = Nothing
@@ -507,7 +517,10 @@ cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs
; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; ksig' <- cvtKind `traverse` ksig
- ; let first_datacon = NE.head $ get_cons_names $ head constrs
+ ; let first_datacon =
+ case get_cons_names $ head constrs of
+ [] -> panic "cvtGenDataDec: empty list of constructors"
+ c:_ -> c
; cons' <- mapM (cvtConstr first_datacon con_name) constrs
; derivs' <- cvtDerivs derivs
@@ -709,18 +722,22 @@ cvtConstr parent_con do_con_name (ForallC tvs ctxt con)
where
all_tvs = tvs' ++ ex_tvs
-cvtConstr _ do_con_name (GadtC cs strtys ty)
- = do { cs' <- mapM do_con_name cs
- ; args <- mapM cvt_arg strtys
- ; ty' <- cvtType ty
- ; mk_gadt_decl cs' (PrefixConGADT $ map hsLinear args) ty'}
-
-cvtConstr parent_con do_con_name (RecGadtC cs varstrtys ty)
- = do { cs' <- mapM do_con_name cs
- ; ty' <- cvtType ty
- ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys
- ; lrec_flds <- returnLA rec_flds
- ; mk_gadt_decl cs' (RecConGADT lrec_flds noHsUniTok) ty' }
+cvtConstr _ do_con_name (GadtC c strtys ty) = case nonEmpty c of
+ Nothing -> failWith GadtNoCons
+ Just c -> do
+ { c' <- mapM do_con_name c
+ ; args <- mapM cvt_arg strtys
+ ; ty' <- cvtType ty
+ ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}
+
+cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of
+ Nothing -> failWith RecGadtNoCons
+ Just c -> do
+ { c' <- mapM do_con_name c
+ ; ty' <- cvtType ty
+ ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys
+ ; lrec_flds <- returnLA rec_flds
+ ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' }
mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
-> CvtM (LConDecl GhcPs)
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -622,6 +622,8 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "CasesExprWithoutAlts" = 91745
GhcDiagnosticCode "ImplicitParamsWithOtherBinds" = 42974
GhcDiagnosticCode "InvalidCCallImpent" = 60220
+ GhcDiagnosticCode "RecGadtNoCons" = 18816
+ GhcDiagnosticCode "GadtNoCons" = 38140
GhcDiagnosticCode "InvalidTypeInstanceHeader" = 37056
GhcDiagnosticCode "InvalidTyFamInstLHS" = 78486
GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603
@@ -705,8 +707,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027
GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639
GhcDiagnosticCode "TcRnMixedSelectors" = 40887
- GhcDiagnosticCode "RecGadtNoCons" = 18816
- GhcDiagnosticCode "GadtNoCons" = 38140
{- *********************************************************************
* *
=====================================
docs/users_guide/9.8.1-notes.rst
=====================================
@@ -104,10 +104,6 @@ Runtime system
``template-haskell`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- The ``GadtC`` and ``RecGadtC`` constructors of the ``Con`` datatype now take
- non-empty lists of constructors. This means that the ``gadtC`` and ``recGadtC``
- smart constructors also expect non-empty lists as arguments.
-
- Record fields now belong to separate ``NameSpace``s, keyed by the parent of
the record field. This is the name of the first constructor of the parent type,
even if this constructor does not have the field in question.
=====================================
libraries/ghc-prim/GHC/Types.hs
=====================================
@@ -202,17 +202,96 @@ data Ordering = LT | EQ | GT
* *
********************************************************************* -}
-{- | The character type 'Char' is an enumeration whose values represent
-Unicode (or equivalently ISO\/IEC 10646) code points (i.e. characters, see
-<http://www.unicode.org/> for details). This set extends the ISO 8859-1
-(Latin-1) character set (the first 256 characters), which is itself an extension
-of the ASCII character set (the first 128 characters). A character literal in
-Haskell has type 'Char'.
-
-To convert a 'Char' to or from the corresponding 'Int' value defined
-by Unicode, use 'Prelude.toEnum' and 'Prelude.fromEnum' from the
-'Prelude.Enum' class respectively (or equivalently 'Data.Char.ord' and
-'Data.Char.chr').
+{- | The character type 'Char' represents Unicode codespace
+and its elements are code points as in definitions
+[D9 and D10 of the Unicode Standard](https://www.unicode.org/versions/Unicode15.0.0/ch03.pdf#G2212).
+
+Character literals in Haskell are single-quoted: @\'Q\'@, @\'Я\'@ or @\'Ω\'@.
+To represent a single quote itself use @\'\\''@, and to represent a backslash
+use @\'\\\\\'@. The full grammar can be found in the section 2.6 of the
+[Haskell 2010 Language Report](https://www.haskell.org/definition/haskell2010.pdf#section.2.6).
+
+To specify a character by its code point one can use decimal, hexadecimal
+or octal notation: @\'\\65\'@, @\'\\x41\'@ and @\'\\o101\'@ are all alternative forms
+of @\'A\'@. The largest code point is @\'\\x10ffff\'@.
+
+There is a special escape syntax for ASCII control characters:
+
++-------------+-------------------+---------------------------+
+| Escape | Alternatives | Meaning |
++=============+===================+===========================+
+| @'\\NUL'@ | @'\\0'@ | null character |
++-------------+-------------------+---------------------------+
+| @'\\SOH'@ | @'\\1'@ | start of heading |
++-------------+-------------------+---------------------------+
+| @'\\STX'@ | @'\\2'@ | start of text |
++-------------+-------------------+---------------------------+
+| @'\\ETX'@ | @'\\3'@ | end of text |
++-------------+-------------------+---------------------------+
+| @'\\EOT'@ | @'\\4'@ | end of transmission |
++-------------+-------------------+---------------------------+
+| @'\\ENQ'@ | @'\\5'@ | enquiry |
++-------------+-------------------+---------------------------+
+| @'\\ACK'@ | @'\\6'@ | acknowledge |
++-------------+-------------------+---------------------------+
+| @'\\BEL'@ | @'\\7'@, @'\\a'@ | bell (alert) |
++-------------+-------------------+---------------------------+
+| @'\\BS'@ | @'\\8'@, @'\\b'@ | backspace |
++-------------+-------------------+---------------------------+
+| @'\\HT'@ | @'\\9'@, @'\\t'@ | horizontal tab |
++-------------+-------------------+---------------------------+
+| @'\\LF'@ | @'\\10'@, @'\\n'@ | line feed (new line) |
++-------------+-------------------+---------------------------+
+| @'\\VT'@ | @'\\11'@, @'\\v'@ | vertical tab |
++-------------+-------------------+---------------------------+
+| @'\\FF'@ | @'\\12'@, @'\\f'@ | form feed |
++-------------+-------------------+---------------------------+
+| @'\\CR'@ | @'\\13'@, @'\\r'@ | carriage return |
++-------------+-------------------+---------------------------+
+| @'\\SO'@ | @'\\14'@ | shift out |
++-------------+-------------------+---------------------------+
+| @'\\SI'@ | @'\\15'@ | shift in |
++-------------+-------------------+---------------------------+
+| @'\\DLE'@ | @'\\16'@ | data link escape |
++-------------+-------------------+---------------------------+
+| @'\\DC1'@ | @'\\17'@ | device control 1 |
++-------------+-------------------+---------------------------+
+| @'\\DC2'@ | @'\\18'@ | device control 2 |
++-------------+-------------------+---------------------------+
+| @'\\DC3'@ | @'\\19'@ | device control 3 |
++-------------+-------------------+---------------------------+
+| @'\\DC4'@ | @'\\20'@ | device control 4 |
++-------------+-------------------+---------------------------+
+| @'\\NAK'@ | @'\\21'@ | negative acknowledge |
++-------------+-------------------+---------------------------+
+| @'\\SYN'@ | @'\\22'@ | synchronous idle |
++-------------+-------------------+---------------------------+
+| @'\\ETB'@ | @'\\23'@ | end of transmission block |
++-------------+-------------------+---------------------------+
+| @'\\CAN'@ | @'\\24'@ | cancel |
++-------------+-------------------+---------------------------+
+| @'\\EM'@ | @'\\25'@ | end of medium |
++-------------+-------------------+---------------------------+
+| @'\\SUB'@ | @'\\26'@ | substitute |
++-------------+-------------------+---------------------------+
+| @'\\ESC'@ | @'\\27'@ | escape |
++-------------+-------------------+---------------------------+
+| @'\\FS'@ | @'\\28'@ | file separator |
++-------------+-------------------+---------------------------+
+| @'\\GS'@ | @'\\29'@ | group separator |
++-------------+-------------------+---------------------------+
+| @'\\RS'@ | @'\\30'@ | record separator |
++-------------+-------------------+---------------------------+
+| @'\\US'@ | @'\\31'@ | unit separator |
++-------------+-------------------+---------------------------+
+| @'\\SP'@ | @'\\32'@, @' '@ | space |
++-------------+-------------------+---------------------------+
+| @'\\DEL'@ | @'\\127'@ | delete |
++-------------+-------------------+---------------------------+
+
+[Data.Char](https://hackage.haskell.org/package/base/docs/Data-Char.html)
+provides utilities to work with 'Char'.
+
-}
data {-# CTYPE "HsChar" #-} Char = C# Char#
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
=====================================
@@ -23,7 +23,7 @@ import qualified Language.Haskell.TH.Syntax as TH
import Control.Applicative(liftA, Applicative(..))
import qualified Data.Kind as Kind (Type)
import Data.Word( Word8 )
-import Data.List.NonEmpty ( NonEmpty(..), toList )
+import Data.List.NonEmpty ( NonEmpty(..) )
import GHC.Exts (TYPE)
import Prelude hiding (Applicative(..))
@@ -680,10 +680,10 @@ forallC ns ctxt con = do
con' <- con
pure $ ForallC ns' ctxt' con'
-gadtC :: Quote m => NonEmpty Name -> [m StrictType] -> m Type -> m Con
+gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con
gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty
-recGadtC :: Quote m => NonEmpty Name -> [m VarStrictType] -> m Type -> m Con
+recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con
recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty
-------------------------------------------------------------------------------
@@ -1177,7 +1177,7 @@ docCons :: (Q Con, Maybe String, [Maybe String]) -> Q ()
docCons (c, md, arg_docs) = do
c' <- c
-- Attach docs to the constructors
- sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- toList $ get_cons_names c' ]
+ sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- get_cons_names c' ]
-- Attach docs to the arguments
case c' of
-- Record selector documentation isn't stored in the argument map,
@@ -1188,6 +1188,6 @@ docCons (c, md, arg_docs) = do
]
_ ->
sequence_ [ putDoc (ArgDoc nm i) arg_doc
- | nm <- toList $ get_cons_names c'
+ | nm <- get_cons_names c'
, (i, Just arg_doc) <- zip [0..] arg_docs
]
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -11,7 +11,6 @@ module Language.Haskell.TH.Ppr where
import Text.PrettyPrint (render)
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
-import qualified Data.List.NonEmpty as NE ( toList )
import Data.Word ( Word8 )
import Data.Char ( toLower, chr)
import GHC.Show ( showMultiLineString )
@@ -684,21 +683,21 @@ instance Ppr Con where
<+> pprBangType st2
ppr (ForallC ns ctxt (GadtC cs sts ty))
- = commaSepApplied (NE.toList cs) <+> dcolon <+> pprForall ns ctxt
+ = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt
<+> pprGadtRHS sts ty
ppr (ForallC ns ctxt (RecGadtC cs vsts ty))
- = commaSepApplied (NE.toList cs) <+> dcolon <+> pprForall ns ctxt
+ = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt
<+> pprRecFields vsts ty
ppr (ForallC ns ctxt con)
= pprForall ns ctxt <+> ppr con
ppr (GadtC cs sts ty)
- = commaSepApplied (NE.toList cs) <+> dcolon <+> pprGadtRHS sts ty
+ = commaSepApplied cs <+> dcolon <+> pprGadtRHS sts ty
ppr (RecGadtC cs vsts ty)
- = commaSepApplied (NE.toList cs) <+> dcolon <+> pprRecFields vsts ty
+ = commaSepApplied cs <+> dcolon <+> pprRecFields vsts ty
instance Ppr PatSynDir where
ppr Unidir = text "<-"
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -48,7 +48,6 @@ import System.IO ( hPutStrLn, stderr )
import Data.Char ( isAlpha, isAlphaNum, isUpper, ord )
import Data.Int
import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE ( singleton )
import Data.Void ( Void, absurd )
import Data.Word
import Data.Ratio
@@ -2685,7 +2684,7 @@ data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang.
| DecidedUnpack -- ^ Field inferred to be unpacked.
deriving (Show, Eq, Ord, Data, Generic)
--- | A single data constructor.
+-- | A data constructor.
--
-- The constructors for 'Con' can roughly be divided up into two categories:
-- those for constructors with \"vanilla\" syntax ('NormalC', 'RecC', and
@@ -2718,16 +2717,36 @@ data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang.
-- Multiplicity annotations for data types are currently not supported
-- in Template Haskell (i.e. all fields represented by Template Haskell
-- will be linear).
-data Con = NormalC Name [BangType] -- ^ @C Int a@
- | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@
- | InfixC BangType Name BangType -- ^ @Int :+ a@
- | ForallC [TyVarBndr Specificity] Cxt Con -- ^ @forall a. Eq a => C [a]@
- | GadtC (NonEmpty Name) [BangType]
- Type -- See Note [GADT return type]
- -- ^ @C :: a -> b -> T b Int@
- | RecGadtC (NonEmpty Name) [VarBangType]
- Type -- See Note [GADT return type]
- -- ^ @C :: { v :: Int } -> T b Int@
+data Con =
+ -- | @C Int a@
+ NormalC Name [BangType]
+
+ -- | @C { v :: Int, w :: a }@
+ | RecC Name [VarBangType]
+
+ -- | @Int :+ a@
+ | InfixC BangType Name BangType
+
+ -- | @forall a. Eq a => C [a]@
+ | ForallC [TyVarBndr Specificity] Cxt Con
+
+ -- @C :: a -> b -> T b Int@
+ | GadtC [Name]
+ -- ^ The list of constructors, corresponding to the GADT constructor
+ -- syntax @C1, C2 :: a -> T b at .
+ --
+ -- Invariant: the list must be non-empty.
+ [BangType] -- ^ The constructor arguments
+ Type -- ^ See Note [GADT return type]
+
+ -- | @C :: { v :: Int } -> T b Int@
+ | RecGadtC [Name]
+ -- ^ The list of constructors, corresponding to the GADT record
+ -- constructor syntax @C1, C2 :: { fld :: a } -> T b at .
+ --
+ -- Invariant: the list must be non-empty.
+ [VarBangType] -- ^ The constructor arguments
+ Type -- ^ See Note [GADT return type]
deriving (Show, Eq, Ord, Data, Generic)
-- Note [GADT return type]
@@ -2925,14 +2944,14 @@ thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ o2 = o2
thenCmp o1 _ = o1
-get_cons_names :: Con -> NonEmpty Name
-get_cons_names (NormalC n _) = NE.singleton n
-get_cons_names (RecC n _) = NE.singleton n
-get_cons_names (InfixC _ n _) = NE.singleton n
+get_cons_names :: Con -> [Name]
+get_cons_names (NormalC n _) = [n]
+get_cons_names (RecC n _) = [n]
+get_cons_names (InfixC _ n _) = [n]
get_cons_names (ForallC _ _ con) = get_cons_names con
-- GadtC can have multiple names, e.g
-- > data Bar a where
-- > MkBar1, MkBar2 :: a -> Bar a
-- Will have one GadtC with [MkBar1, MkBar2] as names
get_cons_names (GadtC ns _ _) = ns
-get_cons_names (RecGadtC ns _ _) = ns
\ No newline at end of file
+get_cons_names (RecGadtC ns _ _) = ns
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -2,10 +2,6 @@
## 2.21.0.0
- * The `GadtC` and `RecGadtC` constructors of the `Con` datatype now take
- non-empty lists of constructors. This means that the `gadtC` and `recGadtC`
- smart constructors also expect non-empty lists as arguments.
-
* Record fields now belong to separate `NameSpace`s, keyed by the parent of
the record field. This is the name of the first constructor of the parent type,
even if this constructor does not have the field in question.
=====================================
testsuite/tests/cmm/should_run/AtomicFetch.hs
=====================================
@@ -0,0 +1,54 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+-- This is not a test of atomic semantics,
+-- just checking that GHC can parse %fetch_fooXX
+
+import GHC.Exts
+import GHC.Int
+import GHC.ST
+
+foreign import prim "cmm_foo8" cmm_foo8
+ :: MutableByteArray# s -> State# s -> (# State# s, Int8# #)
+
+foreign import prim "cmm_foo16" cmm_foo16
+ :: MutableByteArray# s -> State# s -> (# State# s, Int16# #)
+
+foreign import prim "cmm_foo32" cmm_foo32
+ :: MutableByteArray# s -> State# s -> (# State# s, Int32# #)
+
+foreign import prim "cmm_foo64" cmm_foo64
+ :: MutableByteArray# s -> State# s -> (# State# s, Int64# #)
+
+go8 :: Int8
+go8 = runST $ ST $ \s0 ->
+ case newByteArray# 8# s0 of
+ (# s1, mba #) -> case cmm_foo8 mba s1 of
+ (# s2, n' #) -> (# s2, I8# n' #)
+
+go16 :: Int16
+go16 = runST $ ST $ \s0 ->
+ case newByteArray# 8# s0 of
+ (# s1, mba #) -> case cmm_foo16 mba s1 of
+ (# s2, n' #) -> (# s2, I16# n' #)
+
+go32 :: Int32
+go32 = runST $ ST $ \s0 ->
+ case newByteArray# 8# s0 of
+ (# s1, mba #) -> case cmm_foo32 mba s1 of
+ (# s2, n' #) -> (# s2, I32# n' #)
+
+go64 :: Int64
+go64 = runST $ ST $ \s0 ->
+ case newByteArray# 8# s0 of
+ (# s1, mba #) -> case cmm_foo64 mba s1 of
+ (# s2, n' #) -> (# s2, I64# n' #)
+
+main = do
+ print go8
+ print go16
+ print go32
+ print go64
=====================================
testsuite/tests/cmm/should_run/AtomicFetch.stdout
=====================================
@@ -0,0 +1,4 @@
+-4
+-4
+-4
+-4
=====================================
testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
=====================================
@@ -0,0 +1,80 @@
+#include "Cmm.h"
+
+// This is not a test of atomic semantics,
+// just checking that GHC can parse %fetch_fooXX
+
+cmm_foo64 (P_ p)
+{
+ // p points to a ByteArray header, q points to its first element
+ P_ q;
+ q = p + SIZEOF_StgHeader + WDS(1);
+
+ bits64 x;
+
+ prim %store_seqcst64(q, 42);
+ (x) = prim %fetch_add64(q, 5);
+ (x) = prim %fetch_sub64(q, 10);
+ (x) = prim %fetch_and64(q, 120);
+ (x) = prim %fetch_or64(q, 2);
+ (x) = prim %fetch_xor64(q, 33);
+ (x) = prim %fetch_nand64(q, 127);
+ (x) = prim %load_seqcst64(q);
+ return (x);
+}
+
+cmm_foo32 (P_ p)
+{
+ // p points to a ByteArray header, q points to its first element
+ P_ q;
+ q = p + SIZEOF_StgHeader + WDS(1);
+
+ bits32 x;
+
+ prim %store_seqcst32(q, 42);
+ (x) = prim %fetch_add32(q, 5);
+ (x) = prim %fetch_sub32(q, 10);
+ (x) = prim %fetch_and32(q, 120);
+ (x) = prim %fetch_or32(q, 2);
+ (x) = prim %fetch_xor32(q, 33);
+ (x) = prim %fetch_nand32(q, 127);
+ (x) = prim %load_seqcst32(q);
+ return (x);
+}
+
+cmm_foo16 (P_ p)
+{
+ // p points to a ByteArray header, q points to its first element
+ P_ q;
+ q = p + SIZEOF_StgHeader + WDS(1);
+
+ bits16 x;
+
+ prim %store_seqcst16(q, 42);
+ (x) = prim %fetch_add16(q, 5);
+ (x) = prim %fetch_sub16(q, 10);
+ (x) = prim %fetch_and16(q, 120);
+ (x) = prim %fetch_or16(q, 2);
+ (x) = prim %fetch_xor16(q, 33);
+ (x) = prim %fetch_nand16(q, 127);
+ (x) = prim %load_seqcst16(q);
+ return (x);
+}
+
+cmm_foo8 (P_ p)
+{
+ // p points to a ByteArray header, q points to its first element
+ P_ q;
+ q = p + SIZEOF_StgHeader + WDS(1);
+
+ bits8 x;
+
+ prim %store_seqcst8(q, 42);
+ (x) = prim %fetch_add8(q, 5);
+ (x) = prim %fetch_sub8(q, 10);
+ (x) = prim %fetch_and8(q, 120);
+ (x) = prim %fetch_or8(q, 2);
+ (x) = prim %fetch_xor8(q, 33);
+ (x) = prim %fetch_nand8(q, 127);
+ (x) = prim %load_seqcst8(q);
+ return (x);
+}
=====================================
testsuite/tests/cmm/should_run/all.T
=====================================
@@ -34,3 +34,12 @@ test('T22871',
],
multi_compile_and_run,
['T22871', [('T22871_cmm.cmm', '')], ''])
+
+test('AtomicFetch',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , omit_ways(['ghci'])
+ , req_cmm
+ , when(arch('i386'), skip) # https://gitlab.haskell.org/ghc/ghc/-/issues/23217
+ ],
+ multi_compile_and_run,
+ ['AtomicFetch', [('AtomicFetch_cmm.cmm', '')], ''])
=====================================
testsuite/tests/th/T10828.hs
=====================================
@@ -6,7 +6,6 @@ module T10828 where
import Language.Haskell.TH hiding (Type)
import System.IO
import Data.Kind (Type)
-import qualified Data.List.NonEmpty as NE ( singleton )
$( do { decl <- [d| data family D a :: Type -> Type
data instance D Int Bool :: Type where
@@ -34,7 +33,7 @@ $( return
[ DataD [] (mkName "T")
[ PlainTV (mkName "a") () ]
(Just StarT)
- [ GadtC (NE.singleton (mkName "MkT"))
+ [ GadtC [mkName "MkT"]
[ ( Bang NoSourceUnpackedness NoSourceStrictness
, VarT (mkName "a")
)
@@ -47,7 +46,7 @@ $( return
, ForallC [PlainTV (mkName "a") SpecifiedSpec, PlainTV (mkName "b") SpecifiedSpec]
[AppT (AppT EqualityT (VarT $ mkName "a" ) )
(ConT $ mkName "Int") ] $
- RecGadtC (NE.singleton (mkName "MkC"))
+ RecGadtC [mkName "MkC"]
[ ( mkName "foo"
, Bang NoSourceUnpackedness NoSourceStrictness
, VarT (mkName "a")
=====================================
testsuite/tests/th/T10828b.hs
=====================================
@@ -4,7 +4,6 @@ module T10828b where
import Language.Haskell.TH
import System.IO
-import qualified Data.List.NonEmpty as NE ( singleton )
-- attempting to mix GADT and normal constructors
$( return
@@ -24,7 +23,7 @@ $( return
[AppT (AppT EqualityT (VarT $ mkName "a" ) )
(ConT $ mkName "Int") ] $
RecGadtC
- (NE.singleton (mkName "MkC"))
+ [mkName "MkC"]
[ ( mkName "foo"
, Bang NoSourceUnpackedness NoSourceStrictness
, VarT (mkName "a")
=====================================
testsuite/tests/th/T10828b.stderr
=====================================
@@ -1,5 +1,5 @@
-T10828b.hs:10:2: error: [GHC-24104]
+T10828b.hs:9:2: error: [GHC-24104]
Cannot mix GADT constructors with Haskell 98 constructors
When splicing a TH declaration:
data T a :: *
=====================================
testsuite/tests/th/T11345.hs
=====================================
@@ -5,7 +5,6 @@
module Main (main) where
import Language.Haskell.TH
-import qualified Data.List.NonEmpty as NE ( singleton )
infixr 7 :***:
data GADT a where
@@ -17,11 +16,11 @@ $(do gadtName <- newName "GADT2"
infixName <- newName ":****:"
a <- newName "a"
return [ DataD [] gadtName [KindedTV a () StarT] Nothing
- [ GadtC (NE.singleton prefixName)
+ [ GadtC [prefixName]
[ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
, (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
] (AppT (ConT gadtName) (ConT ''Int))
- , GadtC (NE.singleton infixName)
+ , GadtC [infixName]
[ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
, (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
] (AppT (ConT gadtName) (ConT ''Int))
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a91209581442d7f36121b72a5ca622d6035c950...815449c72ddf3b37b61db83f5f1e721e8a172e49
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a91209581442d7f36121b72a5ca622d6035c950...815449c72ddf3b37b61db83f5f1e721e8a172e49
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230402/64805689/attachment-0001.html>
More information about the ghc-commits
mailing list