ghc-lib-parser 9.4.5.20230430 → 9.4.6.20230808

raw patch · 36 files changed

+665/−414 lines, 36 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• compiler/Bytecodes.h +20/−2
• compiler/GHC/ByteCode/Types.hs +37/−17
• compiler/GHC/Cmm/CLabel.hs +6/−2
• compiler/GHC/Core.hs +49/−23
• compiler/GHC/Core/Coercion.hs +7/−3
• compiler/GHC/Core/Coercion/Axiom.hs +28/−14
• compiler/GHC/Core/DataCon.hs +29/−12
• compiler/GHC/Core/FamInstEnv.hs +12/−11
• compiler/GHC/Core/Lint.hs +8/−52
• compiler/GHC/Core/Opt/Arity.hs +1/−1
• compiler/GHC/Core/Ppr.hs +14/−9
• compiler/GHC/Core/Rules.hs +13/−7
• compiler/GHC/Core/Seq.hs +5/−4
• compiler/GHC/Core/SimpleOpt.hs +1/−1
• compiler/GHC/Core/Tidy.hs +7/−6
• compiler/GHC/Core/Unfold.hs +18/−11
• compiler/GHC/Core/Unfold/Make.hs +48/−38
• compiler/GHC/Core/Utils.hs +3/−4
• compiler/GHC/CoreToIface.hs +5/−4
• compiler/GHC/Iface/Syntax.hs +33/−8
• compiler/GHC/Linker/Types.hs +47/−11
• compiler/GHC/Stg/Syntax.hs +1/−1
• compiler/GHC/StgToCmm/Types.hs +47/−1
• compiler/GHC/Tc/Errors/Ppr.hs +10/−0
• compiler/GHC/Tc/Errors/Types.hs +10/−0
• compiler/GHC/Types/Demand.hs +173/−162
• compiler/GHC/Types/Id.hs +2/−0
• compiler/GHC/Types/Id/Info.hs +2/−1
• compiler/GHC/Utils/Binary.hs +2/−2
• compiler/GHC/Utils/Outputable.hs +9/−0
• ghc-lib-parser.cabal +1/−1
• ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +1/−1
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +3/−0
• libraries/ghci/GHCi/FFI.hsc +8/−0
• libraries/ghci/GHCi/Message.hs +1/−1

@@ -34,7 +34,6 @@ #define bci_PUSH16_W                    9 #define bci_PUSH32_W                    10 #define bci_PUSH_G                      11-#define bci_PUSH_ALTS                   12 #define bci_PUSH_ALTS_P                 13 #define bci_PUSH_ALTS_N                 14 #define bci_PUSH_ALTS_F                 15@@ -81,7 +80,6 @@ #define bci_CCALL                       56 #define bci_SWIZZLE                     57 #define bci_ENTER                       58-#define bci_RETURN                      59 #define bci_RETURN_P                    60 #define bci_RETURN_N                    61 #define bci_RETURN_F                    62@@ -94,6 +92,26 @@  #define bci_RETURN_T                    69 #define bci_PUSH_ALTS_T                 70++#define bci_TESTLT_I64                  71+#define bci_TESTEQ_I64                  72+#define bci_TESTLT_I32                  73+#define bci_TESTEQ_I32                  74+#define bci_TESTLT_I16                  75+#define bci_TESTEQ_I16                  76+#define bci_TESTLT_I8                   77+#define bci_TESTEQ_I8                   78+#define bci_TESTLT_W64                  79+#define bci_TESTEQ_W64                  80+#define bci_TESTLT_W32                  81+#define bci_TESTEQ_W32                  82+#define bci_TESTLT_W16                  83+#define bci_TESTEQ_W16                  84+#define bci_TESTLT_W8                   85+#define bci_TESTEQ_W8                   86++#define bci_PRIMCALL                    87+ /* If you need to go past 255 then you will run into the flags */  /* If you need to go below 0x0100 then you will run into the instructions */

@@ -9,10 +9,11 @@   ( CompiledByteCode(..), seqCompiledByteCode   , FFIInfo(..)   , RegBitmap(..)-  , TupleInfo(..), voidTupleInfo+  , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo   , ByteOff(..), WordOff(..)   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)   , ItblEnv, ItblPtr(..)+  , AddrEnv, AddrPtr(..)   , CgBreakInfo(..)   , ModBreaks (..), BreakIndex, emptyModBreaks   , CCostCentre@@ -50,7 +51,7 @@   { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings   , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls   , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated-  , bc_strs   :: [RemotePtr ()] -- malloc'd strings+  , bc_strs   :: AddrEnv        -- malloc'd top-level strings   , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not                                  -- creating breakpoints, for some reason)   }@@ -68,7 +69,7 @@   rnf bc_bcos `seq`   seqEltsNameEnv rnf bc_itbls `seq`   rnf bc_ffis `seq`-  rnf bc_strs `seq`+  seqEltsNameEnv rnf bc_strs `seq`   rnf (fmap seqModBreaks bc_breaks)  newtype ByteOff = ByteOff Int@@ -102,29 +103,42 @@     See GHC.StgToByteCode.layoutTuple for more details. -}-data TupleInfo = TupleInfo-  { tupleSize            :: !WordOff   -- total size of tuple in words-  , tupleRegs            :: !GlobalRegSet-  , tupleNativeStackSize :: !WordOff {- words spilled on the stack by-                                        GHCs native calling convention -}-  } deriving (Show) -instance Outputable TupleInfo where-  ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>-                      text "stack" <+> ppr tupleNativeStackSize <+>-                      text "regs"  <+>-                      ppr (map (text.show) $ regSetToList tupleRegs) <>-                      char '>'+data NativeCallType = NativePrimCall+                    | NativeTupleReturn+  deriving (Eq) -voidTupleInfo :: TupleInfo-voidTupleInfo = TupleInfo 0 emptyRegSet 0+data NativeCallInfo = NativeCallInfo+  { nativeCallType           :: !NativeCallType+  , nativeCallSize           :: !WordOff   -- total size of arguments in words+  , nativeCallRegs           :: !GlobalRegSet+  , nativeCallStackSpillSize :: !WordOff {- words spilled on the stack by+                                            GHCs native calling convention -}+  } +instance Outputable NativeCallInfo where+  ppr NativeCallInfo{..} = text "<arg_size" <+> ppr nativeCallSize <+>+                           text "stack" <+> ppr nativeCallStackSpillSize <+>+                           text "regs"  <+>+                           ppr (map (text . show) $ regSetToList nativeCallRegs) <>+                           char '>'+++voidTupleReturnInfo :: NativeCallInfo+voidTupleReturnInfo = NativeCallInfo NativeTupleReturn 0 emptyRegSet 0++voidPrimCallInfo :: NativeCallInfo+voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0+ type ItblEnv = NameEnv (Name, ItblPtr)+type AddrEnv = NameEnv (Name, AddrPtr)         -- We need the Name in the range so we know which         -- elements to filter out when unloading a module  newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)   deriving (Show, NFData)+newtype AddrPtr = AddrPtr (RemotePtr ())+  deriving (NFData)  data UnlinkedBCO    = UnlinkedBCO {@@ -155,6 +169,12 @@   = BCONPtrWord  {-# UNPACK #-} !Word   | BCONPtrLbl   !FastString   | BCONPtrItbl  !Name+  -- | A reference to a top-level string literal; see+  -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.+  | BCONPtrAddr  !Name+  -- | Only used internally in the assembler in an intermediate representation;+  -- should never appear in a fully-assembled UnlinkedBCO.+  -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm.   | BCONPtrStr   !ByteString  instance NFData BCONPtr where

@@ -65,6 +65,7 @@         mkSMAP_DIRTY_infoLabel,         mkBadAlignmentLabel,         mkOutOfBoundsAccessLabel,+        mkMemcpyRangeOverlapLabel,         mkArrWords_infoLabel,         mkSRTInfoLabel, @@ -643,7 +644,8 @@     mkCAFBlackHoleInfoTableLabel,     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,-    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel+    mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,+    mkMUT_VAR_CLEAN_infoLabel :: CLabel mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData@@ -661,7 +663,8 @@ 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+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")  Nothing ForeignLabelInExternalPackage IsFunction+mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo  mkSRTInfoLabel :: Int -> CLabel@@ -1356,6 +1359,7 @@                    ordinary Haskell function of arity 1 that                    allocates a (Just x) box:                       Just = \x -> Just x+    Just_entry:    The entry code for the worker function     Just_closure:  The closure for this worker      Nothing_closure: a statically allocated closure for Nothing

@@ -53,7 +53,7 @@         isRuntimeArg, isRuntimeVar,          -- * Unfolding data types-        Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),+        Unfolding(..),  UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..),          -- ** Constructing 'Unfolding's         noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon,@@ -1368,15 +1368,8 @@         uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct         uf_src        :: UnfoldingSource, -- Where the unfolding came from         uf_is_top     :: Bool,          -- True <=> top level binding-        uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard-                                        --      a `seq` on this variable-        uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function-                                        --      Cached version of exprIsConLike-        uf_is_work_free :: Bool,                -- True <=> doesn't waste (much) work to expand-                                        --          inside an inlining-                                        --      Cached version of exprIsCheap-        uf_expandable :: Bool,          -- True <=> can expand in RULE matching-                                        --      Cached version of exprIsExpandable+        uf_cache      :: UnfoldingCache,        -- Cache of flags computable from the expr+                                                -- See Note [Tying the 'CoreUnfolding' knot]         uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.     }   -- ^ An unfolding with redundant cached information. Parameters:@@ -1426,6 +1419,21 @@                        -- Inline absolutely always, however boring the context.  +-- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template.+-- See Note [UnfoldingCache]+data UnfoldingCache+  = UnfoldingCache {+        uf_is_value   :: !Bool,         -- exprIsHNF template (cached); it is ok to discard+                                        --      a `seq` on this variable+        uf_is_conlike :: !Bool,         -- True <=> applicn of constructor or CONLIKE function+                                        --      Cached version of exprIsConLike+        uf_is_work_free :: !Bool,       -- True <=> doesn't waste (much) work to expand+                                        --          inside an inlining+                                        --      Cached version of exprIsCheap+        uf_expandable :: !Bool          -- True <=> can expand in RULE matching+                                        --      Cached version of exprIsExpandable+    }+  deriving (Eq)  -- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance@@ -1456,7 +1464,23 @@   | UnfNever        -- The RHS is big, so don't inline it   deriving (Eq) -{-+{- Note [UnfoldingCache]+~~~~~~~~~~~~~~~~~~~~~~~~+The UnfoldingCache field of an Unfolding holds four (strict) booleans,+all derived from the uf_tmpl field of the unfolding.++* We serialise the UnfoldingCache to and from interface files, for+  reasons described in  Note [Tying the 'CoreUnfolding' knot] in+  GHC.IfaceToCore++* Because it is a strict data type, we must be careful not to+  pattern-match on it until we actually want its values.  E.g+  GHC.Core.Unfold.callSiteInline/tryUnfolding are careful not to force+  it unnecessarily.  Just saves a bit of work.++* When `seq`ing Core to eliminate space leaks, to suffices to `seq` on+  the cache, but not its fields, because it is strict in all fields.+ Note [Historical note: unfoldings for wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to have a nice clever scheme in interface files for@@ -1563,8 +1587,8 @@ -- yield a value (something in HNF): returns @False@ if unsure isValueUnfolding :: Unfolding -> Bool         -- Returns False for OtherCon-isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald-isValueUnfolding _                                          = False+isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache+isValueUnfolding _                                    = False  -- | Determines if it possibly the case that the unfolding will -- yield a value. Unlike 'isValueUnfolding' it returns @True@@@ -1572,31 +1596,33 @@ isEvaldUnfolding :: Unfolding -> Bool         -- Returns True for OtherCon isEvaldUnfolding (OtherCon _)                               = True-isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald+isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache isEvaldUnfolding _                                          = False  -- | @True@ if the unfolding is a constructor application, the application -- of a CONLIKE function or 'OtherCon' isConLikeUnfolding :: Unfolding -> Bool-isConLikeUnfolding (OtherCon _)                             = True-isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con })  = con-isConLikeUnfolding _                                        = False+isConLikeUnfolding (OtherCon _)                         = True+isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache+isConLikeUnfolding _                                    = False  -- | Is the thing we will unfold into certainly cheap? isCheapUnfolding :: Unfolding -> Bool-isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf-isCheapUnfolding _                                           = False+isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache+isCheapUnfolding _                                    = False  isExpandableUnfolding :: Unfolding -> Bool-isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable-isExpandableUnfolding _                                              = False+isExpandableUnfolding (CoreUnfolding { uf_cache = cache }) = uf_expandable cache+isExpandableUnfolding _                                    = False  expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr -- Expand an expandable unfolding; this is used in rule matching --   See Note [Expanding variables] in GHC.Core.Rules -- The key point here is that CONLIKE things can be expanded-expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs-expandUnfolding_maybe _                                                       = Nothing+expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs })+  | uf_expandable cache+    = Just rhs+expandUnfolding_maybe _ = Nothing  isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True

