ghc-lib-parser 9.2.1.20220109 → 9.2.2.20220307

raw patch · 62 files changed

+777/−396 lines, 62 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• compiler/GHC/Cmm/CLabel.hs +4/−1
• compiler/GHC/Cmm/Expr.hs +11/−6
• compiler/GHC/Cmm/MachOp.hs +2/−0
• compiler/GHC/Cmm/Node.hs +15/−15
• compiler/GHC/Cmm/Type.hs +38/−2
• compiler/GHC/Core/Coercion.hs +55/−20
• compiler/GHC/Core/Coercion/Opt.hs +1/−1
• compiler/GHC/Core/FVs.hs +1/−1
• compiler/GHC/Core/Lint.hs +8/−6
• compiler/GHC/Core/Make.hs +23/−2
• compiler/GHC/Core/Map/Type.hs +4/−3
• compiler/GHC/Core/Opt/Arity.hs +91/−133
• compiler/GHC/Core/Opt/CallerCC.hs +14/−11
• compiler/GHC/Core/Opt/ConstantFold.hs +8/−8
• compiler/GHC/Core/Opt/Monad.hs +13/−10
• compiler/GHC/Core/Ppr.hs +6/−3
• compiler/GHC/Core/SimpleOpt.hs +15/−4
• compiler/GHC/Core/Subst.hs +4/−11
• compiler/GHC/Core/TyCo/FVs.hs +3/−3
• compiler/GHC/Core/TyCo/Rep.hs +77/−13
• compiler/GHC/Core/TyCo/Subst.hs +1/−1
• compiler/GHC/Core/TyCo/Tidy.hs +1/−1
• compiler/GHC/Core/TyCon/RecWalk.hs +4/−0
• compiler/GHC/Core/Type.hs +49/−21
• compiler/GHC/Core/Unfold.hs +7/−3
• compiler/GHC/Core/Unfold/Make.hs +1/−1
• compiler/GHC/Core/Unify.hs +3/−3
• compiler/GHC/Core/UsageEnv.hs +1/−1
• compiler/GHC/Core/Utils.hs +29/−15
• compiler/GHC/CoreToIface.hs +1/−2
• compiler/GHC/Data/StringBuffer.hs +57/−1
• compiler/GHC/Driver/Flags.hs +3/−0
• compiler/GHC/Driver/Pipeline/Monad.hs +4/−5
• compiler/GHC/Driver/Session.hs +35/−4
• compiler/GHC/Iface/Syntax.hs +1/−0
• compiler/GHC/Iface/Type.hs +10/−1
• compiler/GHC/Parser/Annotation.hs +7/−4
• compiler/GHC/Parser/Errors.hs +9/−0
• compiler/GHC/Parser/Errors/Ppr.hs +15/−0
• compiler/GHC/Tc/Utils/TcType.hs +12/−22
• compiler/GHC/Types/Demand.hs +9/−8
• compiler/GHC/Types/Id.hs +6/−0
• compiler/GHC/Types/Literal.hs +9/−8
• compiler/GHC/Types/Name/Env.hs +1/−0
• compiler/GHC/Types/Name/Reader.hs +4/−4
• compiler/GHC/Types/Unique/DFM.hs +12/−4
• compiler/GHC/Types/Unique/FM.hs +13/−6
• compiler/GHC/Types/Var/Env.hs +5/−5
• compiler/GHC/Unit/Home/ModInfo.hs +3/−1
• compiler/GHC/Unit/Module/Status.hs +0/−1
• compiler/GHC/Utils/Misc.hs +11/−1
• ghc-lib-parser.cabal +1/−1
• ghc-lib/stage0/compiler/build/GHC/Parser.hs +16/−8
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +1/−1
• ghc-lib/stage0/lib/ghcautoconf.h +8/−1
• ghc-lib/stage0/lib/settings +0/−1
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• libraries/ghc-boot/GHC/Unit/Database.hs +25/−0
• libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +3/−1
• libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc +1/−1
• libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc +1/−1
• libraries/ghci/GHCi/Message.hs +1/−1

@@ -62,6 +62,7 @@         mkSMAP_FROZEN_DIRTY_infoLabel,         mkSMAP_DIRTY_infoLabel,         mkBadAlignmentLabel,+        mkOutOfBoundsAccessLabel,         mkArrWords_infoLabel,         mkSRTInfoLabel, @@ -599,7 +600,8 @@     mkTopTickyCtrLabel,     mkCAFBlackHoleInfoTableLabel,     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,-    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel+    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,+    mkOutOfBoundsAccessLabel :: CLabel mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData@@ -617,6 +619,7 @@ mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction  mkSRTInfoLabel :: Int -> CLabel mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo

@@ -9,6 +9,7 @@     ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr     , CmmReg(..), cmmRegType, cmmRegWidth     , CmmLit(..), cmmLitType+    , AlignmentSpec(..)     , LocalReg(..), localRegType     , GlobalReg(..), isArgReg, globalRegType     , spReg, hpReg, spLimReg, hpLimReg, nodeReg@@ -53,12 +54,13 @@ -----------------------------------------------------------------------------  data CmmExpr-  = CmmLit !CmmLit               -- Literal-  | CmmLoad !CmmExpr !CmmType   -- Read memory location+  = CmmLit !CmmLit              -- Literal+  | CmmLoad !CmmExpr !CmmType !AlignmentSpec+                                -- Read memory location   | CmmReg !CmmReg              -- Contents of register   | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)   | CmmStackSlot Area {-# UNPACK #-} !Int-                                -- addressing expression of a stack slot+                                -- Addressing expression of a stack slot                                 -- See Note [CmmStackSlot aliasing]   | CmmRegOff !CmmReg !Int         -- CmmRegOff reg i@@ -69,13 +71,16 @@  instance Eq CmmExpr where       -- Equality ignores the types   CmmLit l1          == CmmLit l2          = l1==l2-  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2+  CmmLoad e1 _ _     == CmmLoad e2 _ _     = e1==e2   CmmReg r1          == CmmReg r2          = r1==r2   CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2   CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2   CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2   _e1                == _e2                = False +data AlignmentSpec = NaturallyAligned | Unaligned+  deriving (Eq, Ord, Show)+ data CmmReg   = CmmLocal  {-# UNPACK #-} !LocalReg   | CmmGlobal GlobalReg@@ -225,7 +230,7 @@ cmmExprType :: Platform -> CmmExpr -> CmmType cmmExprType platform = \case    (CmmLit lit)        -> cmmLitType platform lit-   (CmmLoad _ rep)     -> rep+   (CmmLoad _ rep _)   -> rep    (CmmReg reg)        -> cmmRegType platform reg    (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)    (CmmRegOff reg _)   -> cmmRegType platform reg@@ -385,7 +390,7 @@   {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z e = expr z e     where expr z (CmmLit _)          = z-          expr z (CmmLoad addr _)    = foldRegsUsed platform f z addr+          expr z (CmmLoad addr _ _)  = foldRegsUsed platform f z addr           expr z (CmmReg r)          = foldRegsUsed platform f z r           expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs           expr z (CmmRegOff r _)     = foldRegsUsed platform f z r

@@ -102,6 +102,8 @@   | MO_Or    Width   | MO_Xor   Width   | MO_Not   Width++  -- Shifts. The shift amount must be in [0,widthInBits).   | MO_Shl   Width   | MO_U_Shr Width      -- unsigned shift right   | MO_S_Shr Width      -- signed shift right

@@ -74,7 +74,7 @@   CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O     -- Assign to register -  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O+  CmmStore :: !CmmExpr -> !CmmExpr -> !AlignmentSpec -> CmmNode O O     -- Assign to memory location.  Size is     -- given by cmmExprType of the rhs. @@ -321,7 +321,7 @@   {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr-    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmStore addr rval _ -> fold f (fold f z addr) rval     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args     CmmCondBranch expr _ _ _ -> fold f z expr     CmmSwitch expr _ -> fold f z expr@@ -336,7 +336,7 @@   {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr-    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmStore addr rval _ -> fold f (fold f z addr) rval     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args     CmmCondBranch expr _ _ _ -> fold f z expr     CmmSwitch expr _ -> fold f z expr@@ -464,9 +464,9 @@ -- Take a transformer on expressions and apply it recursively. -- (wrapRecExp f e) first recursively applies itself to sub-expressions of e --                  then  uses f to rewrite the resulting expression-wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)-wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)-wrapRecExp f e                    = f e+wrapRecExp f (CmmMachOp op es)       = f (CmmMachOp op $ map (wrapRecExp f) es)+wrapRecExp f (CmmLoad addr ty align) = f (CmmLoad (wrapRecExp f addr) ty align)+wrapRecExp f e                       = f e  mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x mapExp _ f@(CmmEntry{})                          = f@@ -474,7 +474,7 @@ mapExp _ m@(CmmTick _)                           = m mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs) mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)-mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)+mapExp f   (CmmStore addr e align)               = CmmStore (f addr) (f e) align mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) mapExp _ l@(CmmBranch _)                         = l mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l@@ -495,9 +495,9 @@ wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) -- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e --                   then  gives f a chance to rewrite the resulting expression-wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)-wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)-wrapRecExpM f e                    = f e+wrapRecExpM f n@(CmmMachOp op es)       = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)+wrapRecExpM f n@(CmmLoad addr ty align) = maybe (f n) (\addr' -> f $ CmmLoad addr' ty align) (wrapRecExpM f addr)+wrapRecExpM f e                         = f e  mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) mapExpM _ (CmmEntry{})              = Nothing@@ -505,7 +505,7 @@ mapExpM _ (CmmTick _)               = Nothing mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e-mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]+mapExpM f (CmmStore addr e align)   = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, e] mapExpM _ (CmmBranch _)             = Nothing mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e@@ -548,9 +548,9 @@ -- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad -- itself, delegating all the other CmmExpr forms to 'f'. wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z-wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es-wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)-wrapRecExpf f e                  z = f e z+wrapRecExpf f e@(CmmMachOp _ es)   z = foldr (wrapRecExpf f) (f e z) es+wrapRecExpf f e@(CmmLoad addr _ _) z = wrapRecExpf f addr (f e z)+wrapRecExpf f e                    z = f e z  foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z foldExp _ (CmmEntry {}) z                         = z@@ -558,7 +558,7 @@ foldExp _ (CmmTick {}) z                          = z foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs) foldExp f (CmmAssign _ e) z                       = f e z-foldExp f (CmmStore addr e) z                     = f addr $ f e z+foldExp f (CmmStore addr e _) z                   = f addr $ f e z foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as foldExp _ (CmmBranch _) z                         = z foldExp f (CmmCondBranch e _ _ _) z               = f e z

@@ -181,16 +181,20 @@   -------- Common Widths  ------------++-- | The width of the current platform's word size. wordWidth :: Platform -> Width wordWidth platform = case platformWordSize platform of  PW4 -> W32  PW8 -> W64 +-- | The width of the current platform's half-word size. halfWordWidth :: Platform -> Width halfWordWidth platform = case platformWordSize platform of  PW4 -> W16  PW8 -> W32 +-- | A bit-mask for the lower half-word of current platform. halfWordMask :: Platform -> Integer halfWordMask platform = case platformWordSize platform of  PW4 -> 0xFFFF@@ -203,6 +207,7 @@                    8 -> W64                    s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) +-- | A width in bits. widthInBits :: Width -> Int widthInBits W8   = 8 widthInBits W16  = 16@@ -212,7 +217,9 @@ widthInBits W256 = 256 widthInBits W512 = 512 -+-- | A width in bytes.+--+-- > widthFromBytes (widthInBytes w) === w widthInBytes :: Width -> Int widthInBytes W8   = 1 widthInBytes W16  = 2@@ -223,6 +230,7 @@ widthInBytes W512 = 64  +-- | *Partial* A width from the number of bytes. widthFromBytes :: Int -> Width widthFromBytes 1  = W8 widthFromBytes 2  = W16@@ -234,7 +242,7 @@  widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n) --- log_2 of the width in bytes, useful for generating shifts.+-- | log_2 of the width in bytes, useful for generating shifts. widthInLog :: Width -> Int widthInLog W8   = 0 widthInLog W16  = 1@@ -247,6 +255,20 @@  -- widening / narrowing +-- | Narrow a signed or unsigned value to the given width. The result will+-- reside in @[0, +2^width)@.+--+-- >>> narrowU W8 256    == 256+-- >>> narrowU W8 255    == 255+-- >>> narrowU W8 128    == 128+-- >>> narrowU W8 127    == 127+-- >>> narrowU W8 0      == 0+-- >>> narrowU W8 (-127) == 129+-- >>> narrowU W8 (-128) == 128+-- >>> narrowU W8 (-129) == 127+-- >>> narrowU W8 (-255) == 1+-- >>> narrowU W8 (-256) == 0+-- narrowU :: Width -> Integer -> Integer narrowU W8  x = fromIntegral (fromIntegral x :: Word8) narrowU W16 x = fromIntegral (fromIntegral x :: Word16)@@ -254,6 +276,20 @@ narrowU W64 x = fromIntegral (fromIntegral x :: Word64) narrowU _ _ = panic "narrowTo" +-- | Narrow a signed value to the given width. The result will reside+-- in @[-2^(width-1), +2^(width-1))@.+--+-- >>> narrowS W8 256    == 0+-- >>> narrowS W8 255    == -1+-- >>> narrowS W8 128    == -128+-- >>> narrowS W8 127    == 127+-- >>> narrowS W8 0      == 0+-- >>> narrowS W8 (-127) == -127+-- >>> narrowS W8 (-128) == -128+-- >>> narrowS W8 (-129) == 127+-- >>> narrowS W8 (-255) == 1+-- >>> narrowS W8 (-256) == 0+-- narrowS :: Width -> Integer -> Integer narrowS W8  x = fromIntegral (fromIntegral x :: Int8) narrowS W16 x = fromIntegral (fromIntegral x :: Int16)

