[Git][ghc/ghc][wip/T15808] 4 commits: [skip ci] Fix typo in `callocBytes` haddock.
Ben Gamari
gitlab at gitlab.haskell.org
Sat Oct 31 16:36:06 UTC 2020
Ben Gamari pushed to branch wip/T15808 at Glasgow Haskell Compiler / GHC
Commits:
9902d9ec by Viktor Dukhovni at 2020-10-30T05:28:30-04:00
[skip ci] Fix typo in `callocBytes` haddock.
- - - - -
31fcb55f by Ryan Scott at 2020-10-30T18:52:50-04:00
Split HsConDecl{H98,GADT}Details
Haskell98 and GADT constructors both use `HsConDeclDetails`, which includes
`InfixCon`. But `InfixCon` is never used for GADT constructors, which results
in an awkward unrepresentable state. This removes the unrepresentable state by:
* Renaming the existing `HsConDeclDetails` synonym to `HsConDeclH98Details`,
which emphasizes the fact that it is now only used for Haskell98-style data
constructors, and
* Creating a new `HsConDeclGADTDetails` data type with `PrefixConGADT` and
`RecConGADT` constructors that closely resemble `PrefixCon` and `InfixCon`
in `HsConDeclH98Details`. The key difference is that `HsConDeclGADTDetails`
lacks any way to represent infix constructors.
The rest of the patch is refactoring to accommodate the new structure of
`HsConDecl{H98,GADT}Details`. Some highlights:
* The `getConArgs` and `hsConDeclArgTys` functions have been removed, as
there is no way to implement these functions uniformly for all
`ConDecl`s. For the most part, their previous call sites now
pattern match on the `ConDecl`s directly and do different things for
`ConDeclH98`s and `ConDeclGADT`s.
I did introduce one new function to make the transition easier:
`getRecConArgs_maybe`, which extracts the arguments from a `RecCon(GADT)`.
This is still possible since `RecCon(GADT)`s still use the same representation
in both `HsConDeclH98Details` and `HsConDeclGADTDetails`, and since the
pattern that `getRecConArgs_maybe` implements is used in several places,
I thought it worthwhile to factor it out into its own function.
* Previously, the `con_args` fields in `ConDeclH98` and `ConDeclGADT` were
both of type `HsConDeclDetails`. Now, the former is of type
`HsConDeclH98Details`, and the latter is of type `HsConDeclGADTDetails`,
which are distinct types. As a result, I had to rename the `con_args` field
in `ConDeclGADT` to `con_g_args` to make it typecheck.
A consequence of all this is that the `con_args` field is now partial, so
using `con_args` as a top-level field selector is dangerous. (Indeed, Haddock
was using `con_args` at the top-level, which caused it to crash at runtime
before I noticed what was wrong!) I decided to add a disclaimer in the 9.2.1
release notes to advertise this pitfall.
Fixes #18844. Bumps the `haddock` submodule.
- - - - -
2c66bc3a by Ben Gamari at 2020-10-31T12:35:18-04:00
rts/linker: Fix relocation overflow in PE linker
Previously the overflow check for the IMAGE_REL_AMD64_ADDR32NB
relocation failed to account for the signed nature of the value.
Specifically, the overflow check was:
uint64_t v;
v = S + A;
if (v >> 32) { ... }
However, `v` ultimately needs to fit into 32-bits as a signed value.
Consequently, values `v > 2^31` in fact overflow yet this is not caught
by the existing overflow check.
Here we rewrite the overflow check to rather ensure that
`INT32_MIN <= v <= INT32_MAX`. There is now quite a bit of repetition
between the `IMAGE_REL_AMD64_REL32` and `IMAGE_REL_AMD64_ADDR32` cases
but I am leaving fixing this for future work.
This bug was first noticed by @awson.
Fixes #15808.
- - - - -
47dbdc44 by Ben Gamari at 2020-10-31T12:35:18-04:00
rts/linker: Try using m32 to allocate PE symbol extras
- - - - -
28 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/ThToHs.hs
- docs/users_guide/9.2.1-notes.rst
- libraries/base/Foreign/Marshal/Alloc.hs
- rts/Linker.c
- rts/LinkerInternals.h
- rts/linker/M32Alloc.c
- rts/linker/M32Alloc.h
- rts/linker/PEi386.c
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T15323.stderr
- testsuite/tests/printer/T18791.stderr
- utils/haddock
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -74,8 +74,8 @@ module GHC.Hs.Decls (
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl,
- HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,
- getConNames, getConArgs,
+ HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,
+ getConNames, getRecConArgs_maybe,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
@@ -1476,9 +1476,9 @@ data ConDecl pass
-- Whether or not there is an /explicit/ forall, we still
-- need to capture the implicitly-bound type/kind variables
- , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
- , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon
- , con_res_ty :: LHsType pass -- ^ Result type
+ , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
+ , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix
+ , con_res_ty :: LHsType pass -- ^ Result type
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
@@ -1495,7 +1495,7 @@ data ConDecl pass
-- False => con_ex_tvs is empty
, con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only
, con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)
- , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon
+ , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
@@ -1626,27 +1626,35 @@ or contexts in two parts:
quantification occurs after a visible argument type.
-}
--- | Haskell data Constructor Declaration Details
-type HsConDeclDetails pass
+-- | The arguments in a Haskell98-style data constructor.
+type HsConDeclH98Details pass
= HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
+-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors,
+-- GADT constructors cannot be declared with infix syntax. As a result, we do
+-- not use 'HsConDetails' here, as 'InfixCon' would be an unrepresentable
+-- state. (There is a notion of infix GADT constructors for the purposes of
+-- derived Show instances—see Note [Infix GADT constructors] in
+-- GHC.Tc.TyCl—but that is an orthogonal concern.)
+data HsConDeclGADTDetails pass
+ = PrefixConGADT [HsScaled pass (LBangType pass)]
+ | RecConGADT (XRec pass [LConDeclField pass])
+
getConNames :: ConDecl GhcRn -> [Located Name]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
-getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn
-getConArgs d = con_args d
-
-hsConDeclArgTys :: HsConDeclDetails (GhcPass p) -> [HsScaled (GhcPass p) (LBangType (GhcPass p))]
-hsConDeclArgTys (PrefixCon tys) = tys
-hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
-hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds)
- -- Remark: with the record syntax, constructors have all their argument
- -- linear, despite the fact that projections do not make sense on linear
- -- constructors. The design here is that the record projection themselves are
- -- typed to take an unrestricted argument (that is the record itself is
- -- unrestricted). By the transfer property, projections are then correct in
- -- that all the non-projected fields have multiplicity Many, and can be dropped.
+-- | Return @'Just' fields@ if a data constructor declaration uses record
+-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.
+-- Otherwise, return 'Nothing'.
+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (Located [LConDeclField GhcRn])
+getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of
+ PrefixCon{} -> Nothing
+ RecCon flds -> Just flds
+ InfixCon{} -> Nothing
+getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of
+ PrefixConGADT{} -> Nothing
+ RecConGADT flds -> Just flds
hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]
hsConDeclTheta Nothing = []
@@ -1726,15 +1734,14 @@ pprConDecl (ConDeclH98 { con_name = L _ con
cxt = fromMaybe noLHsContext mcxt
pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
- , con_mb_cxt = mcxt, con_args = args
+ , con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc })
= ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon
<+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt,
ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])
where
- get_args (PrefixCon args) = map ppr args
- get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]
- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)
+ get_args (PrefixConGADT args) = map ppr args
+ get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)]
cxt = fromMaybe noLHsContext mcxt
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -173,6 +173,11 @@ deriving instance Data (ConDecl GhcPs)
deriving instance Data (ConDecl GhcRn)
deriving instance Data (ConDecl GhcTc)
+-- deriving instance DataIdLR p p => Data (HsConDeclGADTDetails p)
+deriving instance Data (HsConDeclGADTDetails GhcPs)
+deriving instance Data (HsConDeclGADTDetails GhcRn)
+deriving instance Data (HsConDeclGADTDetails GhcTc)
+
-- deriving instance DataIdLR p p => Data (TyFamInstDecl p)
deriving instance Data (TyFamInstDecl GhcPs)
deriving instance Data (TyFamInstDecl GhcRn)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -1102,9 +1102,22 @@ instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
--- HsConDetails is used for patterns/expressions *and* for data type
--- declarations
--- | Haskell Constructor Details
+-- | Describes the arguments to a data constructor. This is a common
+-- representation for several constructor-related concepts, including:
+--
+-- * The arguments in a Haskell98-style constructor declaration
+-- (see 'HsConDeclH98Details' in "GHC.Hs.Decls").
+--
+-- * The arguments in constructor patterns in @case@/function definitions
+-- (see 'HsConPatDetails' in "GHC.Hs.Pat").
+--
+-- * The left-hand side arguments in a pattern synonym binding
+-- (see 'HsPatSynDetails' in "GHC.Hs.Binds").
+--
+-- One notable exception is the arguments in a GADT constructor, which uses
+-- a separate data type entirely (see 'HsConDeclGADTDetails' in
+-- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with
+-- infix syntax, unlike the concepts above (#18844).
data HsConDetails arg rec
= PrefixCon [arg] -- C p1 p2 p3
| RecCon rec -- C { x = p1, y = p2 }
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1259,29 +1259,36 @@ hsConDeclsBinders cons
in case unLoc r of
-- remove only the first occurrence of any seen field in order to
-- avoid circumventing detection of duplicate fields (#9156)
- ConDeclGADT { con_names = names, con_args = args }
+ ConDeclGADT { con_names = names, con_g_args = args }
-> (map (L loc . unLoc) names ++ ns, flds ++ fs)
where
- (remSeen', flds) = get_flds remSeen args
+ (remSeen', flds) = get_flds_gadt remSeen args
(ns, fs) = go remSeen' rs
ConDeclH98 { con_name = name, con_args = args }
-> ([L loc (unLoc name)] ++ ns, flds ++ fs)
where
- (remSeen', flds) = get_flds remSeen args
+ (remSeen', flds) = get_flds_h98 remSeen args
(ns, fs) = go remSeen' rs
- get_flds :: Seen p -> HsConDeclDetails (GhcPass p)
+ get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)
+ -> (Seen p, [LFieldOcc (GhcPass p)])
+ get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds
+ get_flds_h98 remSeen _ = (remSeen, [])
+
+ get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)
+ -> (Seen p, [LFieldOcc (GhcPass p)])
+ get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds
+ get_flds_gadt remSeen _ = (remSeen, [])
+
+ get_flds :: Seen p -> Located [LConDeclField (GhcPass p)]
-> (Seen p, [LFieldOcc (GhcPass p)])
- get_flds remSeen (RecCon flds)
- = (remSeen', fld_names)
+ get_flds remSeen flds = (remSeen', fld_names)
where
fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
remSeen' = foldr (.) remSeen
[deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
| v <- fld_names]
- get_flds remSeen _
- = (remSeen, [])
{-
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -189,7 +189,7 @@ subordinates instMap decl = case decl of
, conArgDocs c)
| c <- cons, cname <- getConNames c ]
fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
- | RecCon flds <- map getConArgs cons
+ | Just flds <- map getRecConArgs_maybe cons
, (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
, (L _ n) <- ns ]
derivs = [ (instName, [unLoc doc], M.empty)
@@ -216,22 +216,30 @@ subordinates instMap decl = case decl of
_ -> Nothing
-- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
-conArgDocs con = case getConArgs con of
- PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)
- InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),
- unLoc (hsScaledThing arg2)] ++ ret)
- RecCon _ -> go 1 ret
+conArgDocs :: ConDecl GhcRn -> Map Int HsDocString
+conArgDocs (ConDeclH98{con_args = args}) =
+ h98ConArgDocs args
+conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
+ gadtConArgDocs args (unLoc res_ty)
+
+h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString
+h98ConArgDocs con_args = case con_args of
+ PrefixCon args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
+ InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
+ , unLoc (hsScaledThing arg2) ]
+ RecCon _ -> M.empty
+
+gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> Map Int HsDocString
+gadtConArgDocs con_args res_ty = case con_args of
+ PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
+ RecConGADT _ -> con_arg_docs 1 [res_ty]
+
+con_arg_docs :: Int -> [HsType GhcRn] -> Map Int HsDocString
+con_arg_docs n = M.fromList . catMaybes . zipWith f [n..]
where
- go n = M.fromList . catMaybes . zipWith f [n..]
- where
- f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
- f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
- f _ _ = Nothing
-
- ret = case con of
- ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
- _ -> []
+ f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
+ f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
+ f _ _ = Nothing
isValD :: HsDecl a -> Bool
isValD (ValD _ _) = True
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -877,7 +877,7 @@ repC (L _ (ConDeclH98 { con_name = con
, con_forall = (L _ False)
, con_mb_cxt = Nothing
, con_args = args }))
- = repDataCon con args
+ = repH98DataCon con args
repC (L _ (ConDeclH98 { con_name = con
, con_forall = L _ is_existential
@@ -885,7 +885,7 @@ repC (L _ (ConDeclH98 { con_name = con
, con_mb_cxt = mcxt
, con_args = args }))
= do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
- do { c' <- repDataCon con args
+ do { c' <- repH98DataCon con args
; ctxt' <- repMbContext mcxt
; if not is_existential && isNothing mcxt
then return c'
@@ -897,7 +897,7 @@ repC (L _ (ConDeclGADT { con_g_ext = imp_tvs
, con_names = cons
, con_qvars = exp_tvs
, con_mb_cxt = mcxt
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty }))
| null imp_tvs && null exp_tvs -- No implicit or explicit variables
, Nothing <- mcxt -- No context
@@ -2589,49 +2589,51 @@ repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
repCtxt (MkC tys) = rep2 cxtName [tys]
-repDataCon :: Located Name
- -> HsConDeclDetails GhcRn
- -> MetaM (Core (M TH.Con))
-repDataCon con details
+repH98DataCon :: Located Name
+ -> HsConDeclH98Details GhcRn
+ -> MetaM (Core (M TH.Con))
+repH98DataCon con details
= do con' <- lookupLOcc con -- See Note [Binders and occurrences]
- repConstr details Nothing [con']
+ case details of
+ PrefixCon ps -> do
+ arg_tys <- repPrefixConArgs ps
+ rep2 normalCName [unC con', unC arg_tys]
+ InfixCon st1 st2 -> do
+ arg1 <- repBangTy (hsScaledThing st1)
+ arg2 <- repBangTy (hsScaledThing st2)
+ rep2 infixCName [unC arg1, unC con', unC arg2]
+ RecCon ips -> do
+ arg_vtys <- repRecConArgs ips
+ rep2 recCName [unC con', unC arg_vtys]
repGadtDataCons :: [Located Name]
- -> HsConDeclDetails GhcRn
+ -> HsConDeclGADTDetails GhcRn
-> LHsType GhcRn
-> MetaM (Core (M TH.Con))
repGadtDataCons cons details res_ty
= do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
- repConstr details (Just res_ty) cons'
-
--- Invariant:
--- * for plain H98 data constructors second argument is Nothing and third
--- argument is a singleton list
--- * for GADTs data constructors second argument is (Just return_type) and
--- third argument is a non-empty list
-repConstr :: HsConDeclDetails GhcRn
- -> Maybe (LHsType GhcRn)
- -> [Core TH.Name]
- -> MetaM (Core (M TH.Con))
-repConstr (PrefixCon ps) Nothing [con]
- = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
- rep2 normalCName [unC con, unC arg_tys]
-
-repConstr (PrefixCon ps) (Just res_ty) cons
- = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
- res_ty' <- repLTy res_ty
- rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
-
-repConstr (RecCon ips) resTy cons
- = do args <- concatMapM rep_ip (unLoc ips)
- arg_vtys <- coreListM varBangTypeTyConName args
- case resTy of
- Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
- Just res_ty -> do
+ case details of
+ PrefixConGADT ps -> do
+ arg_tys <- repPrefixConArgs ps
res_ty' <- repLTy res_ty
- rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+ 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 (nonEmptyCoreList cons'), unC arg_vtys,
unC res_ty']
+-- Desugar the arguments in a data constructor declared with prefix syntax.
+repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]
+ -> MetaM (Core [M TH.BangType])
+repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
+
+-- Desugar the arguments in a data constructor declared with record syntax.
+repRecConArgs :: Located [LConDeclField GhcRn]
+ -> MetaM (Core [M TH.VarBangType])
+repRecConArgs ips = do
+ args <- concatMapM rep_ip (unLoc ips)
+ coreListM varBangTypeTyConName args
where
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
@@ -2640,16 +2642,6 @@ repConstr (RecCon ips) resTy cons
; MkC ty <- repBangTy t
; rep2 varBangTypeName [v,ty] }
-repConstr (InfixCon st1 st2) Nothing [con]
- = do arg1 <- repBangTy (hsScaledThing st1)
- arg2 <- repBangTy (hsScaledThing st2)
- rep2 infixCName [unC arg1, unC con, unC arg2]
-
-repConstr (InfixCon {}) (Just _) _ =
- panic "repConstr: infix GADT constructor should be in a PrefixCon"
-repConstr _ _ _ =
- panic "repConstr: invariant violated"
-
------------ Types -------------------
repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1321,6 +1321,10 @@ instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
toHie (RecCon rec) = toHie rec
toHie (InfixCon a b) = concatM [ toHie a, toHie b]
+instance ToHie (HsConDeclGADTDetails GhcRn) where
+ toHie (PrefixConGADT args) = toHie args
+ toHie (RecConGADT rec) = toHie rec
+
instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where
toHie (L span top) = concatM $ makeNode top span : case top of
HsCmdTop _ cmd ->
@@ -1532,7 +1536,7 @@ instance ToHie a => ToHie (HsScaled GhcRn a) where
instance ToHie (Located (ConDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
- , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
+ , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->
[ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
, concatM $ [ bindingsOnly bindings
, toHie $ tvScopes resScope NoScope exp_vars ]
@@ -1543,7 +1547,9 @@ instance ToHie (Located (ConDecl GhcRn)) where
where
rhsScope = combineScopes argsScope tyScope
ctxScope = maybe NoScope mkLScope ctx
- argsScope = condecl_scope args
+ argsScope = case args of
+ PrefixConGADT xs -> scaled_args_scope xs
+ RecConGADT x -> mkLScope x
tyScope = mkLScope typ
resScope = ResolvedScopes [ctxScope, rhsScope]
bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars
@@ -1557,13 +1563,12 @@ instance ToHie (Located (ConDecl GhcRn)) where
where
rhsScope = combineScopes ctxScope argsScope
ctxScope = maybe NoScope mkLScope ctx
- argsScope = condecl_scope dets
- where condecl_scope :: HsConDeclDetails (GhcPass p) -> Scope
- condecl_scope args = case args of
- PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs
- InfixCon a b -> combineScopes (mkLScope (hsScaledThing a))
- (mkLScope (hsScaledThing b))
- RecCon x -> mkLScope x
+ argsScope = case dets of
+ PrefixCon xs -> scaled_args_scope xs
+ InfixCon a b -> scaled_args_scope [a, b]
+ RecCon x -> mkLScope x
+ where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope
+ scaled_args_scope = foldr combineScopes NoScope . map (mkLScope . hsScaledThing)
instance ToHie (Located [Located (ConDeclField GhcRn)]) where
toHie (L span decls) = concatM $
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2330,7 +2330,7 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
: 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }
| {- empty -} { noLoc ([], Nothing) }
-constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) }
+constr_stuff :: { Located (Located RdrName, HsConDeclH98Details GhcPs) }
: infixtype {% fmap (mapLoc (\b -> (dataConBuilderCon b,
dataConBuilderDetails b)))
(runPV $1) }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -611,7 +611,7 @@ recordPatSynErr loc pat =
addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc
mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]
- -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs
+ -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs
-> ConDecl GhcPs
mkConDeclH98 name mb_forall mb_cxt args
@@ -636,17 +636,17 @@ mkGadtDecl :: [Located RdrName]
mkGadtDecl names ty = do
let (args, res_ty, anns)
| L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty
- = (RecCon (L loc rf), res_ty, [])
+ = (RecConGADT (L loc rf), res_ty, [])
| otherwise
= let (arg_types, res_type, anns) = splitHsFunType body_ty
- in (PrefixCon arg_types, res_type, anns)
+ in (PrefixConGADT arg_types, res_type, anns)
pure ( ConDeclGADT { con_g_ext = noExtField
, con_names = names
, con_forall = L (getLoc ty) $ isJust mtvs
, con_qvars = fromMaybe [] mtvs
, con_mb_cxt = mcxt
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
, anns )
@@ -1618,7 +1618,7 @@ dataConBuilderCon :: DataConBuilder -> Located RdrName
dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
-dataConBuilderDetails :: DataConBuilder -> HsConDeclDetails GhcPs
+dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
-- Detect when the record syntax is used:
-- data T = MkT { ... }
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -690,22 +690,21 @@ instance HasHaddock (Located (ConDecl GhcPs)) where
addHaddock (L l_con_decl con_decl) =
extendHdkA l_con_decl $
case con_decl of
- ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do
+ ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_g_args, con_res_ty } -> do
-- discardHasInnerDocs is ok because we don't need this info for GADTs.
con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names))
- con_args' <-
- case con_args of
- PrefixCon ts -> PrefixCon <$> addHaddock ts
- RecCon (L l_rec flds) -> do
+ con_g_args' <-
+ case con_g_args of
+ PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts
+ RecConGADT (L l_rec flds) -> do
-- discardHasInnerDocs is ok because we don't need this info for GADTs.
flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds
- pure $ RecCon (L l_rec flds')
- InfixCon _ _ -> panic "ConDeclGADT InfixCon"
+ pure $ RecConGADT (L l_rec flds')
con_res_ty' <- addHaddock con_res_ty
pure $ L l_con_decl $
ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt,
con_doc = con_doc',
- con_args = con_args',
+ con_g_args = con_g_args',
con_res_ty = con_res_ty' }
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->
addConTrailingDoc (srcSpanEnd l_con_decl) $
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -29,9 +29,9 @@ module GHC.Rename.HsType (
rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,
FreeKiTyVars,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
- extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,
+ extractHsTysRdrTyVars, extractRdrKindSigVars,
+ extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
extractHsTvBndrs, extractHsTyArgRdrKiTyVars,
- extractHsScaledTysRdrTyVars,
forAllOrNothing, nubL
) where
@@ -1747,9 +1747,6 @@ extractHsTyArgRdrKiTyVars args
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars ty = extract_lty ty []
-extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars
-extractHsScaledTysRdrTyVars args acc = foldr (\(HsScaled m ty) -> extract_lty ty . extract_hs_arrow m) acc args
-
-- | Extracts the free type/kind variables from the kind signature of a HsType.
-- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k at .
-- The left-to-right order of variables is preserved.
@@ -1787,6 +1784,15 @@ extractRdrKindSigVars (L _ resultSig) = case resultSig of
TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k
_ -> []
+-- | Extracts free type and kind variables from an argument in a GADT
+-- constructor, returning variable occurrences in left-to-right order.
+-- See @Note [Ordering of implicit variables]@.
+extractConDeclGADTDetailsTyVars ::
+ HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
+extractConDeclGADTDetailsTyVars con_args = case con_args of
+ PrefixConGADT args -> extract_scaled_ltys args
+ RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds
+
-- | Get type/kind variables mentioned in the kind signature, preserving
-- left-to-right order:
--
@@ -1801,6 +1807,14 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lctxt ctxt = extract_ltys (unLoc ctxt)
+extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]
+ -> FreeKiTyVars -> FreeKiTyVars
+extract_scaled_ltys args acc = foldr extract_scaled_lty acc args
+
+extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)
+ -> FreeKiTyVars -> FreeKiTyVars
+extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc
+
extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_ltys tys acc = foldr extract_lty acc tys
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2181,7 +2181,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
; bindLHsTyVarBndrs ctxt WarnUnusedForalls
Nothing ex_tvs $ \ new_ex_tvs ->
do { (new_context, fvs1) <- rnMbContext ctxt mcxt
- ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+ ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args
; let all_fvs = fvs1 `plusFV` fvs2
; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat
[ text "ex_tvs:" <+> ppr ex_tvs
@@ -2198,15 +2198,12 @@ rnConDecl decl@(ConDeclGADT { con_names = names
, con_forall = forall@(L _ explicit_forall)
, con_qvars = explicit_tkvs
, con_mb_cxt = mcxt
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty
, con_doc = mb_doc })
= do { mapM_ (addLocM checkConName) names
; new_names <- mapM lookupLocatedTopBndrRn names
- ; let theta = hsConDeclTheta mcxt
- arg_tys = hsConDeclArgTys args
-
-- We must ensure that we extract the free tkvs in left-to-right
-- order of their appearance in the constructor type.
-- That order governs the order the implicitly-quantified type
@@ -2214,9 +2211,9 @@ rnConDecl decl@(ConDeclGADT { con_names = names
-- See #14808.
; implicit_bndrs <- forAllOrNothing explicit_forall
$ extractHsTvBndrs explicit_tkvs
- $ extractHsTysRdrTyVars theta
- $ extractHsScaledTysRdrTyVars arg_tys
- $ extractHsTysRdrTyVars [res_ty] []
+ $ extractHsTysRdrTyVars (hsConDeclTheta mcxt)
+ $ extractConDeclGADTDetailsTyVars args
+ $ extractHsTyRdrTyVars res_ty
; let ctxt = ConDeclCtx new_names
@@ -2224,7 +2221,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names
bindLHsTyVarBndrs ctxt WarnUnusedForalls
Nothing explicit_tkvs $ \ explicit_tkvs ->
do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
- ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+ ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
-- Ensure that there are no nested `forall`s or contexts, per
@@ -2239,7 +2236,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names
(ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
; return (decl { con_g_ext = implicit_tkvs, con_names = new_names
, con_qvars = explicit_tkvs, con_mb_cxt = new_cxt
- , con_args = new_args, con_res_ty = new_res_ty
+ , con_g_args = new_args, con_res_ty = new_res_ty
, con_doc = mb_doc
, con_forall = forall }, -- Remove when #18311 is fixed
all_fvs) } }
@@ -2250,27 +2247,45 @@ rnMbContext _ Nothing = return (Nothing, emptyFVs)
rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
; return (Just ctx',fvs) }
-rnConDeclDetails
- :: Name
+rnConDeclH98Details ::
+ Name
-> HsDocContext
- -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs])
- -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]),
- FreeVars)
-rnConDeclDetails _ doc (PrefixCon tys)
+ -> HsConDeclH98Details GhcPs
+ -> RnM (HsConDeclH98Details GhcRn, FreeVars)
+rnConDeclH98Details _ doc (PrefixCon tys)
= do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
; return (PrefixCon new_tys, fvs) }
-
-rnConDeclDetails _ doc (InfixCon ty1 ty2)
+rnConDeclH98Details _ doc (InfixCon ty1 ty2)
= do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1
; (new_ty2, fvs2) <- rnScaledLHsType doc ty2
; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
+rnConDeclH98Details con doc (RecCon flds)
+ = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
+ ; return (RecCon new_flds, fvs) }
-rnConDeclDetails con doc (RecCon (L l fields))
+rnConDeclGADTDetails ::
+ Name
+ -> HsDocContext
+ -> HsConDeclGADTDetails GhcPs
+ -> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
+rnConDeclGADTDetails _ doc (PrefixConGADT tys)
+ = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
+ ; return (PrefixConGADT new_tys, fvs) }
+rnConDeclGADTDetails con doc (RecConGADT flds)
+ = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
+ ; return (RecConGADT new_flds, fvs) }
+
+rnRecConDeclFields ::
+ Name
+ -> HsDocContext
+ -> Located [LConDeclField GhcPs]
+ -> RnM (Located [LConDeclField GhcRn], FreeVars)
+rnRecConDeclFields con doc (L l fields)
= do { fls <- lookupConstructorFields con
; (new_fields, fvs) <- rnConDeclFields doc fls fields
-- No need to check for duplicate fields
-- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
- ; return (RecCon (L l new_fields), fvs) }
+ ; pure (L l new_fields, fvs) }
-------------------------------------------------
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -775,7 +775,7 @@ getLocalNonValBinders fixity_env
= [( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds) )]
find_con_flds (L _ (ConDeclGADT { con_names = rdrs
- , con_args = RecCon flds }))
+ , con_g_args = RecConGADT flds }))
= [ ( find_con_name rdr
, concatMap find_con_decl_flds (unLoc flds))
| L _ rdr <- rdrs ]
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1574,7 +1574,7 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
-------------------
--- Type check the types of the arguments to a data constructor.
+-- Kind-check the types of the arguments to a data constructor.
-- This includes doing kind unification if the type is a newtype.
-- See Note [Implementation of UnliftedNewtypes] for why we need
-- the first two arguments.
@@ -1587,6 +1587,21 @@ kcConArgTys new_or_data res_kind arg_tys = do
-- See Note [Implementation of UnliftedNewtypes], STEP 2
}
+-- Kind-check the types of arguments to a Haskell98 data constructor.
+kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()
+kcConH98Args new_or_data res_kind con_args = case con_args of
+ PrefixCon tys -> kcConArgTys new_or_data res_kind tys
+ InfixCon ty1 ty2 -> kcConArgTys new_or_data res_kind [ty1, ty2]
+ RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $
+ map (hsLinear . cd_fld_type . unLoc) flds
+
+-- Kind-check the types of arguments to a GADT data constructor.
+kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()
+kcConGADTArgs new_or_data res_kind con_args = case con_args of
+ PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys
+ RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $
+ map (hsLinear . cd_fld_type . unLoc) flds
+
kcConDecls :: NewOrData
-> Kind -- The result kind signature
-> [LConDecl GhcRn] -- The data constructors
@@ -1615,14 +1630,14 @@ kcConDecl new_or_data res_kind (ConDeclH98
discardResult $
bindExplicitTKBndrs_Tv ex_tvs $
do { _ <- tcHsMbContext ex_ctxt
- ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)
+ ; kcConH98Args new_or_data res_kind args
-- We don't need to check the telescope here,
-- because that's done in tcConDecl
}
kcConDecl new_or_data res_kind (ConDeclGADT
{ con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt
- , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms })
+ , con_g_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms })
= -- Even though the GADT-style data constructor's type is closed,
-- we must still kind-check the type, because that may influence
-- the inferred kind of the /type/ constructor. Example:
@@ -1636,7 +1651,7 @@ kcConDecl new_or_data res_kind (ConDeclGADT
bindExplicitTKBndrs_Tv explicit_tkv_nms $
-- Why "_Tv"? See Note [Kind-checking for GADTs]
do { _ <- tcHsMbContext cxt
- ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)
+ ; kcConGADTArgs new_or_data res_kind args
; _ <- tcHsOpenType res_ty
; return () }
@@ -3207,7 +3222,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data
bindExplicitTKBndrs_Skol explicit_tkv_nms $
do { ctxt <- tcHsMbContext hs_ctxt
; let exp_kind = getArgExpKind new_or_data res_kind
- ; btys <- tcConArgs exp_kind hs_args
+ ; btys <- tcConH98Args exp_kind hs_args
; field_lbls <- lookupConstructorFields name
; let (arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, field_lbls, stricts)
@@ -3277,7 +3292,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
(ConDeclGADT { con_g_ext = implicit_tkv_nms
, con_names = names
, con_qvars = explicit_tkv_nms
- , con_mb_cxt = cxt, con_args = hs_args
+ , con_mb_cxt = cxt, con_g_args = hs_args
, con_res_ty = hs_res_ty })
= addErrCtxt (dataConCtxtName names) $
do { traceTc "tcConDecl 1 gadt" (ppr names)
@@ -3294,7 +3309,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
-- See Note [Datatype return kinds]
; let exp_kind = getArgExpKind new_or_data res_kind
- ; btys <- tcConArgs exp_kind hs_args
+ ; btys <- tcConGADTArgs exp_kind hs_args
; let (arg_tys, stricts) = unzip btys
; field_lbls <- lookupConstructorFields name
; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
@@ -3373,48 +3388,50 @@ getArgExpKind NewType res_ki = TheKind res_ki
getArgExpKind DataType _ = OpenKind
tcConIsInfixH98 :: Name
- -> HsConDetails a b
+ -> HsConDeclH98Details GhcRn
-> TcM Bool
tcConIsInfixH98 _ details
= case details of
- InfixCon {} -> return True
- _ -> return False
+ InfixCon{} -> return True
+ RecCon{} -> return False
+ PrefixCon{} -> return False
tcConIsInfixGADT :: Name
- -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r
+ -> HsConDeclGADTDetails GhcRn
-> TcM Bool
tcConIsInfixGADT con details
= case details of
- InfixCon {} -> return True
- RecCon {} -> return False
- PrefixCon arg_tys -- See Note [Infix GADT constructors]
+ RecConGADT{} -> return False
+ PrefixConGADT arg_tys -- See Note [Infix GADT constructors]
| isSymOcc (getOccName con)
, [_ty1,_ty2] <- map hsScaledThing arg_tys
-> do { fix_env <- getFixityEnv
; return (con `elemNameEnv` fix_env) }
| otherwise -> return False
-tcConArgs :: ContextKind -- expected kind of arguments
- -- always OpenKind for datatypes, but unlifted newtypes
- -- might have a specific kind
- -> HsConDeclDetails GhcRn
- -> TcM [(Scaled TcType, HsSrcBang)]
-tcConArgs exp_kind (PrefixCon btys)
+tcConH98Args :: ContextKind -- expected kind of arguments
+ -- always OpenKind for datatypes, but unlifted newtypes
+ -- might have a specific kind
+ -> HsConDeclH98Details GhcRn
+ -> TcM [(Scaled TcType, HsSrcBang)]
+tcConH98Args exp_kind (PrefixCon btys)
= mapM (tcConArg exp_kind) btys
-tcConArgs exp_kind (InfixCon bty1 bty2)
+tcConH98Args exp_kind (InfixCon bty1 bty2)
= do { bty1' <- tcConArg exp_kind bty1
; bty2' <- tcConArg exp_kind bty2
; return [bty1', bty2'] }
-tcConArgs exp_kind (RecCon fields)
+tcConH98Args exp_kind (RecCon fields)
+ = tcRecConDeclFields exp_kind fields
+
+tcConGADTArgs :: ContextKind -- expected kind of arguments
+ -- always OpenKind for datatypes, but unlifted newtypes
+ -- might have a specific kind
+ -> HsConDeclGADTDetails GhcRn
+ -> TcM [(Scaled TcType, HsSrcBang)]
+tcConGADTArgs exp_kind (PrefixConGADT btys)
= mapM (tcConArg exp_kind) btys
- where
- -- We need a one-to-one mapping from field_names to btys
- combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))
- (unLoc fields)
- explode (ns,ty) = zip ns (repeat ty)
- exploded = concatMap explode combined
- (_,btys) = unzip exploded
-
+tcConGADTArgs exp_kind (RecConGADT fields)
+ = tcRecConDeclFields exp_kind fields
tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes,
-- but might be an unlifted type with UnliftedNewtypes
@@ -3426,6 +3443,19 @@ tcConArg exp_kind (HsScaled w bty)
; traceTc "tcConArg 2" (ppr bty)
; return (Scaled w' arg_ty, getBangStrictness bty) }
+tcRecConDeclFields :: ContextKind
+ -> Located [LConDeclField GhcRn]
+ -> TcM [(Scaled TcType, HsSrcBang)]
+tcRecConDeclFields exp_kind fields
+ = mapM (tcConArg exp_kind) btys
+ where
+ -- We need a one-to-one mapping from field_names to btys
+ combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))
+ (unLoc fields)
+ explode (ns,ty) = zip ns (repeat ty)
+ exploded = concatMap explode combined
+ (_,btys) = unzip exploded
+
tcDataConMult :: HsArrow GhcRn -> TcM Mult
tcDataConMult arr@(HsUnrestrictedArrow _) = do
-- See Note [Function arrows in GADT constructors]
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -622,7 +622,7 @@ cvtConstr (GadtC c strtys ty)
= do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys
; ty' <- cvtType ty
- ; returnL $ mk_gadt_decl c' (PrefixCon $ map hsLinear args) ty'}
+ ; returnL $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}
cvtConstr (RecGadtC [] _varstrtys _ty)
= failWith (text "RecGadtC must have at least one constructor name")
@@ -631,9 +631,9 @@ cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c
; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys
- ; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' }
+ ; returnL $ mk_gadt_decl c' (RecConGADT $ noLoc rec_flds) ty' }
-mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs
+mk_gadt_decl :: [Located RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
-> ConDecl GhcPs
mk_gadt_decl names args res_ty
= ConDeclGADT { con_g_ext = noExtField
@@ -641,7 +641,7 @@ mk_gadt_decl names args res_ty
, con_forall = noLoc False
, con_qvars = []
, con_mb_cxt = Nothing
- , con_args = args
+ , con_g_args = args
, con_res_ty = res_ty
, con_doc = Nothing }
=====================================
docs/users_guide/9.2.1-notes.rst
=====================================
@@ -43,14 +43,52 @@ Compiler
- ``Void#`` is now a type synonym for the unboxed tuple ``(# #)``.
Code using ``Void#`` now has to enable :extension:`UnboxedTuples`.
+``ghc`` library
+~~~~~~~~~~~~~
+
+- The ``con_args`` field of ``ConDeclGADT`` has been renamed to ``con_g_args``.
+ This is because the type of ``con_g_args`` is now different from the type of
+ the ``con_args`` field in ``ConDeclH98``: ::
+
+ data ConDecl pass
+ = ConDeclGADT
+ { ...
+ , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix
+ , ...
+ }
+
+ | ConDeclH98
+ { ...
+ , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix
+ , ...
+ }
+
+ Where: ::
+
+ -- Introduced in GHC 9.2; was called `HsConDeclDetails` in previous versions of GHC
+ type HsConDeclH98Details pass
+ = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
+
+ -- Introduced in GHC 9.2
+ data HsConDeclGADTDetails pass
+ = PrefixConGADT [HsScaled pass (LBangType pass)]
+ | RecConGADT (XRec pass [LConDeclField pass])
+
+ Unlike Haskell98-style constructors, GADT constructors cannot be declared
+ using infix syntax, which is why ``HsConDeclGADTDetails`` lacks an
+ ``InfixConGADT`` constructor.
+
+ As a result of all this, the ``con_args`` field is now partial, so using
+ ``con_args`` as a top-level field selector is discouraged.
+
``base`` library
~~~~~~~~~~~~~~~~
-- It's possible now to promote the ``Natural`` type: ::
-
+- It's possible now to promote the ``Natural`` type: ::
+
data Coordinate = Mk2D Natural Natural
type MyCoordinate = Mk2D 1 10
-
+
The separate kind ``Nat`` is removed and now it is just a type synonym for
``Natural``. As a consequence, one must enable ``TypeSynonymInstances``
in order to define instances for ``Nat``.
=====================================
libraries/base/Foreign/Marshal/Alloc.hs
=====================================
@@ -99,7 +99,7 @@ calloc = callocBytes (sizeOf (undefined :: a))
mallocBytes :: Int -> IO (Ptr a)
mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size))
--- |Llike 'mallocBytes' but memory is filled with bytes of value zero.
+-- |Like 'mallocBytes', but memory is filled with bytes of value zero.
--
callocBytes :: Int -> IO (Ptr a)
callocBytes size = failWhenNULL "calloc" $ _calloc 1 (fromIntegral size)
=====================================
rts/Linker.c
=====================================
@@ -1351,7 +1351,7 @@ void freeObjectCode (ObjectCode *oc)
ocDeinit_ELF(oc);
#endif
-#if RTS_LINKER_USE_MMAP == 1
+#if defined(USE_M32)
m32_allocator_free(oc->rx_m32);
m32_allocator_free(oc->rw_m32);
#endif
@@ -1422,7 +1422,7 @@ mkOc( pathchar *path, char *image, int imageSize,
/* chain it onto the list of objects */
oc->next = NULL;
-#if RTS_LINKER_USE_MMAP
+#if defined(USE_M32)
oc->rw_m32 = m32_allocator_new(false);
oc->rx_m32 = m32_allocator_new(true);
#endif
=====================================
rts/LinkerInternals.h
=====================================
@@ -21,6 +21,36 @@ void printLoadedObjects(void);
#include "BeginPrivate.h"
+/*************************************************
+ * Various bits of configuration
+ *************************************************/
+
+/* PowerPC and ARM have relative branch instructions with only 24 bit
+ * displacements and therefore need jump islands contiguous with each object
+ * code module.
+ */
+#if defined(powerpc_HOST_ARCH)
+#define SHORT_REL_BRANCH 1
+#endif
+#if defined(arm_HOST_ARCH)
+#define SHORT_REL_BRANCH 1
+#endif
+
+#if (RTS_LINKER_USE_MMAP && defined(SHORT_REL_BRANCH) && defined(linux_HOST_OS))
+#define USE_CONTIGUOUS_MMAP 1
+#else
+#define USE_CONTIGUOUS_MMAP 0
+#endif
+
+// We use the m32 allocator on Windows and Unix platforms using mmap
+#if (RTS_LINKER_USE_MMAP == 1) || defined(PE_OBJFORMAT) || 1
+#define USE_M32
+#endif
+
+#if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
+#define NEED_SYMBOL_EXTRAS 1
+#endif
+
typedef void SymbolAddr;
typedef char SymbolName;
@@ -135,10 +165,6 @@ typedef struct _Segment {
int n_sections;
} Segment;
-#if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
-#define NEED_SYMBOL_EXTRAS 1
-#endif
-
/* Jump Islands are sniplets of machine code required for relative
* address relocations on the PowerPC, x86_64 and ARM.
*/
@@ -236,7 +262,7 @@ typedef struct _ObjectCode {
require extra information.*/
StrHashTable *extraInfos;
-#if RTS_LINKER_USE_MMAP == 1
+#if defined(USE_M32)
/* The m32 allocators used for allocating small sections and symbol extras
* during loading. We have two: one for (writeable) data and one for
* (read-only/executable) code. */
@@ -315,27 +341,6 @@ pathchar*
resolveSymbolAddr (pathchar* buffer, int size,
SymbolAddr* symbol, uintptr_t* top);
-/*************************************************
- * Various bits of configuration
- *************************************************/
-
-/* PowerPC and ARM have relative branch instructions with only 24 bit
- * displacements and therefore need jump islands contiguous with each object
- * code module.
- */
-#if defined(powerpc_HOST_ARCH)
-#define SHORT_REL_BRANCH 1
-#endif
-#if defined(arm_HOST_ARCH)
-#define SHORT_REL_BRANCH 1
-#endif
-
-#if (RTS_LINKER_USE_MMAP && defined(SHORT_REL_BRANCH) && defined(linux_HOST_OS))
-#define USE_CONTIGUOUS_MMAP 1
-#else
-#define USE_CONTIGUOUS_MMAP 0
-#endif
-
HsInt isAlreadyLoaded( pathchar *path );
HsInt loadOc( ObjectCode* oc );
ObjectCode* mkOc( pathchar *path, char *image, int imageSize,
=====================================
rts/linker/M32Alloc.c
=====================================
@@ -42,7 +42,7 @@ still check the call for syntax and correct function parameter types.
*/
-#if RTS_LINKER_USE_MMAP == 1
+#if defined(USE_M32)
/*
=====================================
rts/linker/M32Alloc.h
=====================================
@@ -8,7 +8,7 @@
#pragma once
-#if RTS_LINKER_USE_MMAP == 1
+#if defined(USE_M32)
#include <fcntl.h>
#include <sys/mman.h>
@@ -20,7 +20,7 @@
#include "BeginPrivate.h"
-#if RTS_LINKER_USE_MMAP
+#if defined(USE_M32)
#define M32_NO_RETURN /* Nothing */
#else
#define M32_NO_RETURN GNUC3_ATTRIBUTE(__noreturn__)
=====================================
rts/linker/PEi386.c
=====================================
@@ -1294,7 +1294,7 @@ ocVerifyImage_PEi386 ( ObjectCode* oc )
= (PEi386_IMAGE_OFFSET + 2 * default_alignment
+ oc->info->secBytesTotal) & ~0x7;
oc->info->secBytesTotal
- = oc->info->trampoline + info->numberOfSymbols * sizeof(SymbolExtra);
+ = oc->info->trampoline;
/* No further verification after this point; only debug printing. */
i = 0;
@@ -1792,12 +1792,15 @@ ocAllocateExtras_PEi386 ( ObjectCode* oc )
if (!oc->info)
return false;
- const int mask = default_alignment - 1;
- size_t origin = oc->info->trampoline;
+ COFF_HEADER_INFO *info = oc->info->ch_info;
+ size_t extras_size = info->numberOfSymbols * sizeof(SymbolExtra);
+
oc->symbol_extras
- = (SymbolExtra*)((uintptr_t)(oc->info->image + origin + mask) & ~mask);
+ = (SymbolExtra*) m32_alloc(oc->rx_m32, extras_size, 8);
+ if (oc->symbol_extras == NULL)
+ return false;
+
oc->first_symbol_extra = 0;
- COFF_HEADER_INFO *info = oc->info->ch_info;
oc->n_symbol_extras = info->numberOfSymbols;
return true;
@@ -1952,13 +1955,15 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
uint64_t v;
v = S + A;
- if (v >> 32) {
+ // N.B. in the case of the sign-extended relocations we must ensure that v
+ // fits in a signed 32-bit value. See #15808.
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
copyName (getSymShortName (info, sym), oc,
symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + A;
- if (v >> 32) {
+ if (((int64_t) v > (int64_t) INT32_MAX) || ((int64_t) v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_ADDR32[NB]: High bits are set in %zx for %s",
v, (char *)symbol);
}
@@ -1970,14 +1975,14 @@ ocResolve_PEi386 ( ObjectCode* oc )
{
intptr_t v;
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
/* Make the trampoline then */
copyName (getSymShortName (info, sym),
oc, symbol, sizeof(symbol)-1);
S = makeSymbolExtra_PEi386(oc, symIndex, S, (char *)symbol);
/* And retry */
v = S + (int32_t)A - ((intptr_t)pP) - 4;
- if ((v > (intptr_t) INT32_MAX) || (v < (intptr_t) INT32_MIN)) {
+ if ((v > (int64_t) INT32_MAX) || (v < (int64_t) INT32_MIN)) {
barf("IMAGE_REL_AMD64_REL32: High bits are set in %zx for %s",
v, (char *)symbol);
}
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -386,7 +386,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[])
({ T17544.hs:25:13-18 }
(HsAppTy
@@ -522,7 +522,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[])
({ T17544.hs:31:13-18 }
(HsAppTy
@@ -658,7 +658,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[])
({ T17544.hs:37:13-18 }
(HsAppTy
@@ -794,7 +794,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[])
({ T17544.hs:43:13-18 }
(HsAppTy
@@ -930,7 +930,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[])
({ T17544.hs:49:13-18 }
(HsAppTy
@@ -1066,7 +1066,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[])
({ T17544.hs:55:14-20 }
(HsAppTy
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -39,7 +39,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[])
({ T17544_kw.hs:16:18-20 }
(HsTyVar
@@ -83,7 +83,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[(HsScaled
(HsUnrestrictedArrow
(NormalSyntax))
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -374,7 +374,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[(HsScaled
(HsUnrestrictedArrow
(NormalSyntax))
=====================================
testsuite/tests/parser/should_compile/T15323.stderr
=====================================
@@ -72,7 +72,7 @@
({ T15323.hs:6:35 }
(Unqual
{OccName: v}))))))))]))
- (PrefixCon
+ (PrefixConGADT
[])
({ T15323.hs:6:41-54 }
(HsAppTy
=====================================
testsuite/tests/printer/T18791.stderr
=====================================
@@ -39,7 +39,7 @@
(False))
[]
(Nothing)
- (PrefixCon
+ (PrefixConGADT
[(HsScaled
(HsUnrestrictedArrow
(NormalSyntax))
@@ -61,4 +61,6 @@
({ <no location info> }
[])))))]
(Nothing)
- (Nothing)))
\ No newline at end of file
+ (Nothing)))
+
+
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 87a9f86d1ad7de67ff011311905ecf76578b26e9
+Subproject commit 3cce1bdee8c61bb6daa089059e12435178f50770
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59c459f2e0f5d5ba948bb9ea03f54f8c42c0e93e...47dbdc442e2ef49831da1434b3c79eeba5a7b254
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59c459f2e0f5d5ba948bb9ea03f54f8c42c0e93e...47dbdc442e2ef49831da1434b3c79eeba5a7b254
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/20201031/88cb069e/attachment-0001.html>
More information about the ghc-commits
mailing list