@@ -216,8 +216,8 @@ pprCoAxiom :: CoAxiom br -> SDoc -- Used in debug-printing only pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })-  = hang (text "axiom" <+> ppr ax <+> dcolon)-       2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))+  = hang (text "axiom" <+> ppr ax)+       2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))  pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc -- Used when printing injectivity errors (FamInst.reportInjectivityErrors)@@ -251,8 +251,12 @@     [ pprUserForAll (mkTyCoVarBinders Inferred bndrs')          -- See Note [Printing foralls in type family instances] in GHC.Iface.Type     , pp_lhs <+> ppr_rhs tidy_env ee_rhs-    , text "-- Defined" <+> pp_loc ]+    , vcat [ text "-- Defined" <+> pp_loc+           , ppUnless (null incomps) $ whenPprDebug $+             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ]+    ]   where+    incomps = coAxBranchIncomps branch     loc = coAxBranchSpan branch     pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)            | otherwise         = text "in" <+> ppr loc

@@ -36,7 +36,7 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )-import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar ) import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon ) import GHC.Utils.Outputable import GHC.Data.FastString@@ -275,7 +275,6 @@   = length tvs + length cvs   where     CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index- coAxiomName :: CoAxiom br -> Name coAxiomName = co_ax_name @@ -331,7 +330,7 @@ Note [CoAxBranch type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the case of a CoAxBranch of an associated type-family instance,-we use the *same* type variables (where possible) as the+we use the *same* type variables in cab_tvs (where possible) as the enclosing class or instance.  Consider    instance C Int [z] where@@ -341,8 +340,11 @@ same 'z', so that it's easy to check that that type is the same as that in the instance header. -So, unlike FamInsts, there is no expectation that the cab_tvs-are fresh wrt each other, or any other CoAxBranch.+However, I believe that the cab_tvs of any CoAxBranch are distinct+from the cab_tvs of other CoAxBranches in the same CoAxiom.  This is+important when checking for compatiblity and apartness; e.g. see+GHC.Core.FamInstEnv.compatibleBranches.  (The story seems a bit wobbly+here, but it seems to work.)  Note [CoAxBranch roles] ~~~~~~~~~~~~~~~~~~~~~~~@@ -458,6 +460,12 @@ * Note [RoughMap and rm_empty] for how this complicates the RoughMap implementation slightly. -} +{- *********************************************************************+*                                                                      *+              Instances, especially pretty-printing+*                                                                      *+********************************************************************* -}+ instance Eq (CoAxiom br) where     a == b = getUnique a == getUnique b     a /= b = getUnique a /= getUnique b@@ -465,9 +473,6 @@ instance Uniquable (CoAxiom br) where     getUnique = co_ax_unique -instance Outputable (CoAxiom br) where-    ppr = ppr . getName- instance NamedThing (CoAxiom br) where     getName = co_ax_name @@ -477,13 +482,22 @@     gunfold _ _  = error "gunfold"     dataTypeOf _ = mkNoRepType "CoAxiom" +instance Outputable (CoAxiom br) where+  -- You may want GHC.Core.Coercion.pprCoAxiom instead+  ppr = ppr . getName+ instance Outputable CoAxBranch where-  ppr (CoAxBranch { cab_loc = loc-                  , cab_lhs = lhs-                  , cab_rhs = rhs }) =-    text "CoAxBranch" <+> parens (ppr loc) <> colon-      <+> brackets (fsep (punctuate comma (map pprType lhs)))-      <+> text "=>" <+> pprType rhs+  -- This instance doesn't know the name of the type family+  -- If possible, use GHC.Core.Coercion.pprCoAxBranch instead+  ppr (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                  , cab_lhs = lhs_tys, cab_rhs = rhs, cab_incomps = incomps })+    = text "CoAxBranch" <+> braces payload+    where+      payload = hang (text "forall" <+> pprWithCommas pprTyVar (tvs ++ cvs) <> dot)+                   2 (vcat [ text "<tycon>" <+> sep (map pprType lhs_tys)+                           , nest 2 (text "=" <+> ppr rhs)+                           , ppUnless (null incomps) $+                             text "incomps:" <+> vcat (map ppr incomps) ])  {- ************************************************************************

@@ -106,8 +106,8 @@ import Data.List( find )  {--Data constructor representation-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Data constructor representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration          data T = T !Int ![Int]@@ -208,7 +208,7 @@  * The wrapper (if it exists) takes dcOrigArgTys as its arguments.   The worker takes dataConRepArgTys as its arguments-  If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys+  If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys  * The 'NoDataConRep' case of DataConRep is important. Not only is it   efficient, but it also ensures that the wrapper is replaced by the@@ -554,12 +554,22 @@  Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~-dcSourceArity does not take constraints into account,-but dcRepArity does.  For example:+A `DataCon`'s source arity and core representation arity may differ:+`dcSourceArity` does not take constraints into account, but `dcRepArity` does.++The additional arguments taken into account by `dcRepArity` include quantified+dictionaries and coercion arguments, lifted and unlifted (despite the unlifted+coercion arguments having a zero-width runtime representation).+For example:    MkT :: Ord a => a -> T a     dcSourceArity = 1     dcRepArity    = 2 +   MkU :: (b ~ '[]) => U b+    dcSourceArity = 0+    dcRepArity    = 1++ Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In System FC, data constructor type signatures always quantify over all of@@ -885,8 +895,8 @@         Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! -Not that this representation is still *different* from runtime-representation. (Which is what STG uses afer unarise).+Note that this representation is still *different* from runtime+representation. (Which is what STG uses after unarise).  This is how T would end up being used in STG post-unarise: @@ -1322,9 +1332,10 @@ dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity --- | Gives the number of actual fields in the /representation/ of the--- data constructor. This may be more than appear in the source code;--- the extra ones are the existentially quantified dictionaries+-- | Gives the number of value arguments (including zero-width coercions)+-- stored by the given `DataCon`'s worker in its Core representation. This may+-- differ from the number of arguments that appear in the source code; see also+-- Note [DataCon arities] dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity @@ -1333,8 +1344,14 @@ isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = dataConSourceArity dc == 0 --- | Return whether there are any argument types for this 'DataCon's runtime representation type--- See Note [DataCon arities]+-- | Return whether this `DataCon`'s worker, in its Core representation, takes+-- any value arguments.+--+-- In particular, remember that we include coercion arguments in the arity of+-- the Core representation of the `DataCon` -- both lifted and unlifted+-- coercions, despite the latter having zero-width runtime representation.+--+-- See also Note [DataCon arities]. isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 

@@ -25,7 +25,7 @@         FamInstMatch(..),         lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, -        isDominatedBy, apartnessCheck,+        isDominatedBy, apartnessCheck, compatibleBranches,          -- Injectivity         InjectivityCheckResult(..),@@ -531,15 +531,16 @@ compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })                    (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })-  = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2-             -- See Note [Compatibility of eta-reduced axioms]-    in case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of-      SurelyApart -> True-      Unifiable subst-        | Type.substTyAddInScope subst rhs1 `eqType`-          Type.substTyAddInScope subst rhs2-        -> True-      _ -> False+  = case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of+      -- Here we need the cab_tvs of the two branches to be disinct.+      -- See Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom.+      SurelyApart     -> True+      MaybeApart {}   -> False+      Unifiable subst -> Type.substTyAddInScope subst rhs1 `eqType`+                         Type.substTyAddInScope subst rhs2+  where+     (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2+     -- See Note [Compatibility of eta-reduced axioms]  -- | Result of testing two type family equations for injectiviy. data InjectivityCheckResult@@ -590,7 +591,7 @@   where     go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)     go prev_brs cur_br-       = (cur_br : prev_brs, new_br)+       = (new_br : prev_brs, new_br)        where          new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } 

