diff --git a/compiler/Bytecodes.h b/compiler/Bytecodes.h --- a/compiler/Bytecodes.h +++ b/compiler/Bytecodes.h @@ -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 */ diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs --- a/compiler/GHC/ByteCode/Types.hs +++ b/compiler/GHC/ByteCode/Types.hs @@ -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 " 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 " 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 diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -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 diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -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 diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -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 diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -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 "" <+> sep (map pprType lhs_tys) + , nest 2 (text "=" <+> ppr rhs) + , ppUnless (null incomps) $ + text "incomps:" <+> vcat (map ppr incomps) ]) {- ************************************************************************ diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -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 diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -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 } diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -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)) diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -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! diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -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 ] {- ----------------------------------------------------- diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -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 diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -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 _ = () diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -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 diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -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 diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -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 diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -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. -} - diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -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]] diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -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 diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -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 "" <+> parens (ppr e) - ppr (IfCoreUnfold s e) = (if s + ppr (IfCoreUnfold s _ e) = (if s then text "" 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 -> diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -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 diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs --- a/compiler/GHC/StgToCmm/Types.hs +++ b/compiler/GHC/StgToCmm/Types.hs @@ -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 @'[] @~() + +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. diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -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 diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -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 diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -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 {x->A} and ? +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{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 +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 ({x->A} /= /= {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 diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -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) diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -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 diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -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 diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -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 diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -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 diff --git a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs --- a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +++ b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs @@ -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) diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -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" diff --git a/ghc-lib/stage0/rts/build/include/ghcautoconf.h b/ghc-lib/stage0/rts/build/include/ghcautoconf.h --- a/ghc-lib/stage0/rts/build/include/ghcautoconf.h +++ b/ghc-lib/stage0/rts/build/include/ghcautoconf.h @@ -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 diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc --- a/libraries/ghci/GHCi/FFI.hsc +++ b/libraries/ghci/GHCi/FFI.hsc @@ -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 {-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-} diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -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