@@ -35,7 +35,7 @@         mkPiCo, mkPiCos, mkCoCast,         mkSymCo, mkTransCo,         mkNthCo, mkNthCoFunCo, nthCoRole, mkLRCo,-        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo,+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunResCo,         mkForAllCo, mkForAllCos, mkHomoForAllCos,         mkPhantomCo,         mkHoleCo, mkUnivCo, mkSubCo,@@ -72,7 +72,9 @@         isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,         mkCoherenceRightMCo, -        coToMCo, mkTransMCo, mkTransMCoL, mkCastTyMCo, mkSymMCo, isReflMCo,+        coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,+        mkHomoForAllMCo, mkFunResMCo, mkPiMCos, checkReflexiveMCo,+        isReflMCo,          -- ** Coercion variables         mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,@@ -311,6 +313,11 @@ coToMCo co | isReflCo co = MRefl            | otherwise   = MCo co +checkReflexiveMCo :: MCoercion -> MCoercion+checkReflexiveMCo MRefl                       = MRefl+checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl+                           | otherwise        = MCo co+ -- | Tests if this MCoercion is obviously generalized reflexive -- Guaranteed to work very quickly. isGReflMCo :: MCoercion -> Bool@@ -332,9 +339,13 @@ mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)  mkTransMCoL :: MCoercion -> Coercion -> MCoercion-mkTransMCoL MRefl     co2 = MCo co2+mkTransMCoL MRefl     co2 = coToMCo co2 mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2) +mkTransMCoR :: Coercion -> MCoercion -> MCoercion+mkTransMCoR co1 MRefl     = coToMCo co1+mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2)+ -- | Get the reverse of an 'MCoercion' mkSymMCo :: MCoercion -> MCoercion mkSymMCo MRefl    = MRefl@@ -345,6 +356,18 @@ mkCastTyMCo ty MRefl    = ty mkCastTyMCo ty (MCo co) = ty `mkCastTy` co +mkHomoForAllMCo :: TyCoVar -> MCoercion -> MCoercion+mkHomoForAllMCo _   MRefl    = MRefl+mkHomoForAllMCo tcv (MCo co) = MCo (mkHomoForAllCos [tcv] co)++mkPiMCos :: [Var] -> MCoercion -> MCoercion+mkPiMCos _ MRefl = MRefl+mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co)++mkFunResMCo :: Scaled Type -> MCoercionR -> MCoercionR+mkFunResMCo _      MRefl    = MRefl+mkFunResMCo arg_ty (MCo co) = MCo (mkFunResCo Representational arg_ty co)+ mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion mkGReflLeftMCo r ty MRefl    = mkReflCo r ty mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co@@ -454,7 +477,7 @@        -> (TCvSubst,Kind)  -- Rhs kind of coercion        -> [Type]           -- Arguments to that function        -> ([CoercionN], Coercion)-    -- Invariant:  co :: subst1(k2) ~ subst2(k2)+    -- Invariant:  co :: subst1(k1) ~ subst2(k2)      go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)       | Just (a, t1) <- splitForAllTyCoVar_maybe k1@@ -1053,18 +1076,18 @@         -> Coercion mkNthCo r n co   = ASSERT2( good_call, bad_call_msg )-    go r n co+    go n co   where     Pair ty1 ty2 = coercionKind co -    go r 0 co+    go 0 co       | Just (ty, _) <- isReflCo_maybe co       , Just (tv, _) <- splitForAllTyCoVar_maybe ty       = -- works for both tyvar and covar         ASSERT( r == Nominal )         mkNomReflCo (varType tv) -    go r n co+    go n co       | Just (ty, r0) <- isReflCo_maybe co       , let tc = tyConAppTyCon ty       = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty )@@ -1079,7 +1102,7 @@               | otherwise               = False -    go r 0 (ForAllCo _ kind_co _)+    go 0 (ForAllCo _ kind_co _)       = ASSERT( r == Nominal )         kind_co       -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)@@ -1087,10 +1110,10 @@       -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)       -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) -    go _ n (FunCo _ w arg res)+    go n (FunCo _ w arg res)       = mkNthCoFunCo n w arg res -    go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n+    go n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n                                                     , (vcat [ ppr tc                                                             , ppr arg_cos                                                             , ppr r0@@ -1098,9 +1121,12 @@                                                             , ppr r ]) )                                              arg_cos `getNth` n -    go r n co =-      NthCo r n co+    go n (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo+      = mkSymCo (go n co) +    go n co+      = NthCo r n co+     -- Assertion checking     bad_call_msg = vcat [ text "Coercion =" <+> ppr co                         , text "LHS ty =" <+> ppr ty1@@ -1352,7 +1378,7 @@       | case prov of PhantomProv _    -> False  -- should always be phantom                      ProofIrrelProv _ -> True   -- it's always safe                      PluginProv _     -> False  -- who knows? This choice is conservative.-                     CorePrepProv     -> True+                     CorePrepProv _   -> True       = Just $ UnivCo prov Nominal co1 co2     setNominalRole_maybe_helper _ = Nothing @@ -1456,10 +1482,10 @@     AxiomInstCo {} -> mkKindCo co     AxiomRuleCo {} -> mkKindCo co -    UnivCo (PhantomProv kco) _ _ _    -> kco+    UnivCo (PhantomProv kco)    _ _ _ -> kco     UnivCo (ProofIrrelProv kco) _ _ _ -> kco-    UnivCo (PluginProv _) _ _ _       -> mkKindCo co-    UnivCo CorePrepProv _ _ _         -> mkKindCo co+    UnivCo (PluginProv _)       _ _ _ -> mkKindCo co+    UnivCo (CorePrepProv _)     _ _ _ -> mkKindCo co      SymCo g       -> mkSymCo (promoteCoercion g)@@ -1621,9 +1647,18 @@                   -- want it to be r. It is only called in 'mkPiCos', which is                   -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for                   -- now (Aug 2018) v won't occur in co.-                            mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co-              | otherwise = mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co+                            mkFunResCo r scaled_ty co+              | otherwise = mkFunResCo r scaled_ty co+              where+                scaled_ty = Scaled (varMult v) (varType v) +mkFunResCo :: Role -> Scaled Type -> Coercion -> Coercion+-- Given res_co :: res1 -> res2,+--   mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2)+-- Reflexive in the multiplicity argument+mkFunResCo role (Scaled mult arg_ty) res_co+  = mkFunCo role (multToCo mult) (mkReflCo role arg_ty) res_co+ -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above -- Lifted and unlifted equalities take different numbers of arguments,@@ -1779,7 +1814,7 @@ -- -- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') ----- then (a)  @co : ty0 ~ ty'@.+-- then (a)  @co : ty ~ ty'@. --      (b)  ty' is not a newtype. -- -- The function returns @Nothing@ for non-@newtypes@,@@ -2283,7 +2318,7 @@ seqProv (PhantomProv co)    = seqCo co seqProv (ProofIrrelProv co) = seqCo co seqProv (PluginProv _)      = ()-seqProv CorePrepProv        = ()+seqProv (CorePrepProv _)    = ()  seqCos :: [Coercion] -> () seqCos []       = ()

@@ -576,7 +576,7 @@ #endif       ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco       PluginProv _       -> prov-      CorePrepProv       -> prov+      CorePrepProv _     -> prov  ------------- opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]

@@ -404,7 +404,7 @@ orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co orphNamesOfProv (PluginProv _)      = emptyNameSet-orphNamesOfProv CorePrepProv        = emptyNameSet+orphNamesOfProv (CorePrepProv _)    = emptyNameSet  orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo

@@ -2117,13 +2117,15 @@         -- see #9122 for discussion of these checks      checkTypes t1 t2+       | allow_ill_kinded_univ_co prov+       = return ()  -- Skip kind checks+       | otherwise        = do { checkWarnL (not lev_poly1)                          (report "left-hand type is levity-polymorphic")             ; checkWarnL (not lev_poly2)                          (report "right-hand type is levity-polymorphic")             ; when (not (lev_poly1 || lev_poly2)) $-              do { checkWarnL (reps1 `equalLength` reps2 ||-                               is_core_prep_prov prov)+              do { checkWarnL (reps1 `equalLength` reps2)                               (report "between values with different # of reps")                  ; zipWithM_ validateCoercion reps1 reps2 }}        where@@ -2139,8 +2141,8 @@      --  e.g (case error @Int "blah" of {}) :: Int#      --     ==> (error @Int "blah") |> Unsafe Int Int#      -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep-     is_core_prep_prov CorePrepProv = True-     is_core_prep_prov _            = False+     allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind+     allow_ill_kinded_univ_co _                        = False       validateCoercion :: PrimRep -> PrimRep -> LintM ()      validateCoercion rep1 rep2@@ -2171,8 +2173,8 @@             ; check_kinds kco k1 k2             ; return (ProofIrrelProv kco') } -     lint_prov _ _ prov@(PluginProv _) = return prov-     lint_prov _ _ prov@CorePrepProv   = return prov+     lint_prov _ _ prov@(PluginProv _)   = return prov+     lint_prov _ _ prov@(CorePrepProv _) = return prov       check_kinds kco k1 k2        = do { let Pair k1' k2' = coercionKind kco

@@ -824,7 +824,9 @@ --       argument would require allocating a thunk. -- --    4. it can't be CAFFY because that would mean making some non-CAFFY---       definitions that use unboxed sums CAFFY in unarise.+--       definitions that use unboxed sums CAFFY in unarise. We work around+--       this by declaring the absentSumFieldError as non-CAFfy, as described+--       in Note [Wired-in exceptions are not CAFfy]. -- --       Getting this wrong causes hard-to-debug runtime issues, see #15038. --@@ -858,6 +860,21 @@ --   error. That's why it is OK for it to be un-catchable. -- +-- Note [Wired-in exceptions are not CAFfy]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- mkExceptionId claims that all exceptions are not CAFfy, despite the fact+-- that their closures' code may in fact contain CAF references. We get away+-- with this lie because the RTS ensures that all exception closures are+-- considered live by the GC by creating StablePtrs during initialization.+-- The lie is necessary to avoid unduly growing SRTs as these exceptions are+-- sufficiently common to warrant special treatment.+--+-- At some point we could consider removing this optimisation as it is quite+-- fragile, but we do want to be careful to avoid adding undue cost. Unboxed+-- sums in particular are intended to be used in performance-critical contexts.+--+-- See #15038, #21141.+ absentSumFieldErrorName    = mkWiredInIdName       gHC_PRIM_PANIC@@ -899,6 +916,9 @@ rAISE_DIVZERO_ID          = mkExceptionId raiseDivZeroName  -- | Exception with type \"forall a. a\"+--+-- Any exceptions added via this function needs to be added to+-- the RTS's initBuiltinGcRoots() function. mkExceptionId :: Name -> Id mkExceptionId name   = mkVanillaGlobalWithInfo name@@ -906,7 +926,8 @@       (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv                      `setCprInfo` mkCprSig 0 botCpr                      `setArityInfo` 0-                     `setCafInfo` NoCafRefs) -- #15038+                     `setCafInfo` NoCafRefs)+                        -- See Note [Wired-in exceptions are not CAFfy]  mkRuntimeErrorId :: Name -> Id -- Error function

@@ -48,13 +48,13 @@ import GHC.Types.Unique.FM import GHC.Utils.Outputable -import GHC.Data.Maybe import GHC.Utils.Panic  import qualified Data.Map    as Map import qualified Data.IntMap as IntMap  import Control.Monad ( (>=>) )+import GHC.Data.Maybe  -- NB: Be careful about RULES and type families (#5821).  So we should make sure -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)@@ -136,16 +136,17 @@ type TypeMapG = GenMap TypeMapX  -- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the--- 'GenMap' optimization.+-- 'GenMap' optimization. See Note [Computing equality on types] in GHC.Core.Type. data TypeMapX a   = TM { tm_var    :: VarMap a-       , tm_app    :: TypeMapG (TypeMapG a)+       , tm_app    :: TypeMapG (TypeMapG a)  -- Note [Equality on AppTys] in GHC.Core.Type        , tm_tycon  :: DNameEnv a           -- only InvisArg arrows here        , tm_funty  :: TypeMapG (TypeMapG (TypeMapG a))                        -- keyed on the argument, result rep, and result                        -- constraints are never linear-restricted and are always lifted+                       -- See also Note [Equality on FunTys] in GHC.Core.TyCo.Rep         , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr        , tm_tylit  :: TyLitMap a

@@ -1285,6 +1285,7 @@  -- etaExpand arity e = res -- Then 'res' has at least 'arity' lambdas at the top+--    possibly with a cast wrapped around the outside -- See Note [Eta expansion with ArityType] -- -- etaExpand deals with for-alls. For example:@@ -1292,33 +1293,43 @@ -- where  E :: forall a. a -> a -- would return --      (/\b. \y::a -> E b y)------ It deals with coerces too, though they are now rare--- so perhaps the extra code isn't worth it  eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr+eta_expand one_shots (Cast expr co)+  = mkCast (eta_expand one_shots expr) co+ eta_expand one_shots orig_expr-  = go one_shots orig_expr+  = go one_shots [] orig_expr   where       -- Strip off existing lambdas and casts before handing off to mkEtaWW+      -- This is mainly to avoid spending time cloning binders and substituting+      -- when there is actually nothing to do.  It's slightly awkward to deal+      -- with casts here, apart from the topmost one, and they are rare, so+      -- if we find one we just hand off to mkEtaWW anyway       -- Note [Eta expansion and SCCs]-    go [] expr = expr-    go oss@(_:oss1) (Lam v body) | isTyVar v = Lam v (go oss  body)-                                 | otherwise = Lam v (go oss1 body)-    go oss (Cast expr co) = Cast (go oss expr) co+    go [] _ _ = orig_expr  -- Already has the specified arity; no-op -    go oss expr+    go oss@(_:oss1) vs (Lam v body)+      | isTyVar v = go oss  (v:vs) body+      | otherwise = go oss1 (v:vs) body++    go oss rev_vs expr       = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, pprEtaInfos etas]) $-        retick $ etaInfoAbs etas (etaInfoApp in_scope' sexpr etas)+        retick $ etaInfoAbs top_eis $+                 etaInfoApp in_scope' sexpr eis       where           in_scope = mkInScopeSet (exprFreeVars expr)-          (in_scope', etas) = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)+          (in_scope', eis@(EI eta_bndrs mco))+              = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)+          top_bndrs = reverse rev_vs+          top_eis   = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco)            -- Find ticks behind type apps.           -- See Note [Eta expansion and source notes]+          -- I don't really understand this code SLPJ May 21           (expr', args) = collectArgs expr           (ticks, expr'') = stripTicksTop tickishFloatable expr'-          sexpr = foldl' App expr'' args+          sexpr = mkApps expr'' args           retick expr = foldr mkTick expr ticks  {- *********************************************************************@@ -1333,23 +1344,23 @@ Suppose we have (e :: ty) and we want to eta-expand it to arity N. This what eta_expand does.  We do it in two steps: -1.  mkEtaWW: from 'ty' and 'N' build a [EtaInfo] which describes+1.  mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes     the shape of the expansion necessary to expand to arity N.  2.  Build the term        \ v1..vn.  e v1 .. vn     where those abstractions and applications are described by-    the same [EtaInfo].  Specifically we build the term+    the same EtaInfo.  Specifically we build the term         etaInfoAbs etas (etaInfoApp in_scope e etas) -   where etas :: [EtaInfo]#+   where etas :: EtaInfo          etaInfoAbs builds the lambdas          etaInfoApp builds the applictions -   Note that the /same/ [EtaInfo] drives both etaInfoAbs and etaInfoApp+   Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp -To a first approximation [EtaInfo] is just [Var].  But+To a first approximation EtaInfo is just [Var].  But casts complicate the question.  If we have    newtype N a = MkN (S -> a) and@@ -1370,7 +1381,7 @@  This matters a lot in etaEInfoApp, where we * Do beta-reduction on the fly-* Use getARg_mabye to get a cast out of the way,+* Use getArg_maybe to get a cast out of the way,   so that we can do beta reduction Together this makes a big difference.  Consider when e is    case x of@@ -1388,88 +1399,17 @@ -}  ---------------data EtaInfo            -- Abstraction      Application-  = EtaVar Var          -- /\a. []         [] a-                        -- (\x. [])        [] x-  | EtaCo CoercionR     -- [] |> sym co    [] |> co+data EtaInfo = EI [Var] MCoercionR -instance Outputable EtaInfo where-   ppr (EtaVar v) = text "EtaVar" <+> ppr v  <+> dcolon <+> ppr (idType v)-   ppr (EtaCo co) = text "EtaCo"  <+> hang (ppr co) 2 (dcolon <+> ppr (coercionType co))+-- EI bs co+-- Abstraction:  (\b1 b2 .. bn. []) |> sym co+-- Application:  ([] |> co) b1 b2 .. bn+--+--    e :: T    co :: T ~ (t1 -> t2 -> .. -> tn -> tr)+--    e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co --- Used in debug-printing--- pprEtaInfos :: [EtaInfo] -> SDoc--- pprEtaInfos eis = brackets $ vcat $ punctuate comma $ map ppr eis -pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]--- Puts a EtaCo on the front of a [EtaInfo], but combining--- with an existing EtaCo if possible--- A minor improvement-pushCoercion co1 (EtaCo co2 : eis)-  | isReflCo co = eis-  | otherwise   = EtaCo co : eis-  where-    co = co1 `mkTransCo` co2--pushCoercion co eis-  = EtaCo co : eis--getArg_maybe :: [EtaInfo] -> Maybe (CoreArg, [EtaInfo])--- Get an argument to the front of the [EtaInfo], if possible,--- by pushing any EtaCo through the argument-getArg_maybe eis = go MRefl eis-  where-    go :: MCoercion -> [EtaInfo] -> Maybe (CoreArg, [EtaInfo])-    go _         []                = Nothing-    go mco       (EtaCo co2 : eis) = go (mkTransMCoL mco co2) eis-    go MRefl     (EtaVar v : eis)  = Just (varToCoreExpr v, eis)-    go (MCo co)  (EtaVar v : eis)-      | Just (arg, mco) <- pushCoArg co (varToCoreExpr v)-      = case mco of-           MRefl  -> Just (arg, eis)-           MCo co -> Just (arg, pushCoercion co eis)-      | otherwise-      = Nothing--mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr-mkCastMCo e MRefl    = e-mkCastMCo e (MCo co) = Cast e co-  -- We are careful to use (MCo co) only when co is not reflexive-  -- Hence (Cast e co) rather than (mkCast e co)--mkPiMCo :: Var -> MCoercionR -> MCoercionR-mkPiMCo _  MRefl   = MRefl-mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)-----------------etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr--- See Note [The EtaInfo mechanism]-etaInfoAbs eis expr-  | null eis  = expr-  | otherwise = case final_mco of-                   MRefl  -> expr'-                   MCo co -> mkCast expr' co-  where-     (expr', final_mco) = foldr do_one (split_cast expr) eis--     do_one :: EtaInfo -> (CoreExpr, MCoercion) -> (CoreExpr, MCoercion)-     -- Implements the "Abstraction" column in the comments for data EtaInfo-     -- In both argument and result the pair (e,mco) denotes (e |> mco)-     do_one (EtaVar v) (expr, mco) = (Lam v expr, mkPiMCo v mco)-     do_one (EtaCo co) (expr, mco) = (expr, mco `mkTransMCoL` mkSymCo co)--     split_cast :: CoreExpr -> (CoreExpr, MCoercion)-     split_cast (Cast e co) = (e, MCo co)-     split_cast e           = (e, MRefl)-     -- We could look in the body of lets, and the branches of a case-     -- But then we would have to worry about whether the cast mentioned-     -- any of the bound variables, which is tiresome. Later maybe.-     -- Result: we may end up with-     --     (\(x::Int). case x of { DEFAULT -> e1 |> co }) |> sym (<Int>->co)-     -- and fail to optimise it away-----------------etaInfoApp :: InScopeSet -> CoreExpr -> [EtaInfo] -> CoreExpr+etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr -- (etaInfoApp s e eis) returns something equivalent to --             (substExpr s e `appliedto` eis) -- See Note [The EtaInfo mechanism]@@ -1477,13 +1417,16 @@ etaInfoApp in_scope expr eis   = go (mkEmptySubst in_scope) expr eis   where-    go :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr+    go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr     -- 'go' pushed down the eta-infos into the branch of a case     -- and the body of a let; and does beta-reduction if possible+    --   go subst fun co [b1,..,bn]  returns  (subst(fun) |> co) b1 .. bn     go subst (Tick t e) eis       = Tick (substTickish subst t) (go subst e eis)-    go subst (Cast e co) eis-      = go subst e (pushCoercion (Core.substCo subst co) eis)++    go subst (Cast e co) (EI bs mco)+      = go subst e (EI bs (Core.substCo subst co `mkTransMCoR` mco))+     go subst (Case e b ty alts) eis       = Case (Core.substExprSC subst e) b1 ty' alts'       where@@ -1492,37 +1435,42 @@         ty'   = etaInfoAppTy (Core.substTy subst ty) eis         subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis)                  where-                    (subst2,bs') = Core.substBndrs subst1 bs+                  (subst2,bs') = Core.substBndrs subst1 bs+     go subst (Let b e) eis       | not (isJoinBind b) -- See Note [Eta expansion for join points]       = Let b' (go subst' e eis)       where         (subst', b') = Core.substBindSC subst b -    -- Beta-reduction if possible, using getArg_maybe to push-    -- any intervening casts past the argument-    -- See Note [The EtaInfo mechansim]-    go subst (Lam v e) eis-      | Just (arg, eis') <- getArg_maybe eis-      = go (Core.extendSubst subst v arg) e eis'+    -- Beta-reduction if possible, pushing any intervening casts past+    -- the argument. See Note [The EtaInfo mechansim]+    go subst (Lam v e) (EI (b:bs) mco)+      | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b)+      = go (Core.extendSubst subst v arg) e (EI bs mco')      -- Stop pushing down; just wrap the expression up-    go subst e eis = wrap (Core.substExprSC subst e) eis--    wrap e []               = e-    wrap e (EtaVar v : eis) = wrap (App e (varToCoreExpr v)) eis-    wrap e (EtaCo co : eis) = wrap (Cast e co) eis-+    go subst e (EI bs mco) = Core.substExprSC subst e+                             `mkCastMCo` mco+                             `mkVarApps` bs  ---------------etaInfoAppTy :: Type -> [EtaInfo] -> Type+etaInfoAppTy :: Type -> EtaInfo -> Type -- If                    e :: ty -- then   etaInfoApp e eis :: etaInfoApp ty eis-etaInfoAppTy ty []               = ty-etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis-etaInfoAppTy _  (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis+etaInfoAppTy ty (EI bs mco)+  = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs)+  where+    ty1 = case mco of+             MRefl  -> ty+             MCo co -> coercionRKind co  --------------+etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr+-- See Note [The EtaInfo mechanism]+etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco++-------------- -- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding -- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the -- free variables of @e@.@@ -1538,26 +1486,28 @@   -> InScopeSet   -- ^ A super-set of the free vars of the expression to eta-expand.   -> Type-  -> (InScopeSet, [EtaInfo])+  -> (InScopeSet, EtaInfo)   -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'.   -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the   -- fresh variables in 'EtaInfo'.  mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty-  = go 0 orig_oss empty_subst orig_ty []+  = go 0 orig_oss empty_subst orig_ty   where     empty_subst = mkEmptyTCvSubst in_scope      go :: Int                -- For fresh names        -> [OneShotInfo]      -- Number of value args to expand to        -> TCvSubst -> Type   -- We are really looking at subst(ty)-       -> [EtaInfo]          -- Accumulating parameter-       -> (InScopeSet, [EtaInfo])-    go _ [] subst _ eis       -- See Note [exprArity invariant]+       -> (InScopeSet, EtaInfo)+    -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co)+    --    co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr++    go _ [] subst _       -- See Note [exprArity invariant]        ----------- Done!  No more expansion needed-       = (getTCvInScope subst, reverse eis)+       = (getTCvInScope subst, EI [] MRefl) -    go n oss@(one_shot:oss1) subst ty eis       -- See Note [exprArity invariant]+    go n oss@(one_shot:oss1) subst ty       -- See Note [exprArity invariant]        ----------- Forall types  (forall a. ty)        | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty        , (subst', tcv') <- Type.substVarBndr subst tcv@@ -1565,19 +1515,21 @@                   | otherwise   = oss1          -- A forall can bind a CoVar, in which case          -- we consume one of the [OneShotInfo]-       = go n oss' subst' ty' (EtaVar tcv' : eis)+       , (in_scope, EI bs mco) <- go n oss' subst' ty'+       = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco))         ----------- Function types  (t1 -> t2)        | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty        , not (isTypeLevPoly arg_ty)-          -- See Note [Levity polymorphism invariants] in GHC.Core+          -- See Note [Representation polymorphism invariants] in GHC.Core           -- See also test case typecheck/should_run/EtaExpandLevPoly         , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty)           -- Avoid free vars of the original expression         , let eta_id' = eta_id `setIdOneShotInfo` one_shot-       = go (n+1) oss1 subst' res_ty (EtaVar eta_id' : eis)+       , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty+       = (in_scope, EI (eta_id' : bs) (mkFunResMCo (idScaledType eta_id') mco))         ----------- Newtypes        -- Given this:@@ -1587,17 +1539,20 @@        -- We want to get        --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)        | Just (co, ty') <- topNormaliseNewType_maybe ty-       , let co' = Type.substCo subst co+       , -- co :: ty ~ ty'+         let co' = Type.substCo subst co              -- Remember to apply the substitution to co (#16979)              -- (or we could have applied to ty, but then              --  we'd have had to zap it for the recursive call)-       = go n oss subst ty' (pushCoercion co' eis)+       , (in_scope, EI bs mco) <- go n oss subst ty'+         -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr+       = (in_scope, EI bs (mkTransMCoR co' mco))         | otherwise       -- We have an expression of arity > 0,                          -- but its type isn't a function, or a binder-                         -- is levity-polymorphic+                         -- is representation-polymorphic        = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )-         (getTCvInScope subst, reverse eis)+         (getTCvInScope subst, EI [] MRefl)         -- This *can* legitimately happen:         -- e.g.  coerce Int (\x. x) Essentially the programmer is         -- playing fast and loose with types (Happy does this a lot).@@ -1635,13 +1590,16 @@                                                  ; return (arg':args', m_co2) }                                   MRefl  -> return (arg':args, MRefl) } +pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)+pushMCoArg MRefl    arg = Just (arg, MRefl)+pushMCoArg (MCo co) arg = pushCoArg co arg+ pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -- We have (fun |> co) arg, and we want to transform it to --         (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype -- C.f. simplCast in GHC.Core.Opt.Simplify -- 'co' is always Representational--- If the returned coercion is Nothing, then it would have been reflexive pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty                             ; return (Type ty', m_co') } pushCoArg co val_arg   = do { (arg_co, m_co') <- pushCoValArg co@@ -1727,7 +1685,7 @@     Pair tyL tyR = coercionKind co  pushCoercionIntoLambda-    :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)+    :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) -- This implements the Push rule from the paper on coercions --    (\x. e) |> co -- ===>

@@ -10,19 +10,19 @@ -- flag. module GHC.Core.Opt.CallerCC     ( addCallerCostCentres-    , CallerCcFilter+    , CallerCcFilter(..)+    , NamePattern(..)     , parseCallerCcFilter     ) where -import Data.Bifunctor import Data.Word (Word8) import Data.Maybe-import qualified Text.Parsec as P  import Control.Applicative import Control.Monad.Trans.State.Strict import Data.Either import Control.Monad+import qualified Text.ParserCombinators.ReadP as P  import GHC.Prelude import GHC.Utils.Outputable as Outputable@@ -42,6 +42,7 @@ import GHC.Core.Opt.Monad import GHC.Utils.Panic import qualified GHC.Utils.Binary as B+import Data.Char  addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do@@ -170,17 +171,17 @@       = go rest s || go (PWildcard rest) (tail s)     go _ _  = False -type Parser = P.Parsec String ()+type Parser = P.ReadP  parseNamePattern :: Parser NamePattern parseNamePattern = pattern   where-    pattern = star <|> wildcard <|> char <|> end+    pattern = star P.<++ wildcard P.<++ char P.<++ end     star = PChar '*' <$ P.string "\\*" <*> pattern     wildcard = do       void $ P.char '*'       PWildcard <$> pattern-    char = PChar <$> P.anyChar <*> pattern+    char = PChar <$> P.get <*> pattern     end = PEnd <$ P.eof  data CallerCcFilter@@ -199,8 +200,10 @@   put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y  parseCallerCcFilter :: String -> Either String CallerCcFilter-parseCallerCcFilter =-    first show . P.parse parseCallerCcFilter' "caller-CC filter"+parseCallerCcFilter inp =+    case P.readP_to_S parseCallerCcFilter' inp of+      ((result, ""):_) -> Right result+      _ -> Left $ "parse error on " ++ inp  parseCallerCcFilter' :: Parser CallerCcFilter parseCallerCcFilter' =@@ -217,8 +220,8 @@      moduleName :: Parser String     moduleName = do-      c <- P.upper-      cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_"-      rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName+      c <- P.satisfy isUpper+      cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')+      rest <- optional $ P.char '.' >> fmap ('.':) moduleName       return $ c : (cs ++ fromMaybe "" rest) 

@@ -485,11 +485,11 @@     -- coercions -   Int8ToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]-   Int16ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]-   Int32ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]+   Int8ToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]+   Int16ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]+   Int32ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] #if WORD_SIZE_IN_BITS < 64-   Int64ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]+   Int64ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] #endif    IntToInt8Op    -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit                                        , semiInversePrimOp Int8ToIntOp@@ -504,17 +504,17 @@    IntToInt64Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ] #endif -   Word8ToWordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit+   Word8ToWordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit                                        , extendNarrowPassthrough WordToWord8Op 0xFF                                        ]-   Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit+   Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit                                        , extendNarrowPassthrough WordToWord16Op 0xFFFF                                        ]-   Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit+   Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit                                        , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF                                        ] #if WORD_SIZE_IN_BITS < 64-   Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]+   Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit ] #endif     WordToWord8Op  -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit

@@ -165,16 +165,17 @@  data SimplMode             -- See comments in GHC.Core.Opt.Simplify.Monad   = SimplMode-        { sm_names      :: [String]       -- ^ Name(s) of the phase-        , sm_phase      :: CompilerPhase-        , sm_uf_opts    :: !UnfoldingOpts -- ^ Unfolding options-        , sm_rules      :: !Bool          -- ^ Whether RULES are enabled-        , sm_inline     :: !Bool          -- ^ Whether inlining is enabled-        , sm_case_case  :: !Bool          -- ^ Whether case-of-case is enabled-        , sm_eta_expand :: !Bool          -- ^ Whether eta-expansion is enabled-        , sm_pre_inline :: !Bool          -- ^ Whether pre-inlining is enabled-        , sm_logger     :: !Logger-        , sm_dflags     :: DynFlags+        { sm_names        :: [String]       -- ^ Name(s) of the phase+        , sm_phase        :: CompilerPhase+        , sm_uf_opts      :: !UnfoldingOpts -- ^ Unfolding options+        , sm_rules        :: !Bool          -- ^ Whether RULES are enabled+        , sm_inline       :: !Bool          -- ^ Whether inlining is enabled+        , sm_case_case    :: !Bool          -- ^ Whether case-of-case is enabled+        , sm_eta_expand   :: !Bool          -- ^ Whether eta-expansion is enabled+        , sm_cast_swizzle :: !Bool          -- ^ Do we swizzle casts past lambdas?+        , sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled+        , sm_logger       :: !Logger+        , sm_dflags       :: DynFlags             -- Just for convenient non-monadic access; we don't override these.             --             -- Used for:@@ -188,6 +189,7 @@ instance Outputable SimplMode where     ppr (SimplMode { sm_phase = p, sm_names = ss                    , sm_rules = r, sm_inline = i+                   , sm_cast_swizzle = cs                    , sm_eta_expand = eta, sm_case_case = cc })        = text "SimplMode" <+> braces (          sep [ text "Phase =" <+> ppr p <+>@@ -195,6 +197,7 @@              , pp_flag i   (sLit "inline") <> comma              , pp_flag r   (sLit "rules") <> comma              , pp_flag eta (sLit "eta-expand") <> comma+             , pp_flag cs  (sLit "cast-swizzle") <> comma              , pp_flag cc  (sLit "case-of-case") ])          where            pp_flag f s = ppUnless f (text "no") <+> ptext s

@@ -22,6 +22,7 @@         pprCoreExpr, pprParendExpr,         pprCoreBinding, pprCoreBindings, pprCoreAlt,         pprCoreBindingWithSize, pprCoreBindingsWithSize,+        pprCoreBinder, pprCoreBinders,         pprRules, pprOptCo     ) where @@ -356,7 +357,6 @@  Note [Binding-site specific printing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust the information printed. @@ -394,6 +394,10 @@   = getPprDebug $ \debug ->     pprTypedLamBinder bind_site debug bndr +pprCoreBinders :: [Var] -> SDoc+-- Print as lambda-binders, i.e. with their type+pprCoreBinders vs = sep (map (pprCoreBinder LambdaBind) vs)+ pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder   | isTyVar binder = text "@" <> ppr binder    -- NB: don't print kind@@ -643,8 +647,7 @@                 ru_bndrs = tpl_vars, ru_args = tpl_args,                 ru_rhs = rhs })   = hang (doubleQuotes (ftext name) <+> ppr act)-       4 (sep [text "forall" <+>-                  sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,+       4 (sep [text "forall" <+> pprCoreBinders tpl_vars <> dot,                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),                nest 2 (text "=" <+> pprCoreExpr rhs)             ])

@@ -1175,7 +1175,12 @@         -- Look through dictionary functions; see Note [Unfolding DFuns]         | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding         , bndrs `equalLength` args    -- See Note [DFun arity check]-        , let subst = mkOpenSubst in_scope (bndrs `zip` args)+        , let in_scope' = extend_in_scope (exprsFreeVars dfun_args)+              subst = mkOpenSubst in_scope' (bndrs `zip` args)+              -- We extend the in-scope set here to silence warnings from+              -- substExpr when it finds not-in-scope Ids in dfun_args.+              -- simplOptExpr initialises the in-scope set with exprFreeVars,+              -- but that doesn't account for DFun unfoldings         = succeedWith in_scope floats $           pushCoDataCon con (map (substExpr subst) dfun_args) co @@ -1186,7 +1191,7 @@         -- CPR'd workers getting inlined back into their wrappers,         | idArity fun == 0         , Just rhs <- expandUnfolding_maybe unfolding-        , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)+        , let in_scope' = extend_in_scope (exprFreeVars rhs)         = go (Left in_scope') floats rhs cont          -- See Note [exprIsConApp_maybe on literal strings]@@ -1198,6 +1203,11 @@           dealWithStringLiteral fun str co         where           unfolding = id_unf fun+          extend_in_scope unf_fvs+            | isLocalId fun = in_scope `extendInScopeSetSet` unf_fvs+            | otherwise     = in_scope+            -- A GlobalId has no (LocalId) free variables; and the+            -- in-scope set tracks only LocalIds      go _ _ _ _ = Nothing @@ -1318,8 +1328,9 @@ "map coerce = coerce" match. -} -exprIsLambda_maybe :: InScopeEnv -> CoreExpr-                      -> Maybe (Var, CoreExpr,[CoreTickish])+exprIsLambda_maybe :: HasDebugCallStack+                   => InScopeEnv -> CoreExpr+                   -> Maybe (Var, CoreExpr,[CoreTickish])     -- See Note [exprIsLambda_maybe]  -- The simple case: It is a lambda already