@@ -51,7 +51,7 @@ import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom-import GHC.Core.Unify+import GHC.Core.FamInstEnv( compatibleBranches ) import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity    ( typeArity )@@ -2548,8 +2548,10 @@        ; lintL (null cvs)                (text "Coercion variables bound in family axiom")        ; forM_ incomps $ \ br' ->-           lintL (not (compatible_branches br br')) $-           text "Incorrect incompatible branch:" <+> ppr br' }+           lintL (not (compatibleBranches br br')) $+           hang (text "Incorrect incompatible branches:")+              2 (vcat [text "Branch:"       <+> ppr br,+                       text "Bogus incomp:" <+> ppr br']) }  lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () lint_axiom_group (_  :| []) = return ()@@ -2571,7 +2573,7 @@   , Just br2@(CoAxBranch { cab_tvs = tvs2                          , cab_lhs = lhs2                          , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2-  = lintL (compatible_branches br1 br2) $+  = lintL (compatibleBranches br1 br2) $     vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2                 , text "are incompatible" ]          , text "tvs1 =" <+> pprTyVars tvs1@@ -2585,27 +2587,6 @@   = addErrL (text "Open type family axiom has more than one branch: either" <+>              ppr ax1 <+> text "or" <+> ppr ax2) -compatible_branches :: CoAxBranch -> CoAxBranch -> Bool--- True <=> branches are compatible. See Note [Compatibility] in GHC.Core.FamInstEnv.-compatible_branches (CoAxBranch { cab_tvs = tvs1-                                , cab_lhs = lhs1-                                , cab_rhs = rhs1 })-                    (CoAxBranch { cab_tvs = tvs2-                                , cab_lhs = lhs2-                                , cab_rhs = rhs2 })-  = -- we need to freshen ax2 w.r.t. ax1-    -- do this by pretending tvs1 are in scope when processing tvs2-    let in_scope       = mkInScopeSet (mkVarSet tvs1)-        subst0         = mkEmptyTCvSubst in_scope-        (subst, _)     = substTyVarBndrs subst0 tvs2-        lhs2'          = substTys subst lhs2-        rhs2'          = substTy  subst rhs2-    in-    case tcUnifyTys alwaysBindFun lhs1 lhs2' of-      Just unifying_subst -> substTy unifying_subst rhs1  `eqType`-                             substTy unifying_subst rhs2'-      Nothing             -> True- {- ************************************************************************ *                                                                      *@@ -3128,33 +3109,8 @@ dumpLoc (InCo co)   = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) dumpLoc (InAxiom ax)-  = (getSrcLoc ax_name, text "In the coercion axiom" <+> ppr ax_name <+> dcolon <+> pp_ax)-  where-    CoAxiom { co_ax_name     = ax_name-            , co_ax_tc       = tc-            , co_ax_role     = ax_role-            , co_ax_branches = branches } = ax-    branch_list = fromBranches branches--    pp_ax-      | [branch] <- branch_list-      = pp_branch branch--      | otherwise-      = braces $ vcat (map pp_branch branch_list)--    pp_branch (CoAxBranch { cab_tvs = tvs-                          , cab_cvs = cvs-                          , cab_lhs = lhs_tys-                          , cab_rhs = rhs_ty })-      = sep [ brackets (pprWithCommas pprTyVar (tvs ++ cvs)) <> dot-            , ppr (mkTyConApp tc lhs_tys)-            , text "~_" <> pp_role ax_role-            , ppr rhs_ty ]--    pp_role Nominal          = text "N"-    pp_role Representational = text "R"-    pp_role Phantom          = text "P"+  = (getSrcLoc ax, hang (text "In the coercion axiom")+                      2 (pprCoAxiom ax))  pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs))

@@ -1333,7 +1333,7 @@ idArityType :: Id -> ArityType idArityType v   | strict_sig <- idDmdSig v-  , not $ isTopSig strict_sig+  , not $ isNopSig strict_sig   , (ds, div) <- splitDmdSig strict_sig   , let arity = length ds   -- Every strictness signature admits an arity signature!

@@ -529,7 +529,7 @@       has_caf_info = not (mayHaveCafRefs caf_info)        str_info = dmdSigInfo info-      has_str_info = not (isTopSig str_info)+      has_str_info = not (isNopSig str_info)        unf_info = realUnfoldingInfo info       has_unf = hasSomeUnfolding unf_info@@ -573,7 +573,7 @@     has_caf_info = not (mayHaveCafRefs caf_info)      str_info = dmdSigInfo info-    has_str_info = not (isTopSig str_info)+    has_str_info = not (isNopSig str_info)      cpr_info = cprSigInfo info     has_cpr_info = cpr_info /= topCprSig@@ -623,18 +623,14 @@                 <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)             2 (ppr con <+> sep (map ppr args))   ppr (CoreUnfolding { uf_src = src-                     , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf-                     , uf_is_conlike=conlike, uf_is_work_free=wf-                     , uf_expandable=exp, uf_guidance=g })+                     , uf_tmpl=rhs, uf_is_top=top+                     , uf_cache=cache, uf_guidance=g })         = text "Unf" <> braces (pp_info $$ pp_rhs)     where       pp_info = fsep $ punctuate comma                 [ text "Src="        <> ppr src                 , text "TopLvl="     <> ppr top-                , text "Value="      <> ppr hnf-                , text "ConLike="    <> ppr conlike-                , text "WorkFree="   <> ppr wf-                , text "Expandable=" <> ppr exp+                , ppr cache                 , text "Guidance="   <> ppr g ]       pp_tmpl = ppUnlessOption sdocSuppressUnfoldings                   (text "Tmpl=" <+> ppr rhs)@@ -642,6 +638,15 @@              | otherwise          = empty             -- Don't print the RHS or we get a quadratic             -- blowup in the size of the printout!++instance Outputable UnfoldingCache where+    ppr (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike+                        , uf_is_work_free = wf, uf_expandable = exp })+        = fsep $ punctuate comma+          [ text "Value="      <> ppr hnf+          , text "ConLike="    <> ppr conlike+          , text "WorkFree="   <> ppr wf+          , text "Expandable=" <> ppr exp ]  {- -----------------------------------------------------

@@ -50,6 +50,7 @@ import GHC.Core.Coercion as Coercion import GHC.Core.Tidy     ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr )+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )  import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types    ( anyTypeOfKind )@@ -190,13 +191,18 @@ -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'GHC.Core.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs-  = Rule { ru_name = name, ru_fn = fn, ru_act = act,-           ru_bndrs = bndrs, ru_args = args,-           ru_rhs = rhs,-           ru_rough = roughTopNames args,-           ru_origin = this_mod,-           ru_orphan = orph,-           ru_auto = is_auto, ru_local = is_local }+  = Rule { ru_name   = name+         , ru_act    = act+         , ru_fn     = fn+         , ru_bndrs  = bndrs+         , ru_args   = args+         , ru_rhs    = occurAnalyseExpr rhs+                       -- See Note [OccInfo in unfoldings and rules]+         , ru_rough  = roughTopNames args+         , ru_origin = this_mod+         , ru_orphan = orph+         , ru_auto   = is_auto+         , ru_local  = is_local }   where         -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv         -- A rule is an orphan only if none of the variables

