[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