@@ -24,7 +24,7 @@         emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,         extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,         extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,-        addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,+        extendInScope, extendInScopeList, extendInScopeIds,         isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst,         delBndr, delBndrs, @@ -39,8 +39,6 @@  import GHC.Prelude -import GHC.Driver.Ppr- import GHC.Core import GHC.Core.FVs import GHC.Core.Seq@@ -68,6 +66,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import Data.List (mapAccumL)+import GHC.Driver.Ppr   @@ -255,9 +254,9 @@   | not (isLocalId v) = Var v   | Just e  <- lookupVarEnv ids       v = e   | Just v' <- lookupInScope in_scope v = Var v'-        -- Vital! See Note [Extending the Subst]+   | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v-                            $$ ppr in_scope)+                             $$ ppr in_scope)                 Var v  -- | Find the substitution for a 'TyVar' in the 'Subst'@@ -292,12 +291,6 @@ ------------------------------ isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope---- | Add the 'Var' to the in-scope set, but do not remove--- any existing substitutions for it-addInScopeSet :: Subst -> VarSet -> Subst-addInScopeSet (Subst in_scope ids tvs cvs) vs-  = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs  -- | Add the 'Var' to the in-scope set: as a side effect, -- and remove any existing substitutions for it

@@ -650,7 +650,7 @@ tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc-tyCoFVsOfProv CorePrepProv        fv_cand in_scope acc = emptyFV fv_cand in_scope acc+tyCoFVsOfProv (CorePrepProv _)    fv_cand in_scope acc = emptyFV fv_cand in_scope acc  tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc@@ -720,8 +720,8 @@   = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_prov (ProofIrrelProv co) cv   = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (PluginProv _) _ = True-almost_devoid_co_var_of_prov CorePrepProv   _ = True+almost_devoid_co_var_of_prov (PluginProv _)   _ = True+almost_devoid_co_var_of_prov (CorePrepProv _) _ = True  almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True