@@ -104,10 +104,11 @@  seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,-                uf_is_value = b1, uf_is_work_free = b2,-                uf_expandable = b3, uf_is_conlike = b4,-                uf_guidance = g})-  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g+                uf_cache = cache, uf_guidance = g})+  = seqExpr e `seq` top `seq` cache `seq` seqGuidance g+    -- The unf_cache :: UnfoldingCache field is a strict data type,+    -- so it is sufficient to use plain `seq` for this field+    -- See Note [UnfoldingCache] in GHC.Core  seqUnfolding _ = () 

@@ -693,7 +693,7 @@    unfolding_from_rhs = mkUnfolding uf_opts InlineRhs                                     (isTopLevel top_level)                                     False -- may be bottom or not-                                    new_rhs+                                    new_rhs Nothing  simpleUnfoldingFun :: IdUnfoldingFun simpleUnfoldingFun id

@@ -84,7 +84,7 @@ -- This means the code generator can get the full calling convention by only looking at the function -- itself without having to inspect the RHS. ----- The actual logic is in tidyCbvInfo and takes:+-- The actual logic is in computeCbvInfo and takes: -- * The function id -- * The functions rhs -- And gives us back the function annotated with the marks.@@ -362,15 +362,16 @@     (tidy_env', bndrs') = tidyBndrs tidy_env bndrs  tidyNestedUnfolding tidy_env-    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_is_value = is_value })+    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_cache = cache })   | isStableSource src   = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs }    -- Preserves OccInfo-            -- This seqIt avoids a space leak: otherwise the uf_is_value,-            -- uf_is_conlike, ... fields may retain a reference to the-            -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)+            -- This seqIt avoids a space leak: otherwise the uf_cache+            -- field may retain a reference to the pre-tidied+            -- expression forever (GHC.CoreToIface doesn't look at+            -- them)    -- Discard unstable unfoldings, but see Note [Preserve evaluatedness]-  | is_value = evaldUnfolding+  | uf_is_value cache = evaldUnfolding   | otherwise = noUnfolding    where

@@ -1035,11 +1035,11 @@       -- Things with an INLINE pragma may have an unfolding *and*       -- be a loop breaker  (maybe the knot is not yet untied)         CoreUnfolding { uf_tmpl = unf_template-                      , uf_is_work_free = is_wf-                      , uf_guidance = guidance, uf_expandable = is_exp }+                      , uf_cache = unf_cache+                      , uf_guidance = guidance }           | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable                                     arg_infos cont_info unf_template-                                    is_wf is_exp guidance+                                    unf_cache guidance           | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing         NoUnfolding      -> Nothing         BootUnfolding    -> Nothing@@ -1161,11 +1161,10 @@ -}  tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt-             -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance+             -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance              -> Maybe CoreExpr-tryUnfolding logger opts !case_depth id lone_variable-             arg_infos cont_info unf_template-             is_wf is_exp guidance+tryUnfolding logger opts !case_depth id lone_variable arg_infos+             cont_info unf_template unf_cache guidance  = case guidance of      UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing @@ -1177,7 +1176,7 @@         -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing         where           some_benefit = calc_some_benefit uf_arity-          enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)+          enough_args  = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)       UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }         | unfoldingVeryAggressive opts@@ -1188,9 +1187,6 @@         -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing         where           some_benefit = calc_some_benefit (length arg_discounts)-          extra_doc = vcat [ text "case depth =" <+> int case_depth-                           , text "depth based penalty =" <+> int depth_penalty-                           , text "discounted size =" <+> int adjusted_size ]           -- See Note [Avoid inlining into deeply nested cases]           depth_treshold = unfoldingCaseThreshold opts           depth_scaling = unfoldingCaseScaling opts@@ -1200,7 +1196,18 @@           small_enough = adjusted_size <= unfoldingUseThreshold opts           discount = computeDiscount arg_discounts res_discount arg_infos cont_info +          extra_doc = vcat [ text "case depth =" <+> int case_depth+                           , text "depth based penalty =" <+> int depth_penalty+                           , text "discounted size =" <+> int adjusted_size ]+   where+    -- Unpack the UnfoldingCache lazily because it may not be needed, and all+    -- its fields are strict; so evaluating unf_cache at all forces all the+    -- isWorkFree etc computations to take place.  That risks wasting effort for+    -- Ids that are never going to inline anyway.+    -- See Note [UnfoldingCache] in GHC.Core+    UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache+     mk_doc some_benefit extra_doc yes_or_no       = vcat [ text "arg infos" <+> ppr arg_infos              , text "interesting continuation" <+> ppr cont_info

@@ -6,6 +6,7 @@    , mkUnfolding    , mkCoreUnfolding    , mkFinalUnfolding+   , mkFinalUnfolding'    , mkSimpleUnfolding    , mkWorkerUnfolding    , mkInlineUnfolding@@ -36,15 +37,24 @@ import GHC.Utils.Misc import GHC.Utils.Panic +import Data.Maybe ( fromMaybe )+ -- the very simple optimiser is used to optimise unfoldings import {-# SOURCE #-} GHC.Core.SimpleOpt   -mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding+mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding -- "Final" in the sense that this is a GlobalId that will not be further -- simplified; so the unfolding should be occurrence-analysed-mkFinalUnfolding opts src strict_sig expr+mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr++-- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need+-- to pass a precomputed 'UnfoldingCache'+mkFinalUnfolding' :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding+-- "Final" in the sense that this is a GlobalId that will not be further+-- simplified; so the unfolding should be occurrence-analysed+mkFinalUnfolding' opts src strict_sig expr   = mkUnfolding opts src                 True {- Top level -}                 (isDeadEndSig strict_sig)@@ -59,7 +69,7 @@ mkCompulsoryUnfolding' :: CoreExpr -> Unfolding mkCompulsoryUnfolding' expr   = mkCoreUnfolding InlineCompulsory True-                    expr+                    expr Nothing                     (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter                              , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) @@ -71,7 +81,7 @@  mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs-  = mkUnfolding opts InlineRhs False False rhs+  = mkUnfolding opts InlineRhs False False rhs Nothing  mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops@@ -85,7 +95,7 @@ -- after demand/CPR analysis mkWrapperUnfolding opts expr arity   = mkCoreUnfolding InlineStable True-                    (simpleOptExpr opts expr)+                    (simpleOptExpr opts expr) Nothing                     (UnfWhen { ug_arity     = arity                              , ug_unsat_ok  = unSaturatedOk                              , ug_boring_ok = boringCxtNotOk })@@ -96,7 +106,7 @@                   (CoreUnfolding { uf_src = src, uf_tmpl = tmpl                                  , uf_is_top = top_lvl })   | isStableSource src-  = mkCoreUnfolding src top_lvl new_tmpl guidance+  = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance   where     new_tmpl = simpleOptExpr opts (work_fn tmpl)     guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl@@ -111,7 +121,7 @@ mkInlineUnfolding opts expr   = mkCoreUnfolding InlineStable                     True         -- Note [Top-level flag on inline rules]-                    expr' guide+                    expr' Nothing guide   where     expr' = simpleOptExpr opts expr     guide = UnfWhen { ug_arity = manifestArity expr'@@ -125,7 +135,7 @@ mkInlineUnfoldingWithArity arity opts expr   = mkCoreUnfolding InlineStable                     True         -- Note [Top-level flag on inline rules]-                    expr' guide+                    expr' Nothing guide   where     expr' = simpleOptExpr opts expr     guide = UnfWhen { ug_arity = arity@@ -138,7 +148,7 @@  mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding mkInlinableUnfolding opts expr-  = mkUnfolding (so_uf_opts opts) InlineStable False False expr'+  = mkUnfolding (so_uf_opts opts) InlineStable False False expr' Nothing   where     expr' = simpleOptExpr opts expr @@ -172,7 +182,7 @@                              , uf_guidance = old_guidance })  | isStableSource src  -- See Note [Specialising unfoldings]  , UnfWhen { ug_arity = old_arity } <- old_guidance- = mkCoreUnfolding src top_lvl new_tmpl+ = mkCoreUnfolding src top_lvl new_tmpl Nothing                    (old_guidance { ug_arity = old_arity - arity_decrease })  where    new_tmpl = simpleOptExpr opts $@@ -286,11 +296,12 @@             -> Bool       -- Definitely a bottoming binding                           -- (only relevant for top-level bindings)             -> CoreExpr+            -> Maybe UnfoldingCache             -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it-mkUnfolding opts src top_lvl is_bottoming expr-  = mkCoreUnfolding src top_lvl expr guidance+mkUnfolding opts src top_lvl is_bottoming expr cache+  = mkCoreUnfolding src top_lvl expr cache guidance   where     is_top_bottoming = top_lvl && is_bottoming     guidance         = calcUnfoldingGuidance opts is_top_bottoming expr@@ -298,33 +309,33 @@         -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]  mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr-                -> UnfoldingGuidance -> Unfolding--- Occurrence-analyses the expression before capturing it-mkCoreUnfolding src top_lvl expr guidance-  =+                -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding+mkCoreUnfolding src top_lvl expr precomputed_cache guidance+  = CoreUnfolding { uf_tmpl = cache `seq`+                              occurAnalyseExpr expr+      -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]+      -- See #20905 for what a discussion of this 'seq'.+      -- We are careful to make sure we only+      -- have one copy of an unfolding around at once.+      -- Note [Thoughtful forcing in mkCoreUnfolding] -  let is_value = exprIsHNF expr-      is_conlike = exprIsConLike expr-      is_work_free = exprIsWorkFree expr-      is_expandable = exprIsExpandable expr-  in-  -- See #20905 for what is going on here. We are careful to make sure we only-  -- have one copy of an unfolding around at once.-  -- Note [Thoughtful forcing in mkCoreUnfolding]-  CoreUnfolding { uf_tmpl         = is_value `seq`-                                    is_conlike `seq`-                                    is_work_free `seq`-                                    is_expandable `seq`-                                      occurAnalyseExpr expr,-                      -- See Note [Occurrence analysis of unfoldings]-                    uf_src          = src,-                    uf_is_top       = top_lvl,-                    uf_is_value     = is_value,-                    uf_is_conlike   = is_conlike,-                    uf_is_work_free = is_work_free,-                    uf_expandable   = is_expandable,-                    uf_guidance     = guidance }+                  , uf_src          = src+                  , uf_is_top       = top_lvl+                  , uf_cache        = cache+                  , uf_guidance     = guidance }+  where+    is_value      = exprIsHNF expr+    is_conlike    = exprIsConLike expr+    is_work_free  = exprIsWorkFree expr+    is_expandable = exprIsExpandable expr +    recomputed_cache = UnfoldingCache { uf_is_value = is_value+                                      , uf_is_conlike = is_conlike+                                      , uf_is_work_free = is_work_free+                                      , uf_expandable = is_expandable }++    cache = fromMaybe recomputed_cache precomputed_cache+ ---------------- certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding -- ^ Sees if the unfolding is pretty certain to inline.@@ -454,4 +465,3 @@ The result of fixing this led to a 1G reduction in peak memory usage (12G -> 11G) when compiling a very large module (peak 3 million terms). For more discussion see #20905. -}-

@@ -2308,10 +2308,9 @@   | c1 == c2 && equalLength bs1 bs2   = concatMap (uncurry (diffExpr False env')) (zip a1 a2)   where env' = rnBndrs2 env bs1 bs2-diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)-               (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)-  | v1 == v2 && cl1 == cl2-    && wf1 == wf2 && x1 == x2 && g1 == g2+diffUnfold env (CoreUnfolding t1 _ _ c1 g1)+               (CoreUnfolding t2 _ _ c2 g2)+  | c1 == c2 && g1 == g2   = diffExpr False env t1 t2 diffUnfold _   uf1 uf2   = [fsep [ppr uf1, text "/=", ppr uf2]]

@@ -81,7 +81,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Tickish-import GHC.Types.Demand ( isTopSig )+import GHC.Types.Demand ( isNopSig ) import GHC.Types.Cpr ( topCprSig )  import GHC.Utils.Outputable@@ -482,7 +482,7 @@     ------------  Strictness  --------------         -- No point in explicitly exporting TopSig     sig_info = dmdSigInfo id_info-    strict_hsinfo | not (isTopSig sig_info) = Just (HsDmdSig sig_info)+    strict_hsinfo | not (isNopSig sig_info) = Just (HsDmdSig sig_info)                   | otherwise               = Nothing      ------------  CPR --------------@@ -510,6 +510,7 @@ toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs                                 , uf_src = src+                                , uf_cache = cache                                 , uf_guidance = guidance })   = Just $ HsUnfold lb $     case src of@@ -517,9 +518,9 @@           -> case guidance of                UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok =  boring_ok }                       -> IfInlineRule arity unsat_ok boring_ok if_rhs-               _other -> IfCoreUnfold True if_rhs+               _other -> IfCoreUnfold True cache if_rhs         InlineCompulsory -> IfCompulsory if_rhs-        InlineRhs        -> IfCoreUnfold False if_rhs+        InlineRhs        -> IfCoreUnfold False cache if_rhs         -- Yes, even if guidance is UnfNever, expose the unfolding         -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would         -- have stuck in NoUnfolding.  For supercompilation we want

@@ -47,7 +47,7 @@ import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary-import GHC.Core( IsOrphan, isOrphan )+import GHC.Core( IsOrphan, isOrphan, UnfoldingCache(..) ) import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core.Class@@ -359,7 +359,7 @@ -- only later attached to the Id.  Partial reason: some are orphans.  data IfaceUnfolding-  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding+  = IfCoreUnfold Bool IfUnfoldingCache IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding                                 -- Possibly could eliminate the Bool here, the information                                 -- is also in the InlinePragma. @@ -374,7 +374,9 @@    | IfDFunUnfold [IfaceBndr] [IfaceExpr] +type IfUnfoldingCache = UnfoldingCache + -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection.  Notably, none of the -- implicit ones are needed here, because they are not put in@@ -1488,7 +1490,7 @@  instance Outputable IfaceUnfolding where   ppr (IfCompulsory e)     = text "<compulsory>" <+> parens (ppr e)-  ppr (IfCoreUnfold s e)   = (if s+  ppr (IfCoreUnfold s _ e)   = (if s                                 then text "<stable>"                                 else Outputable.empty)                               <+> parens (ppr e)@@ -1741,7 +1743,7 @@ freeNamesItem _                      = emptyNameSet  freeNamesIfUnfold :: IfaceUnfolding -> NameSet-freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e+freeNamesIfUnfold (IfCoreUnfold _ _ e)     = freeNamesIfExpr e freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfDFunUnfold bs es)   = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es@@ -2265,9 +2267,10 @@             _ -> HsTagSig <$> get bh  instance Binary IfaceUnfolding where-    put_ bh (IfCoreUnfold s e) = do+    put_ bh (IfCoreUnfold s c e) = do         putByte bh 0         put_ bh s+        putUnfoldingCache bh c         put_ bh e     put_ bh (IfInlineRule a b c d) = do         putByte bh 1@@ -2286,8 +2289,9 @@         h <- getByte bh         case h of             0 -> do s <- get bh+                    c <- getUnfoldingCache bh                     e <- get bh-                    return (IfCoreUnfold s e)+                    return (IfCoreUnfold s c e)             1 -> do a <- get bh                     b <- get bh                     c <- get bh@@ -2299,6 +2303,26 @@             _ -> do e <- get bh                     return (IfCompulsory e) +putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO ()+putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike+                                     , uf_is_work_free = wf, uf_expandable = exp }) = do+    let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp+    putByte bh b++getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache+getUnfoldingCache bh = do+    b <- getByte bh+    let hnf     = testBit b 3+        conlike = testBit b 2+        wf      = testBit b 1+        exp     = testBit b 0+    return (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike+                           , uf_is_work_free = wf, uf_expandable = exp })++infixl 9 .<<|.+(.<<|.) :: (Bits a) => a -> Bool -> a+x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)+ instance Binary IfaceAlt where     put_ bh (IfaceAlt a b c) = do         put_ bh a@@ -2614,8 +2638,9 @@  instance NFData IfaceUnfolding where   rnf = \case-    IfCoreUnfold inlinable expr ->-      rnf inlinable `seq` rnf expr+    IfCoreUnfold inlinable cache expr ->+      rnf inlinable `seq` cache `seq` rnf expr+    -- See Note [UnfoldingCache] in GHC.Core for why it suffices to merely `seq` on cache     IfCompulsory expr ->       rnf expr     IfInlineRule arity b1 b2 e ->

@@ -10,6 +10,12 @@    ( Loader (..)    , LoaderState (..)    , uninitializedLoader+   , modifyClosureEnv+   , LinkerEnv(..)+   , filterLinkerEnv+   , ClosureEnv+   , emptyClosureEnv+   , extendClosureEnv    , Linkable(..)    , LinkableSet    , mkLinkableSet@@ -32,12 +38,12 @@  import GHC.Prelude import GHC.Unit                ( UnitId, Module )-import GHC.ByteCode.Types      ( ItblEnv, CompiledByteCode )+import GHC.ByteCode.Types      ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type    ( Fingerprint ) import GHCi.RemoteTypes        ( ForeignHValue )  import GHC.Types.Var           ( Id )-import GHC.Types.Name.Env      ( NameEnv )+import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) import GHC.Types.Name          ( Name )  import GHC.Utils.Outputable@@ -66,23 +72,16 @@ library. The Maybe may be Nothing to indicate that the linker has not yet been initialised. -The LoaderState maps Names to actual closures (for interpreted code only), for+The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking. -}  newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }  data LoaderState = LoaderState-    { closure_env :: ClosureEnv+    { linker_env :: !LinkerEnv         -- ^ Current global mapping from Names to their true values -    , itbl_env    :: !ItblEnv-        -- ^ The current global mapping from RdrNames of DataCons to-        -- info table addresses.-        -- When a new Unlinked is linked into the running image, or an existing-        -- module in the image is replaced, the itbl_env must be updated-        -- appropriately.-     , bcos_loaded :: !LinkableSet         -- ^ The currently loaded interpreted modules (home package) @@ -101,7 +100,44 @@ uninitializedLoader :: IO Loader uninitializedLoader = Loader <$> newMVar Nothing +modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState+modifyClosureEnv pls f =+    let le = linker_env pls+        ce = closure_env le+    in pls { linker_env = le { closure_env = f ce } }++data LinkerEnv = LinkerEnv+  { closure_env :: !ClosureEnv+      -- ^ Current global mapping from closure Names to their true values++  , itbl_env    :: !ItblEnv+      -- ^ The current global mapping from RdrNames of DataCons to+      -- info table addresses.+      -- When a new Unlinked is linked into the running image, or an existing+      -- module in the image is replaced, the itbl_env must be updated+      -- appropriately.++  , addr_env    :: !AddrEnv+      -- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,+      -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.+  }++filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv+filterLinkerEnv f le = LinkerEnv+  { closure_env = filterNameEnv (f . fst) (closure_env le)+  , itbl_env    = filterNameEnv (f . fst) (itbl_env le)+  , addr_env    = filterNameEnv (f . fst) (addr_env le)+  }+ type ClosureEnv = NameEnv (Name, ForeignHValue)++emptyClosureEnv :: ClosureEnv+emptyClosureEnv = emptyNameEnv++extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv+extendClosureEnv cl_env pairs+  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]+ type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo  data LoadedPkgInfo

@@ -236,7 +236,7 @@         -- which can't be let-bound   | StgConApp   DataCon                 ConstructorNumber-                [StgArg] -- Saturated+                [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg])                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise    | StgOpApp    StgOp    -- Primitive op or foreign call

@@ -70,6 +70,52 @@ * We don't absolutely guarantee to serialise the CgInfo: we won't if you have   -fomit-interface-pragmas or -fno-code; and we won't read it in if you have   -fignore-interface-pragmas.  (We could revisit this decision.)++Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in `Note [Conveying CAF-info and LFInfo between modules]`,+imported unlifted nullary datacons must have their LambdaFormInfo set to+reflect the fact that they are evaluated . This is necessary as otherwise+references to them may be passed untagged to code that expects tagged+references.++What may be less obvious is that this must be done for not only datacon+workers but also *wrappers*. The reason is found in this program+from #23146:++    module B where++    type NP :: [UnliftedType] -> UnliftedType+    data NP xs where+      UNil :: NP '[]+++    module A where+    import B++    fieldsSam :: NP xs -> NP xs -> Bool+    fieldsSam UNil UNil = True++    x = fieldsSam UNil UNil++Due to its GADT nature, `B.UNil` produces a trivial wrapper++    $WUNil :: NP '[]+    $WUNil = UNil @'[] @~(<co:1>)++which is referenced in the RHS of `A.x`. If we fail to give `$WUNil` the+correct `LFCon 0` `LambdaFormInfo` then we will end up passing an untagged+pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage+of the unlifted nature of its arguments by omitting handling of the zero+tag when scrutinising them.++The fix is straightforward: extend the logic in `mkLFImported` to cover+(nullary) datacon wrappers as well as workers. This is safe because we+know that the wrapper of a nullary datacon will be in WHNF, even if it+includes equalities evidence (since such equalities are not runtime+relevant). This fixed #23146.++See also Note [The LFInfo of Imported Ids] -}  -- | Codegen-generated Id infos, to be passed to downstream via interfaces.@@ -118,7 +164,7 @@         !StandardFormInfo         !Bool           -- True <=> *might* be a function type -  | LFCon               -- A saturated constructor application+  | LFCon               -- A saturated data constructor application         !DataCon        -- The constructor    | LFUnknown           -- Used for function arguments and imported things.

@@ -799,6 +799,11 @@     TcRnInvalidCIdentifier target       -> mkSimpleDecorated $            sep [quotes (ppr target) <+> text "is not a valid C identifier"]+    TcRnCannotDefaultConcrete frr+      -> mkSimpleDecorated $+         ppr (frr_context frr) $$+         text "cannot be assigned a fixed runtime representation," <+>+         text "not even by defaulting."    diagnosticReason = \case     TcRnUnknownMessage m@@ -1059,6 +1064,8 @@       -> ErrorWithoutFlag     TcRnInvalidCIdentifier{}       -> ErrorWithoutFlag+    TcRnCannotDefaultConcrete{}+      -> ErrorWithoutFlag    diagnosticHints = \case     TcRnUnknownMessage m@@ -1318,6 +1325,9 @@            _ -> noHints     TcRnInvalidCIdentifier{}       -> noHints+    TcRnCannotDefaultConcrete{}+      -> [SuggestAddTypeSignatures UnnamedBinding]+  deriveInstanceErrReasonHints :: Class                              -> UsingGeneralizedNewtypeDeriving

@@ -1790,6 +1790,16 @@   -}   TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage +  {- TcRnCannotDefaultConcrete is an error occurring when a concrete+    type variable cannot be defaulted.++    Test cases:+      T23153+  -}+  TcRnCannotDefaultConcrete+    :: !FixedRuntimeRepOrigin+    -> TcRnMessage+ -- | Specifies which backend code generators where expected for an FFI declaration data ExpectedBackends   = COrAsmOrLlvm         -- ^ C, Asm, or LLVM