@@ -169,10 +169,10 @@   | CastTy         Type         KindCoercion  -- ^ A kind cast. The coercion is always nominal.-                      -- INVARIANT: The cast is never reflexive-                      -- INVARIANT: The Type is not a CastTy (use TransCo instead)-                      -- INVARIANT: The Type is not a ForAllTy over a type variable-                      -- See Note [Respecting definitional equality] \(EQ2), (EQ3), (EQ4)+                      -- INVARIANT: The cast is never reflexive \(EQ2)+                      -- INVARIANT: The Type is not a CastTy (use TransCo instead) \(EQ3)+                      -- INVARIANT: The Type is not a ForAllTy over a tyvar \(EQ4)+                      -- See Note [Respecting definitional equality]    | CoercionTy         Coercion    -- ^ Injection of a Coercion into a type@@ -305,6 +305,31 @@ In a FunTy { ft_af = InvisArg }, the argument type is always a Predicate type. +Note [Weird typing rule for ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the typing rules for ForAllTy:++tyvar : Type+inner : TYPE r+tyvar does not occur in r+------------------------------------+ForAllTy (Bndr tyvar vis) inner : TYPE r++inner : TYPE r+------------------------------------+ForAllTy (Bndr covar vis) inner : Type++Note that the kind of the result depends on whether the binder is a+tyvar or a covar. The kind of a forall-over-tyvar is the same as+the kind of the inner type. This is because quantification over types+is erased before runtime. By contrast, the kind of a forall-over-covar+is always Type, because a forall-over-covar is compiled into a function+taking a 0-bit-wide erased coercion argument.++Because the tyvar form above includes r in its result, we must+be careful not to let any variables escape -- thus the last premise+of the rule above.+ Note [Constraints in kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do we allow a type constructor to have a kind like@@ -455,7 +480,7 @@ are interchangeable.  But let's be more precise. If we examine the typing rules of FC (say, those in-https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf)+https://richarde.dev/papers/2015/equalities/equalities.pdf) there are several places where the same metavariable is used in two different premises to a rule. (For example, see Ty_App.) There is an implicit equality check here. What definition of equality should we use? By convention, we use@@ -473,7 +498,7 @@ those rules must also be admissible.  A more drawn out argument around all of this is presented in Section 7.2 of-Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf).+Richard E's thesis (http://richarde.dev/papers/2016/thesis/eisenberg-thesis.pdf).  What would go wrong if we insisted on the casts matching? See the beginning of Section 8 in the unpublished paper above. Theoretically, nothing at all goes@@ -485,8 +510,8 @@ and we would need enormous casts with lots of CoherenceCo's to straighten them out. -Would anything go wrong if eqType respected type families? No, not at all. But-that makes eqType rather hard to implement.+Would anything go wrong if eqType looked through type families? No, not at+all. But that makes eqType rather hard to implement.  Thus, the guideline for eqType is that it should be the largest easy-to-implement relation that is still smaller than ~ and homogeneous. The@@ -500,6 +525,23 @@ This principle also tells us that eqType must relate only types with the same kinds. +Interestingly, it must be the case that the free variables of t1 and t2+might be different, even if t1 `eqType` t2. A simple example of this is+if we have both cv1 :: k1 ~ k2 and cv2 :: k1 ~ k2 in the environment.+Then t1 = t |> cv1 and t2 = t |> cv2 are eqType; yet cv1 is in the free+vars of t1 and cv2 is in the free vars of t2. Unless we choose to implement+eqType to be just α-equivalence, this wrinkle around free variables+remains.++Yet not all is lost: we can say that any two equal types share the same+*relevant* free variables. Here, a relevant variable is a shallow+free variable (see Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs)+that does not appear within a coercion. Note that type variables can+appear within coercions (in, say, a Refl node), but that coercion variables+cannot appear outside a coercion. We do not (yet) have a function to+extract relevant free variables, but it would not be hard to write if+the need arises.+ Besides eqType, another equality relation that upholds the (EQ) property above is /typechecker equality/, which is implemented as GHC.Tc.Utils.TcType.tcEqType. See@@ -528,7 +570,7 @@  Accordingly, by eliminating reflexive casts, splitTyConApp need not worry about outermost casts to uphold (EQ). Eliminating reflexive casts is done-in mkCastTy.+in mkCastTy. This is (EQ1) below.  Unforunately, that's not the end of the story. Consider comparing   (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)@@ -551,6 +593,7 @@  In order to detect reflexive casts reliably, we must make sure not to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).+This is (EQ2) below.  One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. The kind of the body is the same as the kind of the ForAllTy. Accordingly,@@ -573,6 +616,25 @@  These invariants are all documented above, in the declaration for Type. +Note [Equality on FunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+A (FunTy vis mult arg res) is just an abbreviation for a+  TyConApp funTyCon [mult, arg_rep, res_rep, arg, res]+where+  arg :: TYPE arg_rep+  res :: TYPE res_rep+Note that the vis field of a FunTy appears nowhere in the+equivalent TyConApp. In Core, this is OK, because we no longer+care about the visibility of the argument in a FunTy+(the vis distinguishes between arg -> res and arg => res).+In the type-checker, we are careful not to decompose FunTys+with an invisible argument. See also Note [Decomposing fat arrow c=>t]+in GHC.Core.Type.++In order to compare FunTys while respecting how they could+expand into TyConApps, we must check+the kinds of the arg and the res.+ Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -1541,7 +1603,9 @@   | PluginProv String  -- ^ From a plugin, which asserts that this coercion                        --   is sound. The string is for the use of the plugin. -  | CorePrepProv   -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Pprep+  | CorePrepProv       -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep+      Bool   -- True  <=> the UnivCo must be homogeneously kinded+             -- False <=> allow hetero-kinded, e.g. Int ~ Int#    deriving Data.Data @@ -1549,7 +1613,7 @@   ppr (PhantomProv _)    = text "(phantom)"   ppr (ProofIrrelProv _) = text "(proof irrel.)"   ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))-  ppr CorePrepProv       = text "(CorePrep)"+  ppr (CorePrepProv _)   = text "(CorePrep)"  -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole@@ -1861,7 +1925,7 @@     go_prov env (PhantomProv co)    = go_co env co     go_prov env (ProofIrrelProv co) = go_co env co     go_prov _   (PluginProv _)      = mempty-    go_prov _   CorePrepProv        = mempty+    go_prov _   (CorePrepProv _)    = mempty  {- ********************************************************************* *                                                                      *@@ -1918,7 +1982,7 @@ provSize (PhantomProv co)    = 1 + coercionSize co provSize (ProofIrrelProv co) = 1 + coercionSize co provSize (PluginProv _)      = 1-provSize CorePrepProv        = 1+provSize (CorePrepProv _)    = 1  {- ************************************************************************

@@ -852,7 +852,7 @@     go_prov (PhantomProv kco)    = PhantomProv (go kco)     go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)     go_prov p@(PluginProv _)     = p-    go_prov p@CorePrepProv       = p+    go_prov p@(CorePrepProv _)   = p      -- See Note [Substituting in a coercion hole]     go_hole h@(CoercionHole { ch_co_var = cv })

@@ -250,7 +250,7 @@     go_prov (PhantomProv co)    = PhantomProv $! go co     go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co     go_prov p@(PluginProv _)    = p-    go_prov p@CorePrepProv      = p+    go_prov p@(CorePrepProv _)  = p  tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env)

@@ -22,6 +22,7 @@  import GHC.Core.TyCon import GHC.Core.TyCon.Env+import GHC.Utils.Outputable  {- ************************************************************************@@ -73,6 +74,9 @@ data RecTcChecker = RC !Int (TyConEnv Int)   -- The upper bound, and the number of times   -- we have encountered each TyCon++instance Outputable RecTcChecker where+  ppr (RC n env) = text "RC:" <> int n <+> ppr env  -- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. initRecTc :: RecTcChecker

@@ -43,6 +43,7 @@         tcSplitTyConApp_maybe,         splitListTyConApp_maybe,         repSplitTyConApp_maybe,+        tcRepSplitTyConApp_maybe,          mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,         mkSpecForAllTy, mkSpecForAllTys,@@ -581,7 +582,7 @@     go_prov subst (PhantomProv co)    = PhantomProv (go_co subst co)     go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)     go_prov _     p@(PluginProv _)    = p-    go_prov _     p@CorePrepProv      = p+    go_prov _     p@(CorePrepProv _)  = p        -- the "False" and "const" are to accommodate the type of       -- substForAllCoBndrUsing, which is general enough to@@ -915,7 +916,7 @@     go_prov env (PhantomProv co)    = PhantomProv <$> go_co env co     go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co     go_prov _   p@(PluginProv _)    = return p-    go_prov _   p@CorePrepProv      = return p+    go_prov _   p@(CorePrepProv _)  = return p   {-@@ -1059,14 +1060,17 @@ -- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that -- any coreView stuff is already done. Refuses to look through (c => t) tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 })-  | InvisArg <- af-  = Nothing  -- See Note [Decomposing fat arrow c=>t]-  | otherwise+  | VisArg <- af   -- See Note [Decomposing fat arrow c=>t]++  -- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,+  -- Wrinkle around FunTy+  , Just rep1 <- getRuntimeRep_maybe ty1+  , Just rep2 <- getRuntimeRep_maybe ty2   = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2)-  where-    rep1 = getRuntimeRep ty1-    rep2 = getRuntimeRep ty2 +  | otherwise+  = Nothing+ tcRepSplitAppTy_maybe (AppTy ty1 ty2)    = Just (ty1, ty2) tcRepSplitAppTy_maybe (TyConApp tc tys)   | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc@@ -1473,30 +1477,39 @@ tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'-tcSplitTyConApp_maybe (TyConApp tc tys)          = Just (tc, tys)-tcSplitTyConApp_maybe (FunTy VisArg w arg res)-  | Just arg_rep <- getRuntimeRep_maybe arg-  , Just res_rep <- getRuntimeRep_maybe res-  = Just (funTyCon, [w, arg_rep, res_rep, arg, res])-tcSplitTyConApp_maybe _ = Nothing+                         | otherwise             = tcRepSplitTyConApp_maybe ty  ------------------- repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This -- assumes the synonyms have already been dealt with.+repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)+repSplitTyConApp_maybe (FunTy _ w arg res)+  -- NB: we're in Core, so no check for VisArg+  = Just (funTyCon, [w, arg_rep, res_rep, arg, res])+  where+    arg_rep = getRuntimeRep arg+    res_rep = getRuntimeRep res+repSplitTyConApp_maybe _ = Nothing++tcRepSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+-- ^ Like 'tcSplitTyConApp_maybe', but doesn't look through synonyms. This+-- assumes the synonyms have already been dealt with. -- -- Moreover, for a FunTy, it only succeeds if the argument types -- have enough info to extract the runtime-rep arguments that -- the funTyCon requires.  This will usually be true; -- but may be temporarily false during canonicalization: --     see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical----repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)-repSplitTyConApp_maybe (FunTy _ w arg res)+--     and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,+--         Wrinkle around FunTy+tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)+tcRepSplitTyConApp_maybe (FunTy VisArg w arg res)+  -- NB: VisArg. See Note [Decomposing fat arrow c=>t]   | Just arg_rep <- getRuntimeRep_maybe arg   , Just res_rep <- getRuntimeRep_maybe res   = Just (funTyCon, [w, arg_rep, res_rep, arg, res])-repSplitTyConApp_maybe _ = Nothing+tcRepSplitTyConApp_maybe _ = Nothing  ------------------- -- | Attempts to tease a list type apart and gives the type of the elements if@@ -2508,6 +2521,17 @@ comparing type variables is nondeterministic, note the call to nonDetCmpVar in nonDetCmpTypeX. See Note [Unique Determinism] for more details.++Note [Computing equality on types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several places within GHC that depend on the precise choice of+definitional equality used. If we change that definition, all these places+must be updated. This Note merely serves as a place for all these places+to refer to, so searching for references to this Note will find every place+that needs to be updated.++See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.+ -}  nonDetCmpType :: Type -> Type -> Ordering@@ -2537,6 +2561,7 @@  nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse     -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep+    -- See Note [Computing equality on types] nonDetCmpTypeX env orig_t1 orig_t2 =     case go env orig_t1 orig_t2 of       -- If there are casts then we also need to do a comparison of the kinds of@@ -2591,7 +2616,10 @@       | Just (s1, t1) <- repSplitAppTy_maybe ty1       = go env s1 s2 `thenCmpTy` go env t1 t2     go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)-      = go env s1 s2 `thenCmpTy` go env t1 t2 `thenCmpTy` go env w1 w2+        -- NB: nonDepCmpTypeX does the kind check requested by+        -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep+      = liftOrdering (nonDetCmpTypeX env s1 s2 `thenCmp` nonDetCmpTypeX env t1 t2)+          `thenCmpTy` go env w1 w2         -- Comparing multiplicities last because the test is usually true     go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)       = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2@@ -3109,7 +3137,7 @@     go_prov cxt (PhantomProv co)    = PhantomProv <$> go_co cxt co     go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co     go_prov _   p@(PluginProv _)    = return p-    go_prov _   p@CorePrepProv      = return p+    go_prov _   p@(CorePrepProv _)  = return p   {-@@ -3164,7 +3192,7 @@      go_prov (PhantomProv co)    = go_co co      go_prov (ProofIrrelProv co) = go_co co      go_prov (PluginProv _)      = emptyUniqSet-     go_prov CorePrepProv        = emptyUniqSet+     go_prov (CorePrepProv _)    = emptyUniqSet         -- this last case can happen from the tyConsOfType used from         -- checkTauTvUpdate 

@@ -242,9 +242,13 @@         -> UnfNever   -- See Note [Do not inline top-level bottoming functions]          | otherwise-        -> UnfIfGoodArgs { ug_args  = map (mk_discount cased_bndrs) val_bndrs-                         , ug_size  = size-                         , ug_res   = scrut_discount }+        ->++          -- If you don't force this then we retain all the Ids+          let !discounts = strictMap (mk_discount cased_bndrs) val_bndrs+          in UnfIfGoodArgs { ug_args  = discounts+                           , ug_size  = size+                           , ug_res   = scrut_discount }    where     (bndrs, body) = collectBinders expr