@@ -45,28 +45,25 @@     -- ** Manipulating Boxity of a Demand     unboxDeeplyDmd, -    -- * Demand environments-    DmdEnv, emptyDmdEnv,-    keepAliveDmdEnv, reuseEnv,-     -- * Divergence     Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, +    -- * Demand environments+    DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,+    reuseEnv,+     -- * Demand types     DmdType(..), dmdTypeDepth,     -- ** Algebra     nopDmdType, botDmdType,-    lubDmdType, plusDmdType, multDmdType,-    -- *** PlusDmdArg-    PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,+    lubDmdType, plusDmdType, multDmdType, discardArgDmds,     -- ** Other operations     peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,-    keepAliveDmdType,      -- * Demand signatures     DmdSig(..), mkDmdSigForArity, mkClosedDmdSig,     splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,-    nopSig, botSig, isTopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,+    nopSig, botSig, isNopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,     -- ** Handling arity adjustments     prependArgsDmdSig, etaConvertDmdSig, @@ -85,9 +82,8 @@  import GHC.Prelude -import GHC.Types.Var ( Var, Id )+import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Types.Var.Set import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Data.Maybe   ( orElse )@@ -1036,7 +1032,7 @@  argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info]-argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args+argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args   | unsaturated_call = []   | otherwise = go arg_ds   where@@ -1279,7 +1275,7 @@ -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 -- (See Note [Default demand on free variables and arguments] for why) --- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'+-- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence' -- needs to be symmetric. -- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. -- But that regresses in too many places (every infinite loop, basically) to be@@ -1550,112 +1546,131 @@ -}  -- Subject to Note [Default demand on free variables and arguments]-type DmdEnv = VarEnv Demand+-- | Captures the result of an evaluation of an expression, by+--+--   * Listing how the free variables of that expression have been evaluted+--     ('de_fvs')+--   * Saying whether or not evaluation would surely diverge ('de_div')+--+-- See Note [Demand env Equality].+data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence } -emptyDmdEnv :: DmdEnv-emptyDmdEnv = emptyVarEnv+instance Eq DmdEnv where+  DE fv1 div1 == DE fv2 div2+    = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2+    where+      canonicalise div fv = filterUFM (/= defaultFvDmd div) fv +mkEmptyDmdEnv :: Divergence -> DmdEnv+mkEmptyDmdEnv div = DE emptyVarEnv div++-- | Build a potentially terminating 'DmdEnv' from a finite map that says what+-- has been evaluated so far+mkTermDmdEnv :: VarEnv Demand -> DmdEnv+mkTermDmdEnv fvs = DE fvs topDiv++nopDmdEnv :: DmdEnv+nopDmdEnv = mkEmptyDmdEnv topDiv++botDmdEnv :: DmdEnv+botDmdEnv = mkEmptyDmdEnv botDiv++exnDmdEnv :: DmdEnv+exnDmdEnv = mkEmptyDmdEnv exnDiv++lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv+lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div+  where+    -- See Note [Demand env Equality]+    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)+    lub_div = lubDivergence d1 d2++addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv+addVarDmdEnv env@(DE fvs div) id dmd+  = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div++plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv+plusDmdEnv (DE fv1 d1) (DE fv2 d2)+  -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric.+  | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd+  = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient+  | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd+  = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient+  | otherwise+  = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2))+       (d1 `plusDivergence` d2)++-- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum'+plusDmdEnvs :: [DmdEnv] -> DmdEnv+plusDmdEnvs []   = nopDmdEnv+plusDmdEnvs pdas = foldl1' plusDmdEnv pdas+ multDmdEnv :: Card -> DmdEnv -> DmdEnv-multDmdEnv C_11 env = env-multDmdEnv C_00 _   = emptyDmdEnv-multDmdEnv n    env = mapVarEnv (multDmd n) env+multDmdEnv C_11 env          = env+multDmdEnv C_00 _            = nopDmdEnv+multDmdEnv n    (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div)  reuseEnv :: DmdEnv -> DmdEnv reuseEnv = multDmdEnv C_1N --- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have--- /some/ usage in the returned demand types -- they are not Absent.--- See Note [Absence analysis for stable unfoldings and RULES]---     in "GHC.Core.Opt.DmdAnal".-keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv-keepAliveDmdEnv env vs-  = nonDetStrictFoldVarSet add env vs-  where-    add :: Id -> DmdEnv -> DmdEnv-    add v env = extendVarEnv_C add_dmd env v topDmd+lookupDmdEnv :: DmdEnv -> Id -> Demand+-- See Note [Default demand on free variables and arguments]+lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div -    add_dmd :: Demand -> Demand -> Demand-    -- If the existing usage is Absent, make it used-    -- Otherwise leave it alone-    add_dmd dmd _ | isAbsDmd dmd = topDmd-                  | otherwise    = dmd+delDmdEnv :: DmdEnv -> Id -> DmdEnv+delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div  -- | Characterises how an expression -----    * Evaluates its free variables ('dt_env')+--    * Evaluates its free variables ('dt_env') including divergence info --    * Evaluates its arguments ('dt_args')---    * Diverges on every code path or not ('dt_div') ----- Equality is defined modulo 'defaultFvDmd's in 'dt_env'.--- See Note [Demand type Equality]. data DmdType   = DmdType-  { dt_env  :: !DmdEnv     -- ^ Demand on explicitly-mentioned free variables+  { dt_env  :: !DmdEnv     -- ^ Demands on free variables.+                           -- See Note [Demand type Divergence]   , dt_args :: ![Demand]   -- ^ Demand on arguments-  , dt_div  :: !Divergence -- ^ Whether evaluation diverges.-                          -- See Note [Demand type Divergence]   } --- | See Note [Demand type Equality].+-- | See Note [Demand env Equality]. instance Eq DmdType where-  (==) (DmdType fv1 ds1 div1)-       (DmdType fv2 ds2 div2) =  div1 == div2 && ds1 == ds2 -- cheap checks first-                              && canonicalise div1 fv1 == canonicalise div2 fv2-       where-         canonicalise div fv = filterUFM (/= defaultFvDmd div) fv+  DmdType env1 ds1 == DmdType env2 ds2+    = ds1 == ds2 -- cheap checks first+      && env1 == env2  -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType-lubDmdType d1 d2-  = DmdType lub_fv lub_ds lub_div+lubDmdType d1 d2 = DmdType lub_fv lub_ds   where     n = max (dmdTypeDepth d1) (dmdTypeDepth d2)-    (DmdType fv1 ds1 r1) = etaExpandDmdType n d1-    (DmdType fv2 ds2 r2) = etaExpandDmdType n d2--    -- See Note [Demand type Equality]-    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)+    (DmdType fv1 ds1) = etaExpandDmdType n d1+    (DmdType fv2 ds2) = etaExpandDmdType n d2     lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2-    lub_div = lubDivergence r1 r2--type PlusDmdArg = (DmdEnv, Divergence)--mkPlusDmdArg :: DmdEnv -> PlusDmdArg-mkPlusDmdArg env = (env, topDiv)+    lub_fv = lubDmdEnv fv1 fv2 -toPlusDmdArg :: DmdType -> PlusDmdArg-toPlusDmdArg (DmdType fv _ r) = (fv, r)+discardArgDmds :: DmdType -> DmdEnv+discardArgDmds (DmdType fv _) = fv -plusDmdType :: DmdType -> PlusDmdArg -> DmdType-plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)-    -- See Note [Asymmetry of 'plus*']-    -- 'plus' takes the argument/result info from its *first* arg,-    -- using its second arg just for its free-var info.-  | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd-  = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient-  | otherwise-  = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))-            ds1-            (r1 `plusDivergence` t2)+plusDmdType :: DmdType -> DmdEnv -> DmdType+plusDmdType (DmdType fv ds) fv'+  -- See Note [Asymmetry of plusDmdType]+  -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation.+  = DmdType (plusDmdEnv fv fv') ds  botDmdType :: DmdType-botDmdType = DmdType emptyDmdEnv [] botDiv+botDmdType = DmdType botDmdEnv []  -- | The demand type of doing nothing (lazy, absent, no Divergence -- information). Note that it is ''not'' the top of the lattice (which would be -- "may use everything"), so it is (no longer) called topDmdType. nopDmdType :: DmdType-nopDmdType = DmdType emptyDmdEnv [] topDiv--isTopDmdType :: DmdType -> Bool-isTopDmdType (DmdType env args div)-  = div == topDiv && null args && isEmptyVarEnv env+nopDmdType = DmdType nopDmdEnv []  -- | The demand type of an unspecified expression that is guaranteed to -- throw a (precise or imprecise) exception or diverge. exnDmdType :: DmdType-exnDmdType = DmdType emptyDmdEnv [] exnDiv+exnDmdType = DmdType exnDmdEnv []  dmdTypeDepth :: DmdType -> Arity dmdTypeDepth = length . dt_args@@ -1664,7 +1679,7 @@ -- expansion, where n must not be lower than the demand types depth. -- It appends the argument list with the correct 'defaultArgDmd'. etaExpandDmdType :: Arity -> DmdType -> DmdType-etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div}+etaExpandDmdType n d@DmdType{dt_args = ds, dt_env = env}   | n == depth = d   | n >  depth = d{dt_args = inc_ds}   | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)@@ -1676,7 +1691,7 @@         --  * Divergence is still valid:         --    - A dead end after 2 arguments stays a dead end after 3 arguments         --    - The remaining case is Dunno, which is already topDiv-        inc_ds = take n (ds ++ repeat (defaultArgDmd div))+        inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env)))  -- | A conservative approximation for a given 'DmdType' in case of an arity -- decrease. Currently, it's just nopDmdType.@@ -1688,30 +1703,27 @@ -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})-splitDmdTy ty@DmdType{dt_div=div}       = (defaultArgDmd div, ty)+splitDmdTy ty@DmdType{dt_env=env}       = (defaultArgDmd (de_div env), ty)  multDmdType :: Card -> DmdType -> DmdType-multDmdType n (DmdType fv args res_ty)+multDmdType n (DmdType fv args)   = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $     DmdType (multDmdEnv n fv)             (map (multDmd n) args)-            (multDivergence n res_ty)  peelFV :: DmdType -> Var -> (DmdType, Demand)-peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)-                               (DmdType fv' ds res, dmd)+peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)+                            (DmdType fv' ds, dmd)   where   -- 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+  !fv' = fv `delDmdEnv` id+  !dmd = lookupDmdEnv fv id  addDemand :: Demand -> DmdType -> DmdType-addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res+addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds)  findIdDemand :: DmdType -> Var -> Demand-findIdDemand (DmdType fv _ res) id-  = lookupVarEnv fv id `orElse` defaultFvDmd res+findIdDemand (DmdType fv _) id = lookupDmdEnv fv id  -- | When e is evaluated after executing an IO action that may throw a precise -- exception, we act as if there is an additional control flow path that is@@ -1727,11 +1739,6 @@ deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType --- | See 'keepAliveDmdEnv'.-keepAliveDmdType :: DmdType -> VarSet -> DmdType-keepAliveDmdType (DmdType fvs ds res) vars =-  DmdType (fvs `keepAliveDmdEnv` vars) ds res- {- Note [deferAfterPreciseException] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The big picture is in Note [Precise exceptions and strictness analysis]@@ -1787,32 +1794,25 @@ strong enough to unleash err's signature and hence we see that the whole expression diverges! -Note [Demand type Equality]+Note [Demand env Equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~-What is the difference between the DmdType <L>{x->A} and <L>?+What is the difference between the Demand env {x->A} and {}? Answer: There is none! They have the exact same semantics, because any var that-is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on-the divergence of the demand type 'dt_div'.-Similarly, <B>b{x->B, y->A} is the same as <B>b{y->A}, because the default FV-demand of BotDiv is B. But neither is equal to <B>b, because y has demand B in+is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on+the divergence of the demand env 'de_div'.+Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV+demand of BotDiv is B. But neither is equal to b{}, because y has demand B in the latter, not A as before. -NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the-demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along-a 'Divergence', for example.--The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity-issues during fixed-point iteration (<L>{x->A} /= <L> /= <L>{x->A} /= ...).-It does so by filtering out any default FV demands prior to comparing 'dt_env'.-An alternative would be to maintain an invariant that there are no default FV demands-in 'dt_env' to begin with, but that seems more involved to maintain in the current-implementation.+The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity+issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...).+It does so by filtering out any default FV demands prior to comparing 'de_fvs'. -Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD',-involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the+Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD',+involving 'defaultFvDmd' for any entries present in one 'de_fvs' but not the other. -Note [Asymmetry of 'plus*']+Note [Asymmetry of plusDmdType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'plus' for DmdTypes is *asymmetrical*, because there can only one be one type contributing argument demands!  For example, given (e1 e2), we get@@ -1968,21 +1968,21 @@ -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' -- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig-mkDmdSigForArity arity dmd_ty@(DmdType fvs args div)-  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div+mkDmdSigForArity arity dmd_ty@(DmdType fvs args)+  | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args)   | otherwise                   = DmdSig (etaExpandDmdType arity dmd_ty)  mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig-mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res)+mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds)  splitDmdSig :: DmdSig -> ([Demand], Divergence)-splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res)+splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env)  dmdSigDmdEnv :: DmdSig -> DmdEnv-dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env+dmdSigDmdEnv (DmdSig (DmdType env _)) = env  hasDemandEnvSig :: DmdSig -> Bool-hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv+hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv  botSig :: DmdSig botSig = DmdSig botDmdType@@ -1990,17 +1990,17 @@ nopSig :: DmdSig nopSig = DmdSig nopDmdType -isTopSig :: DmdSig -> Bool-isTopSig (DmdSig ty) = isTopDmdType ty+isNopSig :: DmdSig -> Bool+isNopSig (DmdSig ty) = ty == nopDmdType  -- | True if the signature diverges or throws an exception in a saturated call. -- See Note [Dead ends]. isDeadEndSig :: DmdSig -> Bool-isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res+isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env)  -- | True when the signature indicates all arguments are boxed onlyBoxedArguments :: DmdSig -> Bool-onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds+onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds  where    demandIsBoxed BotDmd    = True    demandIsBoxed AbsDmd    = True@@ -2020,12 +2020,15 @@ -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. isDeadEndAppSig :: DmdSig -> Int -> Bool-isDeadEndAppSig (DmdSig (DmdType _ ds res)) n-  = isDeadEndDiv res && not (lengthExceeds ds n)+isDeadEndAppSig (DmdSig (DmdType env ds)) n+  = isDeadEndDiv (de_div env) && not (lengthExceeds ds n) +trimBoxityDmdEnv :: DmdEnv -> DmdEnv+trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div+ trimBoxityDmdType :: DmdType -> DmdType-trimBoxityDmdType (DmdType fvs ds res) =-  DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res+trimBoxityDmdType (DmdType env ds) =+  DmdType (trimBoxityDmdEnv env) (map trimBoxity ds)  trimBoxityDmdSig :: DmdSig -> DmdSig trimBoxityDmdSig = coerce trimBoxityDmdType@@ -2034,12 +2037,10 @@ -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument -- demands. This is used by FloatOut.-prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res))-  | new_args == 0       = sig-  | isTopDmdType dmd_ty = sig-  | new_args < 0        = pprPanic "prependArgsDmdSig: negative new_args"-                                   (ppr new_args $$ ppr sig)-  | otherwise           = DmdSig (DmdType env dmds' res)+prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds))+  | new_args == 0        = sig+  | dmd_ty == nopDmdType = sig+  | otherwise            = DmdSig (DmdType env dmds')   where     dmds' = replicate new_args topDmd ++ dmds @@ -2080,7 +2081,7 @@ -- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, -- return how the function evaluates its free variables and arguments. dmdTransformSig :: DmdSig -> DmdTransformer-dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd+dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd   = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty     -- see Note [Demands from unsaturated function calls]     -- and Note [What are demand signatures?]@@ -2095,7 +2096,7 @@   where     arity = length str_marks     (n, body_sd) = peelManyCalls arity sd-    mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv+    mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds)     bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd)                    | otherwise          = multDmd n dmd     str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness]@@ -2106,11 +2107,11 @@ dmdTransformDictSelSig :: DmdSig -> DmdTransformer -- NB: This currently doesn't handle newtype dictionaries. -- It should simply apply call_sd directly to the dictionary, I suppose.-dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd+dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd    | (n, sd') <- peelCallDmd call_sd    , Prod _ sig_ds <- prod    = multDmdType n $-     DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv+     DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)]    | otherwise    = nopDmdType -- See Note [Demand transformer for a dictionary selector]   where@@ -2232,9 +2233,12 @@ it should not fall over. -} +zapDmdEnv :: DmdEnv -> DmdEnv+zapDmdEnv (DE _ div) = mkEmptyDmdEnv div+ -- | Remove the demand environment from the signature. zapDmdEnvSig :: DmdSig -> DmdSig-zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r+zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds)  zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand@@ -2255,8 +2259,8 @@ -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness --   signature zapUsedOnceSig :: DmdSig -> DmdSig-zapUsedOnceSig (DmdSig (DmdType env ds r))-    = DmdSig (DmdType env (map zapUsedOnceDemand ds) r)+zapUsedOnceSig (DmdSig (DmdType env ds))+    = DmdSig (DmdType env (map zapUsedOnceDemand ds))  data KillFlags = KillFlags     { kf_abs         :: Bool@@ -2341,11 +2345,11 @@ seqDemandList = foldr (seq . seqDemand) ()  seqDmdType :: DmdType -> ()-seqDmdType (DmdType env ds res) =-  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()+seqDmdType (DmdType env ds) =+  seqDmdEnv env `seq` seqDemandList ds `seq` ()  seqDmdEnv :: DmdEnv -> ()-seqDmdEnv env = seqEltsUFM seqDemand env+seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs  seqDmdSig :: DmdSig -> () seqDmdSig (DmdSig ty) = seqDmdType ty@@ -2454,17 +2458,20 @@   ppr ExnOrDiv = char 'x' -- for e(x)ception   ppr Dunno    = empty -instance Outputable DmdType where-  ppr (DmdType fv ds res)-    = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,-            if null fv_elts then empty-            else braces (fsep (map pp_elt fv_elts))]+instance Outputable DmdEnv where+  ppr (DE fvs div)+    = ppr div <> if null fv_elts then empty+                 else braces (fsep (map pp_elt fv_elts))     where       pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd-      fv_elts = nonDetUFMToList fv+      fv_elts = nonDetUFMToList fvs         -- It's OK to use nonDetUFMToList here because we only do it for         -- pretty printing +instance Outputable DmdType where+  ppr (DmdType fv ds)+    = hcat (map (angleBrackets . ppr) ds) <> ppr fv+ instance Outputable DmdSig where    ppr (DmdSig ty) = ppr ty @@ -2513,15 +2520,6 @@       2 -> Prod <$> get bh <*> get bh       _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) -instance Binary DmdSig where-  put_ bh (DmdSig aa) = put_ bh aa-  get bh = DmdSig <$> get bh--instance Binary DmdType where-  -- Ignore DmdEnv when spitting out the DmdType-  put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr-  get bh = DmdType emptyDmdEnv <$> get bh <*> get bh- instance Binary Divergence where   put_ bh Dunno    = putByte bh 0   put_ bh ExnOrDiv = putByte bh 1@@ -2533,3 +2531,16 @@       1 -> return ExnOrDiv       2 -> return Diverges       _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))++instance Binary DmdEnv where+  -- Ignore VarEnv when spitting out the DmdType+  put_ bh (DE _ d) = put_ bh d+  get bh = DE emptyVarEnv <$> get bh++instance Binary DmdType where+  put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds+  get bh = DmdType <$> get bh <*> get bh++instance Binary DmdSig where+  put_ bh (DmdSig aa) = put_ bh aa+  get bh = DmdSig <$> get bh

@@ -695,6 +695,8 @@ setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id +-- | This function counts all arguments post-unarisation, which includes+-- arguments with no runtime representation -- see Note [Unarisation and arity] idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) 

@@ -372,6 +372,7 @@         --         -- See documentation of the getters for what these packed fields mean.         lfInfo          :: !(Maybe LambdaFormInfo),+        -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure          -- See documentation of the getters for what these packed fields mean.         tagSig          :: !(Maybe TagSig)@@ -451,7 +452,7 @@ oneShotInfo = bitfieldGetOneShotInfo . bitfield  -- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments--- this 'Id' has to be applied to before it doesn any meaningful work.+-- this 'Id' has to be applied to before it does any meaningful work. arityInfo :: IdInfo -> ArityInfo arityInfo = bitfieldGetArityInfo . bitfield 

@@ -1075,13 +1075,13 @@ putBS bh bs =   BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do     put_ bh l-    putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l)+    putPrim bh l (\op -> copyBytes op (castPtr ptr) l)  getBS :: BinHandle -> IO ByteString getBS bh = do   l <- get bh :: IO Int   BS.create l $ \dest -> do-    getPrim bh l (\src -> BS.memcpy dest src l)+    getPrim bh l (\src -> copyBytes dest src l)  instance Binary ByteString where   put_ bh f = putBS bh f

@@ -900,6 +900,12 @@     ppr EQ = text "EQ"     ppr GT = text "GT" +instance Outputable Int8 where+   ppr n = integer $ fromIntegral n++instance Outputable Int16 where+   ppr n = integer $ fromIntegral n+ instance Outputable Int32 where    ppr n = integer $ fromIntegral n @@ -911,6 +917,9 @@  instance Outputable Integer where     ppr n = integer n++instance Outputable Word8 where+    ppr n = integer $ fromIntegral n  instance Outputable Word16 where     ppr n = integer $ fromIntegral n

@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-parser-version: 9.4.5.20230430+version: 9.4.6.20230808 license: BSD3 license-file: LICENSE category: Development

@@ -21,7 +21,7 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "9.2.5"+cBooterVersion        = "9.2.7"  cStage                :: String cStage                = show (1 :: Int)

@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "a213d3676550a0e4d542172de539c0cfa2662431"+cProjectGitCommitId   = "5f9929478e304868cbb6e1ea04da3f27ea4a1e8e"  cProjectVersion       :: String-cProjectVersion       = "9.4.5"+cProjectVersion       = "9.4.6"  cProjectVersionInt    :: String cProjectVersionInt    = "904"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "5"+cProjectPatchLevel    = "6"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "5"+cProjectPatchLevel1   = "6"  cProjectPatchLevel2   :: String cProjectPatchLevel2   = "0"

@@ -186,6 +186,9 @@ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 +/* Define to 1 if you have the `mingwex' library (-lmingwex). */+/* #undef HAVE_LIBMINGWEX */+ /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 

@@ -6,6 +6,14 @@ -- ----------------------------------------------------------------------------- +-- See Note [FFI_GO_CLOSURES workaround] in ghc_ffi.h+-- We can't include ghc_ffi.h here as we must build with stage0+#if defined(darwin_HOST_OS)+#if !defined(FFI_GO_CLOSURES)+#define FFI_GO_CLOSURES 0+#endif+#endif+ #include <ffi.h>  {-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}

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