@@ -70,7 +70,7 @@ -- Simplify.simplUnfolding.  mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding-mkSimpleUnfolding opts rhs+mkSimpleUnfolding !opts rhs   = mkUnfolding opts InlineRhs False False rhs  mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding

@@ -801,14 +801,14 @@  Unlike the "impure unifiers" in the typechecker (the eager unifier in GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Canonical), the pure-unifier It does /not/ work up to ~.+unifier does /not/ work up to ~.  The algorithm implemented here is rather delicate, and we depend on it to uphold certain properties. This is a summary of these required properties.  Notation:- θ,φ    substitutions+ θ,φ  substitutions  ξ    type-function-free types  τ,σ  other types  τ♭   type τ, flattened@@ -1068,7 +1068,7 @@          -> UM () -- See Note [Specification of unification] -- Respects newtypes, PredTypes-+-- See Note [Computing equality on types] in GHC.Core.Type unify_ty env ty1 ty2 kco   -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.   | TyConApp tc1 [] <- ty1

@@ -52,7 +52,7 @@ scaleUsage x   (MUsage y) = MUsage $ mkMultMul x y  -- For now, we use extra multiplicity Bottom for empty case.-data UsageEnv = UsageEnv (NameEnv Mult) Bool+data UsageEnv = UsageEnv !(NameEnv Mult) Bool  unitUE :: NamedThing n => n -> Mult -> UsageEnv unitUE x w = UsageEnv (unitNameEnv (getName x) w) False

@@ -11,7 +11,7 @@ -- | Commonly useful utilities for manipulating the Core language module GHC.Core.Utils (         -- * Constructing expressions-        mkCast,+        mkCast, mkCastMCo, mkPiMCo,         mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,         bindNonRec, needsCaseBinding,         mkAltExpr, mkDefaultCase, mkSingleAltCase,@@ -136,7 +136,7 @@ exprType (Lam binder expr)   = mkLamType binder (exprType expr) exprType e@(App _ _)   = case collectArgs e of-        (fun, args) -> applyTypeToArgs e (exprType fun) args+        (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args  exprType other = pprPanic "exprType" (pprCoreExpr other) @@ -264,10 +264,10 @@ -}  -- Not defined with applyTypeToArg because you can't print from GHC.Core.-applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type+applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context-applyTypeToArgs e op_ty args+applyTypeToArgs pp_e op_ty args   = go op_ty args   where     go op_ty []                   = op_ty@@ -286,19 +286,27 @@     go_ty_args op_ty rev_tys args        = go (piResultTys op_ty (reverse rev_tys)) args -    panic_msg as = vcat [ text "Expression:" <+> pprCoreExpr e-                     , text "Type:" <+> ppr op_ty-                     , text "Args:" <+> ppr args-                     , text "Args':" <+> ppr as ]+    panic_msg as = vcat [ text "Expression:" <+> pp_e+                        , text "Type:" <+> ppr op_ty+                        , text "Args:" <+> ppr args+                        , text "Args':" <+> ppr as ] +mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr+mkCastMCo e MRefl    = e+mkCastMCo e (MCo co) = Cast e co+  -- We are careful to use (MCo co) only when co is not reflexive+  -- Hence (Cast e co) rather than (mkCast e co) -{--************************************************************************+mkPiMCo :: Var -> MCoercionR -> MCoercionR+mkPiMCo _  MRefl   = MRefl+mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)+++{- ********************************************************************* *                                                                      *-\subsection{Attaching notes}+             Casts *                                                                      *-************************************************************************--}+********************************************************************* -}  -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions@@ -338,6 +346,13 @@           $$ callStackDoc )     (Cast expr co) ++{- *********************************************************************+*                                                                      *+             Attaching ticks+*                                                                      *+********************************************************************* -}+ -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: CoreTickish -> CoreExpr -> CoreExpr@@ -2483,8 +2498,7 @@        , let mult = idMult bndr        , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty        , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort-       = let reflCo = mkRepReflCo (idType bndr)-         in Just (mkFunCo Representational (multToCo mult) reflCo co, [])+       = Just (mkFunResCo Representational (idScaledType bndr) co, [])     ok_arg bndr (Cast e co_arg) co fun_ty        | (ticks, Var v) <- stripTicksTop tickishFloatable e        , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty

@@ -313,8 +313,7 @@     go_prov (PhantomProv co)    = IfacePhantomProv (go co)     go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)     go_prov (PluginProv str)    = IfacePluginProv str-    go_prov CorePrepProv        = pprPanic "toIfaceCoercionX" empty-         -- CorePrepProv only happens after the iface file is generated+    go_prov (CorePrepProv b)    = IfaceCorePrepProv b  toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet

@@ -46,8 +46,12 @@           -- * Parsing integers         parseUnsignedInteger,-       ) where +        -- * Checking for bi-directional format characters+        containsBidirectionalFormatChar,+        bidirectionalFormatChars+        ) where+ #include "GhclibHsVersions.h"  import GHC.Prelude@@ -214,6 +218,58 @@           (# c#, nBytes# #) ->              let cur' = I# (cur# +# nBytes#) in              return (C# c#, StringBuffer buf len cur')+++bidirectionalFormatChars :: [(Char,String)]+bidirectionalFormatChars =+  [ ('\x202a' , "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)")+  , ('\x202b' , "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)")+  , ('\x202c' , "U+202C POP DIRECTIONAL FORMATTING (PDF)")+  , ('\x202d' , "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)")+  , ('\x202e' , "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)")+  , ('\x2066' , "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)")+  , ('\x2067' , "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)")+  , ('\x2068' , "U+2068 FIRST STRONG ISOLATE (FSI)")+  , ('\x2069' , "U+2069 POP DIRECTIONAL ISOLATE (PDI)")+  ]++{-| Returns true if the buffer contains Unicode bi-directional formatting+characters.++https://www.unicode.org/reports/tr9/#Bidirectional_Character_Types++Bidirectional format characters are one of+'\x202a' : "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)"+'\x202b' : "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)"+'\x202c' : "U+202C POP DIRECTIONAL FORMATTING (PDF)"+'\x202d' : "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)"+'\x202e' : "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)"+'\x2066' : "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)"+'\x2067' : "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)"+'\x2068' : "U+2068 FIRST STRONG ISOLATE (FSI)"+'\x2069' : "U+2069 POP DIRECTIONAL ISOLATE (PDI)"++This list is encoded in 'bidirectionalFormatChars'++-}+{-# INLINE containsBidirectionalFormatChar #-}+containsBidirectionalFormatChar :: StringBuffer -> Bool+containsBidirectionalFormatChar (StringBuffer buf (I# len#) (I# cur#))+  = inlinePerformIO $ unsafeWithForeignPtr buf $ \(Ptr a#) -> do+  let go :: Int# -> Bool+      go i | isTrue# (i >=# len#) = False+           | otherwise = case utf8DecodeCharAddr# a# i of+                (# '\x202a'#  , _ #) -> True+                (# '\x202b'#  , _ #) -> True+                (# '\x202c'#  , _ #) -> True+                (# '\x202d'#  , _ #) -> True+                (# '\x202e'#  , _ #) -> True+                (# '\x2066'#  , _ #) -> True+                (# '\x2067'#  , _ #) -> True+                (# '\x2068'#  , _ #) -> True+                (# '\x2069'#  , _ #) -> True+                (# _, bytes #) -> go (i +# bytes)+  pure $! go cur#  -- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous -- to 'Data.List.head').  __Warning:__ The behavior is undefined if the

@@ -128,6 +128,7 @@    | Opt_DoCmmLinting    | Opt_DoAsmLinting    | Opt_DoAnnotationLinting+   | Opt_DoBoundsChecking    | Opt_NoLlvmMangler                  -- hidden flag    | Opt_FastLlvm                       -- hidden flag    | Opt_NoTypeableBinds@@ -266,6 +267,7 @@    | Opt_Ticky_Dyn_Thunk    | Opt_RPath    | Opt_RelativeDynlibPaths+   | Opt_CompactUnwind               -- ^ @-fcompact-unwind@    | Opt_Hpc    | Opt_FamAppCache    | Opt_ExternalInterpreter@@ -512,6 +514,7 @@    | Opt_WarnAmbiguousFields                -- Since 9.2    | Opt_WarnImplicitLift                 -- Since 9.2    | Opt_WarnMissingKindSignatures        -- Since 9.2+   | Opt_WarnUnicodeBidirectionalFormatCharacters -- Since 9.0.2    deriving (Eq, Ord, Show, Enum)  -- | Used when outputting warnings: if a reason is given, it is

@@ -27,7 +27,6 @@ import GHC.Types.SourceFile  import GHC.Unit.Module-import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModIface import GHC.Unit.Module.Status @@ -82,7 +81,7 @@          -- ^ additional object files resulting from compiling foreign          -- code. They come from two sources: foreign stubs, and          -- add{C,Cxx,Objc,Objcxx}File from template haskell-       iface :: Maybe (ModIface, ModDetails)+       iface :: Maybe ModIface          -- ^ Interface generated by HscOut phase. Only available after the          -- phase runs.   }@@ -90,7 +89,7 @@ pipeStateDynFlags :: PipeState -> DynFlags pipeStateDynFlags = hsc_dflags . hsc_env -pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails)+pipeStateModIface :: PipeState -> Maybe ModIface pipeStateModIface = iface  data PipelineOutput@@ -139,5 +138,5 @@ setForeignOs os = P $ \_env state ->   return (state{ foreign_os = os }, ()) -setIface :: ModIface -> ModDetails -> CompPipeline ()-setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ())+setIface :: ModIface -> CompPipeline ()+setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ())

@@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}  ------------------------------------------------------------------------------- --@@ -42,6 +43,7 @@         DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,         dynamicOutputFile, dynamicOutputHi,         sccProfilingEnabled,+        needSourceNotes,         DynFlags(..),         outputFile, hiSuf, objectSuf, ways,         FlagSpec(..),@@ -882,13 +884,28 @@ opt_i dflags= toolSettings_opt_i $ toolSettings dflags  -- | The directory for this version of ghc in the user's app directory--- (typically something like @~/.ghc/x86_64-linux-7.6.3@)+-- The appdir used to be in ~/.ghc but to respect the XDG specification+-- we want to move it under $XDG_DATA_HOME/+-- However, old tooling (like cabal) might still write package environments+-- to the old directory, so we prefer that if a subdirectory of ~/.ghc+-- with the correct target and GHC version suffix exists. --+-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that+-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR+--+-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath versionedAppDir appname platform = do   -- Make sure we handle the case the HOME isn't set (see #11678)-  appdir <- tryMaybeT $ getXdgDirectory XdgData appname-  return $ appdir </> versionedFilePath platform+  -- We need to fallback to the old scheme if the subdirectory exists.+  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))+       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/+       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/+       ]+  where+    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case+      True -> pure dir+      False -> MaybeT (pure Nothing)  versionedFilePath :: ArchOS -> FilePath versionedFilePath platform = uniqueSubdir platform@@ -2095,6 +2112,12 @@       (NoArg (setGeneralFlag Opt_SingleLibFolder))   , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))   , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))+  , make_ord_flag defGhcFlag "fcompact-unwind"+      (noArgM (\dflags -> do+       if platformOS (targetPlatform dflags) == OSDarwin+          then return (gopt_set dflags Opt_CompactUnwind)+          else do addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring."+                  return dflags))          ------- Specific phases  --------------------------------------------     -- need to appear before -pgmL to be parsed as LLVM flags.@@ -3234,7 +3257,9 @@   flagSpec "invalid-haddock"             Opt_WarnInvalidHaddock,   flagSpec "operator-whitespace-ext-conflict"  Opt_WarnOperatorWhitespaceExtConflict,   flagSpec "operator-whitespace"         Opt_WarnOperatorWhitespace,-  flagSpec "implicit-lift"               Opt_WarnImplicitLift+  flagSpec "implicit-lift"               Opt_WarnImplicitLift,+  flagSpec "unicode-bidirectional-format-characters"+                                         Opt_WarnUnicodeBidirectionalFormatCharacters  ]  -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@@@ -3387,6 +3412,7 @@   flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,   flagSpec "catch-bottoms"                    Opt_CatchBottoms,   flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,+  flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,   flagSpec "num-constant-folding"             Opt_NumConstantFolding,   flagSpec "show-warning-groups"              Opt_ShowWarnGroups,   flagSpec "hide-source-paths"                Opt_HideSourcePaths,@@ -4891,6 +4917,11 @@ -- | Indicate if cost-centre profiling is enabled sccProfilingEnabled :: DynFlags -> Bool sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)++-- | Indicate whether we need to generate source notes+needSourceNotes :: DynFlags -> Bool+needSourceNotes dflags = debugLevel dflags > 0+                       || gopt Opt_InfoTableMap dflags  -- ----------------------------------------------------------------------------- -- Linker/compiler information

@@ -1690,6 +1690,7 @@ freeNamesIfProv (IfacePhantomProv co)    = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _)      = emptyNameSet+freeNamesIfProv (IfaceCorePrepProv _)    = emptyNameSet  freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr

@@ -397,6 +397,7 @@   = IfacePhantomProv IfaceCoercion   | IfaceProofIrrelProv IfaceCoercion   | IfacePluginProv String+  | IfaceCorePrepProv Bool  -- See defn of CorePrepProv  {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -596,7 +597,8 @@      go_prov (IfacePhantomProv co)    = IfacePhantomProv (go_co co)     go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)-    go_prov (IfacePluginProv str)    = IfacePluginProv str+    go_prov co@(IfacePluginProv _)   = co+    go_prov co@(IfaceCorePrepProv _) = co  substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args@@ -1755,6 +1757,8 @@   = text "irrel" <+> pprParendIfaceCoercion co pprIfaceUnivCoProv (IfacePluginProv s)   = text "plugin" <+> doubleQuotes (text s)+pprIfaceUnivCoProv (IfaceCorePrepProv _)+  = text "CorePrep"  ------------------- instance Outputable IfaceTyCon where@@ -2112,6 +2116,9 @@   put_ bh (IfacePluginProv a) = do           putByte bh 3           put_ bh a+  put_ bh (IfaceCorePrepProv a) = do+          putByte bh 4+          put_ bh a    get bh = do       tag <- getByte bh@@ -2122,6 +2129,8 @@                    return $ IfaceProofIrrelProv a            3 -> do a <- get bh                    return $ IfacePluginProv a+           4 -> do a <- get bh+                   return (IfaceCorePrepProv a)            _ -> panic ("get IfaceUnivCoProv " ++ show tag)  

@@ -492,11 +492,11 @@ -- new AST fragments out of old ones, and have them still printed out -- in a precise way. data EpAnn ann-  = EpAnn { entry   :: Anchor+  = EpAnn { entry   :: !Anchor            -- ^ Base location for the start of the syntactic element            -- holding the annotations.-           , anns     :: ann -- ^ Annotations added by the Parser-           , comments :: EpAnnComments+           , anns     :: !ann -- ^ Annotations added by the Parser+           , comments :: !EpAnnComments               -- ^ Comments enclosed in the SrcSpan of the element               -- this `EpAnn` is attached to            }@@ -563,7 +563,10 @@ -- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with -- an extra annotation type. This is mapped to a specific `GenLocated` -- usage in the AST through the `XRec` and `Anno` type families.-data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan }++-- Important that the fields are strict as these live inside L nodes which+-- are live for a long time.+data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan }         deriving (Data, Eq) -- See Note [XRec and Anno in the AST] 

@@ -30,6 +30,7 @@ import GHC.Utils.Outputable (SDoc) import GHC.Data.FastString import GHC.Unit.Module.Name+import Data.List.NonEmpty (NonEmpty)  -- | A warning that might arise during parsing. data PsWarning@@ -39,6 +40,14 @@       { tabFirst :: !SrcSpan -- ^ First occurrence of a tab       , tabCount :: !Word    -- ^ Number of other occurrences       }++   {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag)+   that occurs when unicode bi-directional format characters are found within in a file++   The 'PsLoc' contains the exact position in the buffer the character occured, and the+   string contains a description of the character.+   -}+   | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String))     | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason       -- ^ Transitional layout warnings

@@ -24,6 +24,7 @@ import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple)+import Data.List.NonEmpty (NonEmpty((:|)))  mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc mkParserErr span doc = MsgEnvelope@@ -61,6 +62,20 @@                TransLayout_Where -> "`where' clause at the same depth as implicit layout block"                TransLayout_Pipe  -> "`|' at the same depth as implicit layout block"             )++   PsWarnBidirectionalFormatChars ((loc,_,desc) :| xs)+      -> mkParserWarn Opt_WarnUnicodeBidirectionalFormatCharacters (RealSrcSpan (realSrcLocSpan $ psRealLoc loc) Nothing) $+            text "A unicode bidirectional formatting character" <+> parens (text desc)+         $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file"+         $$ (case xs of+           [] -> empty+           xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs+            where+              pprChars [] = empty+              pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc+                                       $$ pprChars xs+              )+         $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors"     PsWarnUnrecognisedPragma loc       -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $

@@ -627,6 +627,10 @@ But in fact (GivenInv) is automatically true, so we're adhering to it for now.  See #18929. +* If a tyvar tv has level n, then the levels of all variables free+  in tv's kind are <= n. Consequence: if tv is untouchable, so are+  all variables in tv's kind.+ Note [WantedInv] ~~~~~~~~~~~~~~~~ Why is WantedInv important?  Consider this implication, where@@ -1593,6 +1597,7 @@            -> Type -> Type            -> Bool -- Flags False, False is the usual setting for tc_eq_type+-- See Note [Computing equality on types] in Type tc_eq_type keep_syns vis_only orig_ty1 orig_ty2   = go orig_env orig_ty1 orig_ty2   where@@ -1622,10 +1627,14 @@     -- Make sure we handle all FunTy cases since falling through to the     -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked     -- kind variable, which causes things to blow up.+    -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check+    -- kinds here     go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)-      = go env w1 w2 && go env arg1 arg2 && go env res1 res2-    go env ty (FunTy _ w arg res) = eqFunTy env w arg res ty-    go env (FunTy _ w arg res) ty = eqFunTy env w arg res ty+      = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2+      where+        kinds_eq | vis_only  = True+                 | otherwise = go env (typeKind arg1) (typeKind arg2) &&+                               go env (typeKind res1) (typeKind res2)        -- See Note [Equality on AppTys] in GHC.Core.Type     go env (AppTy s1 t1)        ty2@@ -1660,25 +1669,6 @@      orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] -    -- @eqFunTy w arg res ty@ is True when @ty@ equals @FunTy w arg res@. This is-    -- sometimes hard to know directly because @ty@ might have some casts-    -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't-    -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or-    -- res is unzonked. Thus this function, which handles this-    -- corner case.-    eqFunTy :: RnEnv2 -> Mult -> Type -> Type -> Type -> Bool-               -- Last arg is /not/ FunTy-    eqFunTy env w arg res ty@(AppTy{}) = get_args ty []-      where-        get_args :: Type -> [Type] -> Bool-        get_args (AppTy f x)       args = get_args f (x:args)-        get_args (CastTy t _)      args = get_args t args-        get_args (TyConApp tc tys) args-          | tc == funTyCon-          , [w', _, _, arg', res'] <- tys ++ args-          = go env w w' && go env arg arg' && go env res res'-        get_args _ _    = False-    eqFunTy _ _ _ _ _   = False {-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type].  {- Note [Typechecker equality vs definitional equality]

@@ -357,7 +357,7 @@ viewProd n (Prod ds)   | ds `lengthIs` n = Just ds -- Note the strict application to replicate: This makes sure we don't allocate -- a thunk for it, inlines it and lets case-of-case fire at call sites.-viewProd n (Poly card)                   = Just (replicate n $! polyDmd card)+viewProd n (Poly card)                   = Just $! (replicate n $! polyDmd card) viewProd _ _                             = Nothing {-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation                         -- for Arity. Otherwise, #18304 bites us.@@ -386,7 +386,7 @@ lubSubDmd :: SubDemand -> SubDemand -> SubDemand -- Handle Prod lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =-  Prod $ zipWith lubDmd ds2 ds1 -- try to fuse with ds2+  Prod $ strictZipWith lubDmd ds2 ds1 -- try to fuse with ds2 -- Handle Call lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))   -- See Note [Call demands are relative]@@ -1084,7 +1084,7 @@ -- Subject to Note [Default demand on free variables and arguments] type DmdEnv = VarEnv Demand -emptyDmdEnv :: VarEnv Demand+emptyDmdEnv :: DmdEnv emptyDmdEnv = emptyVarEnv  multDmdEnv :: Card -> DmdEnv -> DmdEnv@@ -1118,9 +1118,9 @@ --    * Diverges on every code path or not ('dt_div') data DmdType   = DmdType-  { dt_env  :: DmdEnv     -- ^ Demand on explicitly-mentioned free variables-  , dt_args :: [Demand]   -- ^ Demand on arguments-  , dt_div  :: Divergence -- ^ Whether evaluation diverges.+  { dt_env  :: !DmdEnv     -- ^ Demand on explicitly-mentioned free variables+  , dt_args :: ![Demand]   -- ^ Demand on arguments+  , dt_div  :: !Divergence -- ^ Whether evaluation diverges.                           -- See Note [Demand type Divergence]   } @@ -1225,9 +1225,10 @@ peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)                                (DmdType fv' ds res, dmd)   where-  fv' = fv `delVarEnv` id+  -- Force these arguments so that old `Env` is not retained.+  !fv' = fv `delVarEnv` id   -- See Note [Default demand on free variables and arguments]-  dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res+  !dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res  addDemand :: Demand -> DmdType -> DmdType addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res

@@ -66,6 +66,7 @@         isRecordSelector, isNaughtyRecordSelector,         isPatSynRecordSelector,         isDataConRecordSelector,+        isClassOpId,         isClassOpId_maybe, isDFunId,         isPrimOpId, isPrimOpId_maybe,         isFCallId, isFCallId_maybe,@@ -458,6 +459,7 @@ isDataConWorkId         :: Id -> Bool isDataConWrapId         :: Id -> Bool isDFunId                :: Id -> Bool+isClassOpId             :: Id -> Bool  isClassOpId_maybe       :: Id -> Maybe Class isPrimOpId_maybe        :: Id -> Maybe PrimOp@@ -480,6 +482,10 @@ isNaughtyRecordSelector id = case Var.idDetails id of                         RecSelId { sel_naughty = n } -> n                         _                               -> False++isClassOpId id = case Var.idDetails id of+                        ClassOpId _   -> True+                        _other        -> False  isClassOpId_maybe id = case Var.idDetails id of                         ClassOpId cls -> Just cls

@@ -58,7 +58,7 @@         -- ** Coercions         , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit         , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit-        , extendIntLit, extendWordLit+        , convertToIntLit, convertToWordLit         , charToIntLit, intToCharLit         , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit         , nullAddrLit, floatToDoubleLit, doubleToFloatLit@@ -682,13 +682,14 @@ narrowWord32Lit = narrowLit' @Word32 LitNumWord32 narrowWord64Lit = narrowLit' @Word64 LitNumWord64 --- | Extend a fixed-width literal (e.g. 'Int16#') to a word-sized literal (e.g.--- 'Int#').-extendWordLit, extendIntLit :: Platform -> Literal -> Literal-extendWordLit platform (LitNumber _nt i)  = mkLitWord platform i-extendWordLit _platform l                 = pprPanic "extendWordLit" (ppr l)-extendIntLit  platform (LitNumber _nt i)  = mkLitInt platform i-extendIntLit  _platform l                 = pprPanic "extendIntLit" (ppr l)+-- | Extend or narrow a fixed-width literal (e.g. 'Int16#') to a target+-- word-sized literal ('Int#' or 'Word#'). Narrowing can only happen on 32-bit+-- architectures when we convert a 64-bit literal into a 32-bit one.+convertToWordLit, convertToIntLit :: Platform -> Literal -> Literal+convertToWordLit platform (LitNumber _nt i)  = mkLitWordWrap platform i+convertToWordLit _platform l                 = pprPanic "convertToWordLit" (ppr l)+convertToIntLit  platform (LitNumber _nt i)  = mkLitIntWrap platform i+convertToIntLit  _platform l                 = pprPanic "convertToIntLit" (ppr l)  charToIntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c)) charToIntLit l                 = pprPanic "charToIntLit" (ppr l)

@@ -134,6 +134,7 @@ elemNameEnv x y          = elemUFM x y plusNameEnv x y          = plusUFM x y plusNameEnv_C f x y      = plusUFM_C f x y+{-# INLINE plusNameEnv_CD #-} plusNameEnv_CD f x d y b = plusUFM_CD f x d y b plusNameEnv_CD2 f x y    = plusUFM_CD2 f x y extendNameEnv_C f x y z  = addToUFM_C f x y z

@@ -486,10 +486,10 @@ -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt-  = GRE { gre_name :: GreName      -- ^ See Note [GreNames]-        , gre_par  :: Parent       -- ^ See Note [Parents]-        , gre_lcl :: Bool          -- ^ True <=> the thing was defined locally-        , gre_imp :: [ImportSpec]  -- ^ In scope through these imports+  = GRE { gre_name :: !GreName      -- ^ See Note [GreNames]+        , gre_par  :: !Parent       -- ^ See Note [Parents]+        , gre_lcl :: !Bool          -- ^ True <=> the thing was defined locally+        , gre_imp :: ![ImportSpec]  -- ^ In scope through these imports     } deriving (Data, Eq)          -- INVARIANT: either gre_lcl = True or gre_imp is non-empty          -- See Note [GlobalRdrElt provenance]

@@ -72,6 +72,7 @@ import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable +import qualified Data.IntMap.Strict as MS import qualified Data.IntMap as M import Data.Data import Data.Functor.Classes (Eq1 (..))@@ -122,7 +123,7 @@ -- | A type of values tagged with insertion time data TaggedVal val =   TaggedVal-    val+    !val     {-# UNPACK #-} !Int -- ^ insertion time   deriving stock (Data, Functor, Foldable, Traversable) @@ -175,20 +176,24 @@ -- The new binding always goes to the right of existing ones addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_Directly (UDFM m i) u v-  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+  = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)   where     tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i       -- Keep the old tag, but insert the new value       -- This means that udfmToList typically returns elements       -- in the order of insertion, rather than the reverse +      -- It is quite critical that the strict insertWith is used as otherwise+      -- the combination function 'tf' is not forced and both old values are retained+      -- in the map.+ addToUDFM_C_Directly   :: (elt -> elt -> elt)   -- old -> new -> result   -> UniqDFM key elt   -> Unique -> elt   -> UniqDFM key elt addToUDFM_C_Directly f (UDFM m i) u v-  = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)+  = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1)     where       tf (TaggedVal new_v _) (TaggedVal old_v old_i)          = TaggedVal (f old_v new_v) old_i@@ -400,7 +405,10 @@  -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2-mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i+mapUDFM f (UDFM m i) = UDFM (MS.map (fmap f) m) i+-- Critical this is strict map, otherwise you get a big space leak when reloading+-- in GHCi because all old ModDetails are retained (see pruneHomePackageTable).+-- Modify with care.  mapMaybeUDFM :: forall elt1 elt2 key.                 (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2

@@ -233,12 +233,16 @@ -- there is no entry in `m1` reps. `m2`. The domain is the union of -- the domains of `m1` and `m2`. --+-- IMPORTANT NOTE: This function strictly applies the modification function+-- and forces the result unlike most the other functions in this module.+-- -- Representative example: -- -- @ -- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 --    == {A: f 1 42, B: f 2 3, C: f 23 4 } -- @+{-# INLINE plusUFM_CD #-} plusUFM_CD   :: (elta -> eltb -> eltc)   -> UniqFM key elta  -- map X@@ -247,10 +251,10 @@   -> eltb         -- default for Y   -> UniqFM key eltc plusUFM_CD f (UFM xm) dx (UFM ym) dy-  = UFM $ M.mergeWithKey+  = UFM $ MS.mergeWithKey       (\_ x y -> Just (x `f` y))-      (M.map (\x -> x `f` dy))-      (M.map (\y -> dx `f` y))+      (MS.map (\x -> x `f` dy))+      (MS.map (\y -> dx `f` y))       xm ym  -- | `plusUFM_CD2 f m1 m2` merges the maps using `f` as the combining@@ -258,6 +262,9 @@ -- instead passed as `Nothing` to `f`. `f` can never have both its arguments -- be `Nothing`. --+-- IMPORTANT NOTE: This function strictly applies the modification function+-- and forces the result.+-- -- `plusUFM_CD2 f m1 m2` is the same as `plusUFM_CD f (mapUFM Just m1) Nothing -- (mapUFM Just m2) Nothing`. plusUFM_CD2@@ -266,10 +273,10 @@   -> UniqFM key eltb  -- map Y   -> UniqFM key eltc plusUFM_CD2 f (UFM xm) (UFM ym)-  = UFM $ M.mergeWithKey+  = UFM $ MS.mergeWithKey       (\_ x y -> Just (Just x `f` Just y))-      (M.map (\x -> Just x `f` Nothing))-      (M.map (\y -> Nothing `f` Just y))+      (MS.map (\x -> Just x `f` Nothing))+      (MS.map (\y -> Nothing `f` Just y))       xm ym  mergeUFM

@@ -64,7 +64,7 @@         rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe,         rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap,         delBndrL, delBndrR, delBndrsL, delBndrsR,-        addRnInScopeSet,+        extendRnInScopeSetList,         rnEtaL, rnEtaR,         rnInScope, rnInScopeSet, lookupRnInScope,         rnEnvL, rnEnvR,@@ -260,10 +260,10 @@                         , envR     = emptyVarEnv                         , in_scope = vars } -addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2-addRnInScopeSet env vs-  | isEmptyVarSet vs = env-  | otherwise        = env { in_scope = extendInScopeSetSet (in_scope env) vs }+extendRnInScopeSetList :: RnEnv2 -> [Var] -> RnEnv2+extendRnInScopeSetList env vs+  | null vs   = env+  | otherwise = env { in_scope = extendInScopeSetList (in_scope env) vs }  rnInScope :: Var -> RnEnv2 -> Bool rnInScope x env = x `elemInScopeSet` in_scope env

@@ -38,9 +38,11 @@         -- ^ The basic loaded interface file: every loaded module has one of         -- these, even if it is imported from another package -   , hm_details  :: !ModDetails+   , hm_details  :: ModDetails         -- ^ Extra information that has been created from the 'ModIface' for         -- the module, typically during typechecking++        -- This field is LAZY because a ModDetails is constructed by knot tying.     , hm_linkable :: !(Maybe Linkable)         -- ^ The actual artifact we would like to link to access things in

@@ -28,7 +28,6 @@           -- ^ Information for the code generator.         , hscs_mod_location   :: !ModLocation           -- ^ Module info-        , hscs_mod_details    :: !ModDetails         , hscs_partial_iface  :: !PartialModIface           -- ^ Partial interface         , hscs_old_iface_hash :: !(Maybe Fingerprint)

@@ -85,7 +85,7 @@         transitiveClosure,          -- * Strictness-        seqList, strictMap,+        seqList, strictMap, strictZipWith,          -- * Module names         looksLikeModuleName,@@ -1062,6 +1062,16 @@   let     !x' = f x     !xs' = strictMap f xs+  in+    x' : xs'++strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c]+strictZipWith _ [] _ = []+strictZipWith _ _ [] = []+strictZipWith f (x : xs) (y: ys) =+  let+    !x' = f x y+    !xs' = strictZipWith f xs ys   in     x' : xs' 

@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 9.2.1.20220109+version: 9.2.2.20220307 license: BSD3 license-file: LICENSE category: Development

@@ -488,8 +488,8 @@ happyOut69 :: (HappyAbsSyn ) -> HappyWrap69 happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut69 #-}-newtype HappyWrap70 = HappyWrap70 (Located (SourceText,Int))-happyIn70 :: (Located (SourceText,Int)) -> (HappyAbsSyn )+newtype HappyWrap70 = HappyWrap70 (Maybe (Located (SourceText,Int)))+happyIn70 :: (Maybe (Located (SourceText,Int))) -> (HappyAbsSyn ) happyIn70 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap70 x) {-# INLINE happyIn70 #-} happyOut70 :: (HappyAbsSyn ) -> HappyWrap70@@ -4402,7 +4402,7 @@ happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_133 = happySpecReduce_0  54# happyReduction_133 happyReduction_133  =  happyIn70-		 (noLoc (NoSourceText,9)+		 (Nothing 	)  happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -4410,7 +4410,7 @@ happyReduction_134 happy_x_1 	 =  case happyOutTok happy_x_1 of { happy_var_1 ->  	happyIn70-		 (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1)))+		 (Just (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1)))) 	)}  happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -8230,10 +8230,18 @@ 	 = happyThen ((case happyOut71 happy_x_1 of { (HappyWrap71 happy_var_1) ->  	case happyOut70 happy_x_2 of { (HappyWrap70 happy_var_2) ->  	case happyOut72 happy_x_3 of { (HappyWrap72 happy_var_3) -> -	( checkPrecP happy_var_2 happy_var_3 >>-                 acsA (\cs -> sLL happy_var_1 happy_var_3 $ SigD noExtField-                        (FixSig (EpAnn (glR happy_var_1) [mj AnnInfix happy_var_1,mj AnnVal happy_var_2] cs) (FixitySig noExtField (fromOL $ unLoc happy_var_3)-                                (Fixity (fst $ unLoc happy_var_2) (snd $ unLoc happy_var_2) (unLoc happy_var_1))))))}}})+	( do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 happy_var_3+                                                      ; pure (mj AnnVal l2) })+                                       happy_var_2+                   ; let (fixText, fixPrec) = case happy_var_2 of+                                                -- If an explicit precedence isn't supplied,+                                                -- it defaults to maxPrecedence+                                                Nothing -> (NoSourceText, maxPrecedence)+                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)+                   ; acsA (\cs -> sLL happy_var_1 happy_var_3 $ SigD noExtField+                            (FixSig (EpAnn (glR happy_var_1) (mj AnnInfix happy_var_1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc happy_var_3)+                                    (Fixity fixText fixPrec (unLoc happy_var_1)))))+                   })}}}) 	) (\r -> happyReturn (happyIn202 r))  happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )

@@ -206,7 +206,7 @@   , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n   The ByteArray\\# and the memory region at Addr\\# must fully contain the\n   specified ranges, but this is not checked. The Addr\\# must not point into the\n   ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n   either.")   , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n   Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n   pinned), but this is not checked either.")   , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n   MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n   but this is not checked either.")-  , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len]@ of\n   the @MutableByteArray#@ to the byte @c@.")+  , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len)@ of\n   the @MutableByteArray#@ to the byte @c@.")   , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")

@@ -97,7 +97,7 @@ /* Define to 1 if you have the <bfd.h> header file. */ /* #undef HAVE_BFD_H */ -/* Does GCC support __atomic primitives? */+/* Does C compiler support __atomic primitives? */ #define HAVE_C11_ATOMICS 1  /* Define to 1 if you have the `clock_gettime' function. */@@ -113,6 +113,10 @@    don't. */ #define HAVE_DECL_CTIME_R 1 +/* Define to 1 if you have the declaration of `environ', and to 0 if you+   don't. */+#define HAVE_DECL_ENVIRON 0+ /* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you    don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */@@ -374,6 +378,9 @@ /* Define to 1 if C symbols have a leading underscore added by the compiler.    */ #define LEADING_UNDERSCORE 1++/* Define to 1 if we need -latomic. */+#define NEED_ATOMIC_LIB 0  /* Define 1 if we need to link code using pthreads with -lpthread */ #define NEED_PTHREAD_LIB 0

@@ -40,7 +40,6 @@ ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang")-,("BigNum backend", "native") ,("Use interpreter", "YES") ,("Support SMP", "YES") ,("RTS ways", "v thr")

@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "82e6bf12786908ccda643dd1dceb42abcc97290c"+cProjectGitCommitId   = "fbaee70d380973f71fa6e9e15be746532e5a4fc5"  cProjectVersion       :: String-cProjectVersion       = "9.2.1"+cProjectVersion       = "9.2.2"  cProjectVersionInt    :: String cProjectVersionInt    = "902"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "1"+cProjectPatchLevel    = "2"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "1"+cProjectPatchLevel1   = "2"  cProjectPatchLevel2   :: String cProjectPatchLevel2   = ""

@@ -87,6 +87,10 @@ import Control.Exception as Exception import Control.Monad (when) import System.FilePath as FilePath+#if !defined(mingw32_HOST_OS)+import System.Posix.Files+import GHC.IO.Exception (ioe_type, IOErrorType(NoSuchThing))+#endif import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType))@@ -503,6 +507,26 @@ -- Copied from Cabal's Distribution.Simple.Utils. writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO () writeFileAtomic targetPath content = do+  -- Figure out how to update the file mode after we create the temporary file+  let no_update _path = return ()+#if !defined(mingw32_HOST_OS)+  let on_error ioe =+          -- If the file doesn't yet exist then just use the default owner and+          -- mode.+          case ioe_type ioe of+            NoSuchThing -> return no_update+            _ -> ioError ioe+  let handleIO :: (IOException -> IO a) -> IO a -> IO a+      handleIO = flip catch+  set_metadata <- handleIO on_error $ do+      status <- getFileStatus targetPath+      return $ \path -> do+        setFileMode path (fileMode status)+        setOwnerAndGroup path (fileOwner status) (fileGroup status)+#else+  let set_metadata = no_update+#endif+   let (targetDir, targetFile) = splitFileName targetPath   Exception.bracketOnError     (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")@@ -510,6 +534,7 @@     (\(tmpPath, handle) -> do         BS.Lazy.hPut handle content         hClose handle+        set_metadata tmpPath         renameFile tmpPath targetPath)  instance Binary DbUnitInfo where

@@ -386,8 +386,10 @@   | BlockedOnCCall   | BlockedOnCCall_Interruptible   | BlockedOnMsgThrowTo-  | ThreadMigrating+#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 902   | BlockedOnIOCompletion+#endif+  | ThreadMigrating   | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug   deriving (Eq, Show, Generic, Ord) 

@@ -77,7 +77,7 @@                         (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible                         (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo                         (#const ThreadMigrating) -> ThreadMigrating-#if __GLASGOW_HASKELL__ >= 811+#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 902                         (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion #endif                         _ -> WhyBlockedUnknownValue w

@@ -77,7 +77,7 @@                         (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible                         (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo                         (#const ThreadMigrating) -> ThreadMigrating-#if __GLASGOW_HASKELL__ >= 811+#if __GLASGOW_HASKELL__ >= 811 && __GLASGOW_HASKELL__ < 902                         (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion #endif                         _ -> WhyBlockedUnknownValue w

@@ -462,7 +462,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\   (major1) <  9 || \   (major1) == 9 && (major2) <  2 || \-  (major1) == 9 && (major2) == 2 && (minor) <= 1)+  (major1) == 9 && (major2) == 2 && (minor) <= 2) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo