diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 5d6d6d26c977febb0f95119f022b8e8b44d94ade..e4fd3cc5e2b8868be3e464d95c787b24473e3ded 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -648,6 +648,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri -- See Note [Constructor tag allocation] and #14657 data_con = mkDataCon dc_name declared_infix prom_info (map (const no_bang) arg_tys) + (map (const HsLazy) arg_tys) + (map (const NotMarkedStrict) arg_tys) [] -- No labelled fields tyvars ex_tyvars conc_tyvars diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 8c1c5f635dbc018f1c0f4ce2daab0ebaed7cf9ff..c7f8cd005e9d70c8e101be8d3bfe1df3b118a615 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -42,7 +42,7 @@ module GHC.Core ( foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, collectNBinders, collectNValBinders_maybe, - collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds, collectFunSimple, exprToType, @@ -1029,6 +1029,61 @@ tail position: A cast changes the type, but the type must be the same. But operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for ideas how to fix this. +Note [Strict fields in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Evaluating a data constructor worker evaluates its strict fields. + +In other words, if `MkT` is strict in its first field and `xs` reduces to +`error "boom"`, then `MkT xs b` will throw that error. +Consequently, it is sound to seq the field before the call to the constructor, +e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`. +Let's call this transformation "field eval insertion". + +Note in particular that the data constructor application `MkT xs b` above is +*not* a value, unless `xs` is! + +This has pervasive effect on the Core pipeline: + +(SFC1) `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the + strict arguments of a DataCon worker are values/ok-for-spec themselves. + +(SFC2) `exprIsConApp_maybe` inserts field evals in the `FloatBind`s it returns, so + that the Simplifier, Constant-folding, the pattern-match checker, etc. + all see the inserted field evals when they match on strict workers. Often this + is just to emphasise strict semantics, but for case-of-known constructor + and case-to-let, field insertion is *vital*, otherwise these transformations + would lose field evals that the user expects to happen, perhaps in order to + fix a space leak. For example, + case MkT xs b of MkT xs' b' -> b' + optimising this expression with case-of-known-con must leave behind the + field eval on `xs`, thus + case xs of xs' { __DEFAULT -> b } + +(SFC3) The demand signature of a data constructor is strict in strict field + position when otherwise it is lazy. Likewise the demand *transformer* + of a DataCon worker can stricten up demands on strict field args. + See Note [Demand transformer for data constructors]. + +(SFC4) In the absence of `-fpedantic-bottoms`, it is still possible that some seqs + are ultimately dropped or delayed due to eta-expansion. + See Note [Dealing with bottom]. + +Strict field semantics is exploited and lowered in STG during EPT enforcement; +see Note [EPT enforcement lowers strict constructor worker semantics] for the +connection. + +Historical Note: +The delightfully simple description of strict field semantics is the result of +a long saga (#20749, the bits about strict data constructors in #21497, #22475), +where we tried a more lenient (but actually not) semantics first that would +allow both strict and lazy implementations of DataCon workers. This was favoured +because the "pervasive effect" throughout the compiler was deemed too large +(when it really turned out to be quite modest). +Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the +same way as above, otherwise the analysis would not be conservative wrt. the +lenient semantics (which includes the strict one). It is also much harder to +explain and maintain, as it turned out. + ************************************************************************ * * In/Out type synonyms @@ -2158,6 +2213,17 @@ collectArgs expr go (App f a) as = go f (a:as) go e as = (e, as) +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectValArgs :: Expr b -> (Expr b, [Arg b]) +collectValArgs expr + = go expr [] + where + go (App f a) as + | isValArg a = go f (a:as) + | otherwise = go f as + go e as = (e, as) + -- | Takes a nested application expression and returns the function -- being applied. Looking through casts and ticks to find it. collectFunSimple :: Expr b -> Expr b diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 1dd17bed577dcb805037fce8e4453ad796eef6a6..5f04b919c24bbef2a22cf95eaec3224704d32b67 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -49,18 +49,20 @@ module GHC.Core.DataCon ( dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitTyThings, - dataConRepStrictness, dataConImplBangs, dataConBoxer, + dataConRepStrictness, + dataConImplBangs, dataConBoxer, splitDataProductType_maybe, -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, + isLazyDataConRep, isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon, isUnboxedSumDataCon, isCovertGadtDataCon, isVanillaDataCon, isNewDataCon, isTypeDataCon, classDataCon, dataConCannotMatch, dataConUserTyVarsNeedWrapper, checkDataConTyVars, - isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, + isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, -- ** Promotion related functions @@ -524,6 +526,18 @@ data DataCon -- Matches 1-1 with dcOrigArgTys -- Hence length = dataConSourceArity dataCon + dcImplBangs :: [HsImplBang], + -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + dcStricts :: [StrictnessMark], + -- One mark for every field of the DataCon worker; + -- if it's empty, then all fields are lazy, + -- otherwise 1-1 with dataConRepArgTys. + -- See also Note [Strict fields in Core] in GHC.Core + -- for the effect on the strictness signature + dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the dcOrigArgTys; @@ -826,13 +840,6 @@ data DataConRep -- after unboxing and flattening, -- and *including* all evidence args - , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] - - , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) - -- about the original arguments; 1-1 with orig_arg_tys - -- See Note [Bangs on data constructor arguments] - } type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon @@ -900,43 +907,8 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty instance Outputable EqSpec where ppr (EqSpec tv ty) = ppr (tv, ty) -{- Note [Data-con worker strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we do *not* say the worker Id is strict even if the data -constructor is declared strict - e.g. data T = MkT ![Int] Bool -Even though most often the evals are done by the *wrapper* $WMkT, there are -situations in which tag inference will re-insert evals around the worker. -So for all intents and purposes the *worker* MkT is strict, too! - -Unfortunately, if we exposed accurate strictness of DataCon workers, we'd -see the following transformation: - - f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs - ==> { drop-seq, binder swap on xs' } - f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs - ==> { case-to-let } - f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs! - -I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs` -and then doing case-to-let. The issue is that `exprIsHNF` currently says that -every DataCon worker app is a value. The implicit assumption is that surrounding -evals will have evaluated strict fields like `xs` before! But now that we had -just dropped the eval on `xs`, that assumption is no longer valid. - -Long story short: By keeping the demand signature lazy, the Simplifier will not -drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others -remains sound. - -Similarly, during demand analysis in dmdTransformDataConSig, we bump up the -field demand with `C_01`, *not* `C_11`, because the latter exposes too much -strictness that will drop the eval on `xs` above. - -This issue is discussed at length in -"Failed idea: no wrappers for strict data constructors" in #21497 and #22475. - -Note [Bangs on data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT !Int {-# UNPACK #-} !Int Bool @@ -962,8 +934,8 @@ Terminology: the flag settings in the importing module. Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make -* The dcr_bangs field of the dcRep field records the [HsImplBang] - If T was defined in this module, Without -O the dcr_bangs might be +* The dcImplBangs field records the [HsImplBang] + If T was defined in this module, Without -O the dcImplBangs might be [HsStrict _, HsStrict _, HsLazy] With -O it might be [HsStrict _, HsUnpack _, HsLazy] @@ -972,6 +944,19 @@ Terminology: With -XStrictData it might be [HsStrict _, HsUnpack _, HsStrict _] +* Core passes will often need to know whether the DataCon worker or wrapper in + an application is strict in some (lifted) field or not. This is tracked in the + demand signature attached to a DataCon's worker resp. wrapper Id. + + So if you've got a DataCon dc, you can get the demand signature by + `idDmdSig (dataConWorkId dc)` and make out strict args by testing with + `isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives + you the demand signature of the wrapper, if it exists. + + These demand signatures are set in GHC.Types.Id.Make.mkDataConWorkId, + compute from the single source of truth `dataConRepStrictness`, which is + generated from `dcStricts`. + Note [Detecting useless UNPACK pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to issue a warning when there's an UNPACK pragma in the source code, @@ -1007,7 +992,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. - ************************************************************************ * * \subsection{Instances} @@ -1109,6 +1093,11 @@ isBanged (HsUnpack {}) = True isBanged (HsStrict {}) = True isBanged HsLazy = False +isUnpacked :: HsImplBang -> Bool +isUnpacked (HsUnpack {}) = True +isUnpacked (HsStrict {}) = False +isUnpacked HsLazy = False + isSrcStrict :: SrcStrictness -> Bool isSrcStrict SrcStrict = True isSrcStrict _ = False @@ -1134,13 +1123,15 @@ cbvFromStrictMark MarkedStrict = MarkedCbv -- | Build a new data constructor mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVar] -- ^ Universals. - -> [TyCoVar] -- ^ Existentials. + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [HsImplBang] -- ^ Strictness/unpack annotations, as inferred by the compiler + -> [StrictnessMark] -- ^ Strictness marks for the DataCon worker's fields in Core + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. -> ConcreteTyVars -- ^ TyVars which must be instantiated with -- concrete types @@ -1162,7 +1153,9 @@ mkDataCon :: Name -- Can get the tag from the TyCon mkDataCon name declared_infix prom_info - arg_stricts -- Must match orig_arg_tys 1-1 + arg_stricts -- Must match orig_arg_tys 1-1 + impl_bangs -- Must match orig_arg_tys 1-1 + str_marks -- Must be empty or match dataConRepArgTys 1-1 fields univ_tvs ex_tvs conc_tvs user_tvbs eq_spec theta @@ -1179,6 +1172,8 @@ mkDataCon name declared_infix prom_info = con where is_vanilla = null ex_tvs && null eq_spec && null theta + str_marks' | not $ any isMarkedStrict str_marks = [] + | otherwise = str_marks con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, @@ -1191,7 +1186,8 @@ mkDataCon name declared_infix prom_info dcStupidTheta = stupid_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = rep_tycon, - dcSrcBangs = arg_stricts, + dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs, + dcStricts = str_marks', dcFields = fields, dcTag = tag, dcRepType = rep_ty, dcWorkId = work_id, dcRep = rep, @@ -1434,20 +1430,25 @@ isNullarySrcDataCon dc = dataConSourceArity dc == 0 isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 +isLazyDataConRep :: DataCon -> Bool +-- ^ True <==> All fields are lazy +isLazyDataConRep dc = null (dcStricts dc) + dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = case dcRep dc of - NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] - DCR { dcr_stricts = strs } -> strs +-- ^ Give the demands on the runtime arguments of a Core DataCon worker +-- application. +-- The length of the list matches `dataConRepArgTys` (e.g., the number +-- of runtime arguments). +dataConRepStrictness dc + | isLazyDataConRep dc + = replicate (dataConRepArity dc) NotMarkedStrict + | otherwise + = dcStricts dc dataConImplBangs :: DataCon -> [HsImplBang] -- The implementation decisions about the strictness/unpack of each -- source program argument to the data constructor -dataConImplBangs dc - = case dcRep dc of - NoDataConRep -> replicate (dcSourceArity dc) HsLazy - DCR { dcr_bangs = bangs } -> bangs +dataConImplBangs dc = dcImplBangs dc dataConBoxer :: DataCon -> Maybe DataConBoxer dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 98c7235c57a19fe0c736234d45cbd0f7c83f8b0e..e1bb7b216046544e6160561d5cf0e31c24cf9bc9 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -1533,7 +1533,7 @@ myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty -- See Note [Eta expanding through dictionaries] -- See Note [Eta expanding through CallStacks] - cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e -- | A version of 'isCheapApp' that considers results from arity analysis. -- See Note [Arity analysis] for what's in the signature environment and why diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index 9d83e3d8596972cd488c0386657a7a817f460ed5..13fc39ee91d6a99fd74b585d8160ef2599f51fc3 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -209,7 +209,7 @@ cprAnal, cprAnal' -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ - cprAnal' env e + cprAnal' env e cprAnal' _ (Lit lit) = (topCprType, Lit lit) cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact @@ -296,9 +296,16 @@ data TermFlag -- Better than using a Bool -- See Note [Nested CPR] exprTerminates :: CoreExpr -> TermFlag +-- ^ A /very/ simple termination analysis. exprTerminates e - | exprIsHNF e = Terminates -- A /very/ simple termination analysis. - | otherwise = MightDiverge + | exprIsHNF e = Terminates + | exprOkForSpeculation e = Terminates + | otherwise = MightDiverge + -- Annoyingly, we have to check both for HNF and ok-for-spec. + -- * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing! + -- * `lvl` is an HNF if its unfolding is evaluated + -- (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never + -- ok-for-spec due to Note [exprOkForSpeculation and evaluated variables]. cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr) -- Main function that takes care of /nested/ CPR. See Note [Nested CPR] @@ -367,8 +374,8 @@ cprTransformDataConWork env con args , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE] , args `lengthIs` wkr_arity , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors] - -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True - = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks)) + = -- pprTraceWith "cprTransformDataConWork" (\r -> ppr con <+> ppr wkr_arity <+> ppr args <+> ppr r) $ + CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks)) | otherwise = topCprType where @@ -505,7 +512,8 @@ cprAnalBind env id rhs | isDataStructure id -- Data structure => no code => no need to analyse rhs = (id, rhs, env) | otherwise - = (id `setIdCprSig` sig', rhs', env') + = -- pprTrace "cprAnalBind" (ppr id <+> ppr sig <+> ppr sig') + (id `setIdCprSig` sig', rhs', env') where (rhs_ty, rhs') = cprAnal env rhs -- possibly trim thunk CPR info diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index a4972f94062efef9aa3556f8d7bd4b7df4cd2109..8b547d4e9ee537b1d6f6d01467e3219585edfb7c 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -835,6 +835,10 @@ to the Divergence lattice, but in practice it turned out to be hard to untaint from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +You might think that we should check for side-effects rather than just for +precise exceptions. Right you are! See Note [Side-effects and strictness] +for why we unfortunately do not. + Note [Demand analysis for recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ T11545 features a single-product, recursive data type diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 8f52855e26e45670939a9009d45d4deaf2d6a314..335847c09a38d12cfff91a959da527520ff00d47 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -8,14 +8,13 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - SimplMode(..), updMode, - smPedanticBottoms, smPlatform, + SimplMode(..), updMode, smPlatform, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, - seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline, + seOptCoercionOpts, sePhase, sePlatform, sePreInline, seRuleOpts, seRules, seUnfoldingOpts, mkSimplEnv, extendIdSubst, extendCvIdSubst, extendTvSubst, extendCvSubst, @@ -235,9 +234,6 @@ seNames env = sm_names (seMode env) seOptCoercionOpts :: SimplEnv -> OptCoercionOpts seOptCoercionOpts env = sm_co_opt_opts (seMode env) -sePedanticBottoms :: SimplEnv -> Bool -sePedanticBottoms env = smPedanticBottoms (seMode env) - sePhase :: SimplEnv -> CompilerPhase sePhase env = sm_phase (seMode env) @@ -292,9 +288,6 @@ instance Outputable SimplMode where where pp_flag f s = ppUnless f (text "no") <+> s -smPedanticBottoms :: SimplMode -> Bool -smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts) - smPlatform :: SimplMode -> Platform smPlatform opts = roPlatform (sm_rule_opts opts) diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index b0fe0caa0da3377171e83586b5792e5da049441c..0ef58aec223b9a07654c0c60fe4b9d72e4906347 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -31,9 +31,6 @@ import GHC.Core.Reduction import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon - ( DataCon, dataConWorkId, dataConRepStrictness - , dataConRepArgTys, isUnboxedTupleDataCon - , StrictnessMark (..), dataConWrapId_maybe ) import GHC.Core.Opt.Stats ( Tick(..) ) import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Core.Unfold @@ -2204,17 +2201,21 @@ zap the SubstEnv. This is VITAL. Consider We'll clone the inner \x, adding x->x' in the id_subst Then when we inline y, we must *not* replace x by x' in the inlined copy!! -Note [Fast path for data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For applications of a data constructor worker, the full glory of +Note [Fast path for lazy data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For applications of a /lazy/ data constructor worker, the full glory of rebuildCall is a waste of effort; * They never inline, obviously * They have no rewrite rules -* They are not strict (see Note [Data-con worker strictness] - in GHC.Core.DataCon) +* Lazy constructors don't need the `StrictArg` treatment. So it's fine to zoom straight to `rebuild` which just rebuilds the call in a very straightforward way. +For a data constructor worker that is strict (see Note [Strict fields in Core]) +we take the slow path, so that we'll transform + K (case x of (a,b) -> a) --> case x of (a,b) -> K a +via the StrictArg case of rebuildCall + Some programs have a /lot/ of data constructors in the source program (compiler/perf/T9961 is an example), so this fast path can be very valuable. @@ -2235,7 +2236,8 @@ simplVar env var simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplIdF env var cont - | isDataConWorkId var -- See Note [Fast path for data constructors] + | Just dc <- isDataConWorkId_maybe var + , isLazyDataConRep dc -- See Note [Fast path for lazy data constructors] = rebuild env (Var var) cont | otherwise = case substId env var of @@ -3461,7 +3463,7 @@ a case pattern. This is *important*. Consider We really must record that b is already evaluated so that we don't go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in GHC.Core.DataCon +See Note [Strict fields in Core] in GHC.Core. NB: simplLamBndrs preserves this eval info diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 3ddefd75e3cdfd65955a21d6982658074d26faeb..0e0a40969c0e708c8a8d2408971234c5993bee74 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -833,7 +833,7 @@ We could still try to do C) in the future by having PAP calls which will evaluat before calling the partially applied function. But this would be neither a small nor simple change so we stick with A) and a flag for B) for now. -See also Note [Tag Inference] and Note [CBV Function Ids] +See also Note [EPT enforcement] and Note [CBV Function Ids] Note [Worker/wrapper for strict arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -859,7 +859,7 @@ happens at all. The worker `$wf` is a CBV function (see `Note [CBV Function Ids]` in GHC.Types.Id.Info) and the code generator guarantees that every -call to `$wf` has a properly tagged argument (see `GHC.Stg.InferTags.Rewrite`). +call to `$wf` has a properly tagged argument (see `GHC.Stg.EnforceEpt.Rewrite`). Is this a win? Not always: * It can cause slight codesize increases. This is since we push evals to every diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index afaeed01e7dee2ce550b97baf0522f9c7169f608..0c5dad9178d7f4c06db941592e06d16f11d9c61f 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -1284,11 +1284,8 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr -- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } - = let arg' = subst_expr subst arg - bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type) - float = FloatCase arg' bndr DEFAULT [] - subst' = subst_extend_in_scope subst bndr - in go subst' (float:floats) fun (CC (Var bndr : args) mco) + , (subst', float, bndr) <- case_bind subst arg arg_type + = go subst' (float:floats) fun (CC (Var bndr : args) mco) | otherwise = go subst floats fun (CC (subst_expr subst arg : args) mco) @@ -1331,8 +1328,10 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun - = succeedWith in_scope floats $ - pushCoDataCon con args mco + , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args + -- mkFieldSeqFloats: See (SFC2) in Note [Strict fields in Core] + = succeedWith in_scope' (seq_floats ++ floats) $ + pushCoDataCon con args' mco -- Look through data constructor wrappers: they inline late (See Note -- [Activation for data constructor wrappers]) but we want to do @@ -1418,6 +1417,38 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) + case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id) + case_bind subst expr expr_ty = (subst', float, bndr) + where + bndr = setCaseBndrEvald MarkedStrict $ + uniqAway (subst_in_scope subst) $ + mkWildValBinder ManyTy expr_ty + subst' = subst_extend_in_scope subst bndr + expr' = subst_expr subst expr + float = FloatCase expr' bndr DEFAULT [] + + mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr]) + -- See Note [Strict fields in Core] for what a field eval is and why we + -- insert them + mkFieldSeqFloats in_scope dc args + | isLazyDataConRep dc + = (in_scope, [], args) + | otherwise + = (in_scope', floats', ty_args ++ val_args') + where + (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args + (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual "mkFieldSeqFloats" str_marks val_args + str_marks = dataConRepStrictness dc + do_one (str, arg) (in_scope,floats,args) + | NotMarkedStrict <- str = no_seq + | exprIsHNF arg = no_seq + | otherwise = (in_scope', float:floats, Var bndr:args) + where + no_seq = (in_scope, floats, arg:args) + (in_scope', float, bndr) = + case case_bind (Left in_scope) arg (exprType arg) of + (Left in_scope', float, bndr) -> (in_scope', float, bndr) + (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) -- See Note [exprIsConApp_maybe on literal strings] dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 5514090540cbc9344a4689acfb7fed966cd9a5f3..1657930279228afcfba0806f56a59136f1dbeb64 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -55,7 +55,7 @@ module GHC.Core.Type ( splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe, splitForAllTyCoVar_maybe, splitForAllTyCoVar, splitForAllTyVar_maybe, splitForAllCoVar_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, + splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders, getRuntimeArgTys, mkTyConBindersPreferAnon, mkPiTy, mkPiTys, @@ -292,6 +292,7 @@ import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Maybe ( orElse, isJust, firstJust ) +import GHC.List (build) -- $type_classification -- #type_classification# @@ -2061,6 +2062,18 @@ splitPiTys ty = split ty ty [] split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) +collectPiTyBinders :: Type -> [PiTyBinder] +collectPiTyBinders ty = build $ \c n -> + let + split (ForAllTy b res) = Named b `c` split res + split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + = Anon (Scaled w arg) af `c` split res + split ty | Just ty' <- coreView ty = split ty' + split _ = n + in + split ty +{-# INLINE collectPiTyBinders #-} + -- | Extracts a list of run-time arguments from a function type, -- looking through newtypes to the right of arrows. -- diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index d6bcc869018ca61bcee57c92a7d266153414dd3a..968d0306156f489c77e00ab8967dfc40e7731bbf 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -1494,18 +1494,23 @@ in this (which it previously was): in \w. v True -} --------------------- -exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] -exprIsWorkFree e = exprIsCheapX isWorkFreeApp e - -exprIsCheap :: CoreExpr -> Bool -exprIsCheap e = exprIsCheapX isCheapApp e +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + -- isExpandableApp -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool +exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool {-# INLINE exprIsCheapX #-} --- allow specialization of exprIsCheap and exprIsWorkFree +-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable -- instead of having an unknown call to ok_app -exprIsCheapX ok_app e +-- expandable: Only True for exprIsExpandable, where Case and Let are never +-- expandable. +exprIsCheapX ok_app expandable e = ok e where ok e = go 0 e @@ -1516,7 +1521,7 @@ exprIsCheapX ok_app e go _ (Type {}) = True go _ (Coercion {}) = True go n (Cast e _) = go n e - go n (Case scrut _ _ alts) = ok scrut && + go n (Case scrut _ _ alts) = not expandable && ok scrut && and [ go n rhs | Alt _ _ rhs <- alts ] go n (Tick t e) | tickishCounts t = False | otherwise = go n e @@ -1524,90 +1529,26 @@ exprIsCheapX ok_app e | otherwise = go n e go n (App f e) | isRuntimeArg e = go (n+1) f && ok e | otherwise = go n f - go n (Let (NonRec _ r) e) = go n e && ok r - go n (Let (Rec prs) e) = go n e && all (ok . snd) prs + go n (Let (NonRec _ r) e) = not expandable && go n e && ok r + go n (Let (Rec prs) e) = not expandable && go n e && all (ok . snd) prs -- Case: see Note [Case expressions are work-free] -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] +-------------------- +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e -{- Note [exprIsExpandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -An expression is "expandable" if we are willing to duplicate it, if doing -so might make a RULE or case-of-constructor fire. Consider - let x = (a,b) - y = build g - in ....(case x of (p,q) -> rhs)....(foldr k z y).... - -We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), -but we do want - - * the case-expression to simplify - (via exprIsConApp_maybe, exprIsLiteral_maybe) - - * the foldr/build RULE to fire - (by expanding the unfolding during rule matching) - -So we classify the unfolding of a let-binding as "expandable" (via the -uf_expandable field) if we want to do this kind of on-the-fly -expansion. Specifically: - -* True of constructor applications (K a b) - -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. - (NB: exprIsCheap might not be true of this) - -* False of case-expressions. If we have - let x = case ... in ...(case x of ...)... - we won't simplify. We have to inline x. See #14688. - -* False of let-expressions (same reason); and in any case we - float lets out of an RHS if doing so will reveal an expandable - application (see SimplEnv.doFloatFromRhs). - -* Take care: exprIsExpandable should /not/ be true of primops. I - found this in test T5623a: - let q = /\a. Ptr a (a +# b) - in case q @ Float of Ptr v -> ...q... - - q's inlining should not be expandable, else exprIsConApp_maybe will - say that (q @ Float) expands to (Ptr a (a +# b)), and that will - duplicate the (a +# b) primop, which we should not do lightly. - (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) --} +-------------------- +exprIsCheap :: CoreExpr -> Bool +-- See Note [exprIsCheap] +exprIsCheap e = exprIsCheapX isCheapApp False e -------------------------------------- +-------------------- exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable] -exprIsExpandable e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = isExpandableApp v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Tick t e) | tickishCounts t = False - | otherwise = go n e - go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e - | otherwise = go n e - go n (App f e) | isRuntimeArg e = go (n+1) f && ok e - | otherwise = go n f - go _ (Case {}) = False - go _ (Let {}) = False - - -------------------------------------- -type CheapAppFun = Id -> Arity -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? - -- True mainly of data constructors, partial applications; - -- but with minor variations: - -- isWorkFreeApp - -- isCheapApp +exprIsExpandable e = exprIsCheapX isExpandableApp True e isWorkFreeApp :: CheapAppFun isWorkFreeApp fn n_val_args @@ -1627,7 +1568,7 @@ isCheapApp fn n_val_args | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] | otherwise = case idDetails fn of - DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId op _ -> primOpIsCheap op @@ -1642,6 +1583,7 @@ isExpandableApp fn n_val_args | isWorkFreeApp fn n_val_args = True | otherwise = case idDetails fn of + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId {} -> False @@ -1673,6 +1615,50 @@ isExpandableApp fn n_val_args I'm not sure why we have a special case for bottoming functions in isCheapApp. Maybe we don't need it. +Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) + Note [isExpandableApp: bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important that isExpandableApp does not respond True to bottoming @@ -1853,7 +1839,7 @@ expr_ok fun_ok primop_ok other_expr _ -> False ----------------------------- -app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool +app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool app_ok fun_ok primop_ok fun args | not (fun_ok fun) = False -- This code path is only taken for Note [Speculative evaluation] @@ -1868,13 +1854,11 @@ app_ok fun_ok primop_ok fun args -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not - DataConWorkId {} -> args_ok - -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account - -- Well, we thought so. But it's definitely wrong! - -- See #20749 and Note [How untagged pointers can - -- end up in strict fields] in GHC.Stg.InferTags + DataConWorkId dc + | isLazyDataConRep dc + -> args_ok + | otherwise + -> fields_ok (dataConRepStrictness dc) ClassOpId _ is_terminating_result | is_terminating_result -- See Note [exprOkForSpeculation and type classes] @@ -1924,7 +1908,7 @@ app_ok fun_ok primop_ok fun args -- Even if a function call itself is OK, any unlifted -- args are still evaluated eagerly and must be checked - args_ok = and (zipWith arg_ok arg_tys args) + args_ok = all2Prefix arg_ok arg_tys args arg_ok :: PiTyVarBinder -> CoreExpr -> Bool arg_ok (Named _) _ = True -- A type argument arg_ok (Anon ty _) arg -- A term argument @@ -1933,6 +1917,18 @@ app_ok fun_ok primop_ok fun args | otherwise = expr_ok fun_ok primop_ok arg + -- Used for strict DataCon worker arguments + -- See (SFC1) of Note [Strict fields in Core] + fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args + field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool + field_ok (Named _) _ _ = True + field_ok (Anon ty _) str arg + | NotMarkedStrict <- str -- iff it's a lazy field + , definitelyLiftedType (scaledThing ty) -- and its type is lifted + = True -- then the worker app does not eval + | otherwise + = expr_ok fun_ok primop_ok arg + ----------------------------- altsAreExhaustive :: [Alt b] -> Bool -- True <=> the case alternatives are definitely exhaustive @@ -2158,12 +2154,14 @@ exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding -- or PAPs. -- exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool -exprIsHNFlike is_con is_con_unf = is_hnf_like +exprIsHNFlike is_con is_con_unf e + = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $ + is_hnf_like e where is_hnf_like (Var v) -- NB: There are no value args at this point - = id_app_is_value v 0 -- Catches nullary constructors, - -- so that [] and () are values, for example - -- and (e.g.) primops that don't have unfoldings + = id_app_is_value v [] -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value -- or to a guaranteed-evaluated variable (isEvaldUnfolding) @@ -2187,7 +2185,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like -- See Note [exprIsHNF Tick] is_hnf_like (Cast e _) = is_hnf_like e is_hnf_like (App e a) - | isValArg a = app_is_value e 1 + | isValArg a = app_is_value e [a] | otherwise = is_hnf_like e is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like (Case e b _ as) @@ -2195,26 +2193,64 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like = is_hnf_like rhs is_hnf_like _ = False - -- 'n' is the number of value args to which the expression is applied - -- And n>0: there is at least one value argument - app_is_value :: CoreExpr -> Int -> Bool - app_is_value (Var f) nva = id_app_is_value f nva - app_is_value (Tick _ f) nva = app_is_value f nva - app_is_value (Cast f _) nva = app_is_value f nva - app_is_value (App f a) nva - | isValArg a = - app_is_value f (nva + 1) && - not (needsCaseBinding (exprType a) a) - -- For example f (x /# y) where f has arity two, and the first - -- argument is unboxed. This is not a value! - -- But f 34# is a value. - -- NB: Check app_is_value first, the arity check is cheaper - | otherwise = app_is_value f nva - app_is_value _ _ = False - - id_app_is_value id n_val_args - = is_con id - || idArity id > n_val_args + -- Collect arguments through Casts and Ticks and call id_app_is_value + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var f) as = id_app_is_value f as + app_is_value (Tick _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as | isValArg a = app_is_value f (a:as) + | otherwise = app_is_value f as + app_is_value _ _ = False + + id_app_is_value id val_args = + case compare (idArity id) (length val_args) of + EQ | is_con id -> -- Saturated app of a DataCon/CONLIKE Id + case mb_str_marks id of + Just str_marks -> -- with strict fields; see (SFC1) of Note [Strict fields in Core] + assert (val_args `equalLength` str_marks) $ + fields_hnf str_marks + Nothing -> -- without strict fields: like PAP + args_hnf -- NB: CONLIKEs are lazy! + + GT -> -- PAP: Check unlifted val_args + args_hnf + + _ -> False + + where + -- Saturated, Strict DataCon: Check unlifted val_args and strict fields + fields_hnf str_marks = all3Prefix check_field val_arg_tys str_marks val_args + + -- PAP: Check unlifted val_args + args_hnf = all2Prefix check_arg val_arg_tys val_args + + fun_ty = idType id + val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty) + -- val_arg_tys = map exprType val_args, but much less costly. + -- The obvious definition regresses T16577 by 30% so we don't do it. + + check_arg a_ty a + | mightBeUnliftedType a_ty = is_hnf_like a + | otherwise = True + -- Check unliftedness; for example f (x /# 12#) where f has arity two, + -- and the first argument is unboxed. This is not a value! + -- But f 34# is a value, so check args for HNFs. + -- NB: We check arity (and CONLIKEness) first because it's cheaper + -- and we reject quickly on saturated apps. + check_field a_ty str a + | mightBeUnliftedType a_ty = is_hnf_like a + | isMarkedStrict str = is_hnf_like a + | otherwise = True + -- isMarkedStrict: Respect Note [Strict fields in Core] + + mb_str_marks id + | Just dc <- isDataConWorkId_maybe id + , not (isLazyDataConRep dc) + = Just (dataConRepStrictness dc) + | otherwise + = Nothing + +{-# INLINE exprIsHNFlike #-} {- Note [exprIsHNF Tick] @@ -2776,7 +2812,7 @@ This means the seqs on x and y both become no-ops and compared to the first vers The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated. But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated -already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this. +already at the call site because of the EPT Invariant! See Note [EPT enforcement] for more in this. This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good. We only apply this when we think there is a benefit in doing so however. There are a number of cases in which @@ -2869,7 +2905,7 @@ Adding that eval was a waste of time. So don't add it for strictly-demanded Ids 5) Functions -Functions are tricky (see Note [TagInfo of functions] in InferTags). +Functions are tricky (see Note [TagInfo of functions] in EnforceEpt). But the gist of it even if we make a higher order function argument strict we can't avoid the tag check when it's used later in the body. So there is no benefit. @@ -2901,7 +2937,7 @@ wantCbvForId cbv_for_strict v -- See Note [Which Ids should be strictified] point 2) , mightBeLiftedType ty -- Functions sometimes get a zero tag so we can't eliminate the tag check. - -- See Note [TagInfo of functions] in InferTags. + -- See Note [TagInfo of functions] in EnforceEpt. -- See Note [Which Ids should be strictified] point 5) , not $ isFunTy ty -- If the var is strict already a seq is redundant. diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 8de576065acc69772c1ee4189ca812568a59f6c3..785d79cc060bfea9bb25ebbff5c2409fa27bdf40 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -915,6 +915,7 @@ cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut ; (env', bndr2) <- cpCloneBndr env bndr + ; let bndr3 = bndr2 `setIdUnfolding` evaldUnfolding ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env -- Suppose the alternatives do not cover all the data constructors of the type. @@ -930,9 +931,9 @@ cpeRhsE env (Case scrut bndr ty alts) ; case alts'' of [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] - | let float = mkCaseFloat bndr2 scrut' + | let float = mkCaseFloat bndr3 scrut' -> return (snocFloat floats float, rhs) - _ -> return (floats, Case scrut' bndr2 (cpSubstTy env ty) alts'') } + _ -> return (floats, Case scrut' bndr3 (cpSubstTy env ty) alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -1167,7 +1168,7 @@ cpeApp top_env expr -- allocating CaseBound Floats for token and thing as needed = do { (floats1, token) <- cpeArg env topDmd token ; (floats2, thing) <- cpeBody env thing - ; case_bndr <- newVar ty + ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar ty ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] ; let float = mkCaseFloat case_bndr thing ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) } @@ -1872,10 +1873,7 @@ and the above footwork in cpsRhsE avoids generating a nested case. Note [Pin evaluatedness on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When creating a new float `sat=e` in `mkNonRecFloat`, we propagate `sat` with an -`evaldUnfolding` if either - - 1. `e` is a value, or - 2. `sat=e` is case-bound, but won't float to top-level. +`evaldUnfolding` if `e` is a value. To see why, consider a call to a CBV function, such as a DataCon worker with *strict* fields, in an argument context, such as @@ -1883,63 +1881,33 @@ To see why, consider a call to a CBV function, such as a DataCon worker with data Box a = Box !a ... f (Box e) ... -During ANFisation, we will `mkNonRecFloat` for `e`, binding it to a -fresh binder `sat=e`, and binding `sat2=Box sat` to a fresh `sat2` as well. - -In principle, we want to realise these floats with as few thunks as possible. -There are two interesting cases where that is possible, corresponding to when we -pin an `evaldUnfolding`: - - 1. When `f` is *lazy* and `e` is ok-for-spec, e.g. `e = I# (x +# 1#)`, we want - to get the very nice code - - case x +# 1# of x' -> - let sat = I# x' in - let sat2 = Box sat in - f sat2 - - Note that Case (2) of Note [wantFloatLocal] is in effect. That is, - * x' is unlifted but ok-for-spec, hence floated out of the lazy arg of f - * Since x' is unlifted, `I# x'` is a value, and so `sat` can be let-bound. - * Since `sat` is a value, `Box sat` is a value as well, and so `sat2` can - be let-bound. - Hence no thunk needs to be allocated! However, in order to recognise - `Box sat` as a value, it is crucial that the newly created `sat` has an - `evaldUnfolding`; otherwise the strict worker `Box` forces an eval on `sat`. - and we would get the far worse code - - let sat2 = - case x +# 1# of x' -> - case I# x' of sat' -> - Box sat in - f sat2 - - A live example of this is T24730, inspired by $walexGetByte. +where `f` is *lazy* and `e` is ok-for-spec, e.g. `e = I# (x +# 1#)`. +After ANFisation, we want to get the very nice code - 2. `f` is strict and `e` is not a value, we want to get + case x +# 1# of x' -> + let sat = I# x' in + let sat2 = Box sat in + f sat2 - case e of sat -> - let sat2 = Box sat in - f sat2 +Note that Case (2) of Note [wantFloatLocal] is in effect. That is, - But `sat2` will not be let-bound unless `sat` has an `evaldUnfolding`; which - it clearly deserves given that it is a case binder. - Otherwise, we get + * x' is unlifted but ok-for-spec, hence floated out of the lazy arg of f + * Since x' is unlifted, `I# x'` is a value, and so `sat` can be let-bound. + * Since `sat` is a value, `Box sat` is a value as well, and so `sat2` can + be let-bound. - case e of sat -> - case Box sat of sat2 -> - f sat2 +Hence no thunk needs to be allocated! However, in order to recognise +`Box sat` as a value, it is crucial that the newly created `sat` has an +`evaldUnfolding`; otherwise the strict worker `Box` forces an eval on `sat`. +and we would get the far worse code - which is far harder to parse; furthermore it is unclear whether `Box sat` is - ok-for-spec. - This happened in GHC.Linker.Deps.$wgetLinkDeps. + let sat2 = + case x +# 1# of x' -> + case I# x' of sat' -> + Box sat in + f sat2 - Small wrinkle: - It could be that `sat` floats to top-level, where it is not eagerly - evaluated. In this case, we may not give `sat` an `evaldUnfolding`. - We detect this case by looking at the `FloatInfo` of `sat`: If it says - `TopLvlFloatable`, we are conservative and will not give `sat` an - `evaldUnfolding`. +A live example of this is T24730, inspired by $walexGetByte. Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2227,6 +2195,7 @@ data FloatInfoArgs { fia_levity :: Levity , fia_demand :: Demand , fia_is_hnf :: Bool + , fia_is_triv :: Bool , fia_is_string :: Bool , fia_is_dc_worker :: Bool , fia_ok_for_spec :: Bool @@ -2238,6 +2207,7 @@ defFloatInfoArgs bndr rhs { fia_levity = typeLevity (idType bndr) , fia_demand = idDemandInfo bndr -- mkCaseFloat uses evalDmd , fia_is_hnf = exprIsHNF rhs + , fia_is_triv = exprIsTrivial rhs , fia_is_string = exprIsTickedString rhs , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval @@ -2245,28 +2215,30 @@ defFloatInfoArgs bndr rhs decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo) decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, - fia_is_string=is_string, fia_is_dc_worker=is_dc_worker, - fia_ok_for_spec=ok_for_spec} - | Lifted <- lev, is_hnf = (LetBound, TopLvlFloatable) + fia_is_triv=is_triv, fia_is_string=is_string, + fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec} + | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs -- (but SG thinks that in principle, we should) - | is_dc_worker = (LetBound, TopLvlFloatable) + -- is_triv: Should not turn `case x of x' ->` into `let x' = x` + -- when x is a HNF (cf. fun3 of T24264) + | is_dc_worker = (LetBound, TopLvlFloatable) -- We need this special case for nullary unlifted DataCon -- workers/wrappers (top-level bindings) until #17521 is fixed - | is_string = (CaseBound, TopLvlFloatable) + | is_string = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level - | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable - Lifted -> TopLvlFloatable) + | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable + Lifted -> TopLvlFloatable) -- See Note [Speculative evaluation] -- Ok-for-spec-eval things will be case-bound, lifted or not. -- But when it's lifted we are ok with floating it to top-level -- (where it is actually bound lazily). - | Unlifted <- lev = (CaseBound, StrictContextFloatable) - | isStrUsedDmd dmd = (CaseBound, StrictContextFloatable) + | Unlifted <- lev = (CaseBound, StrictContextFloatable) + | isStrUsedDmd dmd = (CaseBound, StrictContextFloatable) -- These will never be floated out of a lazy RHS context - | Lifted <- lev = (LetBound, TopLvlFloatable) + | Lifted <- lev = (LetBound, TopLvlFloatable) -- And these float freely but can't be speculated, hence LetBound mkCaseFloat :: Id -> CpeRhs -> FloatingBind @@ -2307,8 +2279,7 @@ mkNonRecFloat env lev bndr rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) -- See Note [Pin evaluatedness on floats] - evald = is_hnf --- || (bound == CaseBound && info /= TopLvlFloatable) - bndr' | evald = bndr `setIdUnfolding` evaldUnfolding + bndr' | is_hnf = bndr `setIdUnfolding` evaldUnfolding | otherwise = bndr -- | Wrap floats around an expression diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 8f18509eaf2ddcced1f34ad97fe3dd0b74535e13..ed3f606fa74d48400e3a4125c3e0e21dfb7f134e 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -295,7 +295,7 @@ import Data.Time import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) -import GHC.Stg.InferTags.TagSig (seqTagSig) +import GHC.Stg.EnforceEpt.TagSig (seqTagSig) import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index e0fe5d1657af733f9e9b3fc84252be520b472006..244b11fd011ceb014bddeae6249385b36198e7b8 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -21,7 +21,7 @@ import GHC.Prelude import GHC.Hs -import GHC.Stg.InferTags.TagSig (StgCgInfos) +import GHC.Stg.EnforceEpt.TagSig (StgCgInfos) import GHC.StgToCmm.Types (CmmCgInfos (..)) import GHC.Tc.Utils.TcType diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index e6334d3283d4b5afa5da8637333ba50e21c17369..977547c614d39a03d4c2fbc41a1830a4e73e80cf 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -80,7 +80,7 @@ import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) -import GHC.Stg.InferTags.TagSig +import GHC.Stg.EnforceEpt.TagSig import GHC.Parser.Annotation (noLocA) import GHC.Hs.Extension ( GhcRn ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/EnforceEpt.hs similarity index 75% rename from compiler/GHC/Stg/InferTags.hs rename to compiler/GHC/Stg/EnforceEpt.hs index 81092587a7b34eb51d92707ae1918d94c54d9470..b2bdcafb22fbaa78bb7440fd1946a5bca4122f14 100644 --- a/compiler/GHC/Stg/InferTags.hs +++ b/compiler/GHC/Stg/EnforceEpt.hs @@ -5,7 +5,7 @@ -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass {-# OPTIONS_GHC -Wname-shadowing #-} -module GHC.Stg.InferTags ( inferTags ) where +module GHC.Stg.EnforceEpt ( enforceEpt ) where import GHC.Prelude hiding (id) @@ -24,31 +24,112 @@ import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) -import GHC.Stg.InferTags.Types -import GHC.Stg.InferTags.Rewrite (rewriteTopBinds) +import GHC.Stg.EnforceEpt.Types +import GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds) import Data.Maybe import GHC.Types.Name.Env (mkNameEnv, NameEnv) import GHC.Driver.DynFlags import GHC.Utils.Logger import qualified GHC.Unit.Types -{- Note [Tag Inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The purpose of this pass is to attach to every binder a flag -to indicate whether or not it is "properly tagged". A binder -is properly tagged if it is guaranteed: - - to point to a heap-allocated *value* - - and to have the tag of the value encoded in the pointer - -For example - let x = Just y in ... - -Here x will be properly tagged: it will point to the heap-allocated -values for (Just y), and the tag-bits of the pointer will encode -the tag for Just so there is no need to re-enter the closure or even -check for the presence of tag bits. The impacts of this can be very large. - -For containers the reduction in runtimes with this optimization was as follows: +{- Note [Evaluated and Properly Tagged] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A pointer is Evaluated and Properly Tagged (EPT) when the pointer + + (a) points directly to the value, and + (b) is tagged with the tag corresponding to said value (e.g. constructor tag). + +A binder is EPT when all the runtime pointers it binds are EPT. + +Note that a lifted EPT pointer will never point to a thunk, nor will it be +tagged `000` (meaning "might be a thunk"). + +Examples: +* Case binders are always EPT; hence an eval + case x of x' { __DEFAULT -> ... } + ensures that x' is EPT even if x was not. +* Data constructor bindings + let x = Just y in ... + are EPT: x will point to the heap-allocated constructor closure for (Just y), + and the tag-bits of the pointer will encode the tag for Just (i.e. `010`). + +Caveat: +Currently, the proper tag for builtin *unlifted* data types such as `Array#` is +not `001` but `000`, which is not a proper tag for lifted data. +This means that UnliftedRep is not a proper sub-rep of LiftedRep. +SG thinks it would be good to fix this; see #21792. + +Note [EPT enforcement] +~~~~~~~~~~~~~~~~~~~~~~ +The goal of EPT enforcement is to mark as many binders as possible as EPT +(see Note [Evaluated and Properly Tagged]). +To find more EPT binders, it establishes the following + +EPT INVARIANT: +> Any binder of a strict field or a strict worker argument is EPT. + +(Note that prior to EPT enforcement, this invariant may *not* always be upheld. +An example can be found at the end of this Note.) +This is all to optimise code such as the following: + + data SPair a b = SP !a !b + case p :: SP Bool Bool of + SP x y -> + case x of + True -> ... + False -> ... + +We can infer that the strict field x is EPT and hence may safely +omit the code to enter x and the check for the presence of a tag that goes along +with it. However we still branch on the tag as usual to jump to the True or +False case. + +Note that for every example involving strict fields we could find a similar +example using strict worker functions (see Note [CBV Function Ids]), e.g. + + $wf x[EPT] y = + case x of + True -> ... + False -> ... + +is the above example translated to use a strict worker function. + +Implementation +-------------- +EPT enforcement encompasses an analysis as well as a transformation. +* EPT analysis infers which binders are EPT, attaching the result to /binders/. + This is implemented in GHC.Stg.EnforceEpt.inferTags. + Crucially, the analysis assumes that the EPT invariant defined above is in + effect, because it improves the precision of the analysis quite significantly. +* The EPT rewriter establishes the EPT invariant. That is, if + (a) a binder x is used to + * construct a strict field (`SP x y`), or + * passed as a strict worker argument (`$wf x`), + and + (b) x was not inferred EPT, + then the EPT rewriter inserts an eval prior to the call, e.g. + case x of x' { __ DEFAULT -> SP x' y }. + case x of x' { __ DEFAULT -> $wf x' }. + (Recall that the case binder x' is always EPT.) + This is implemented in GHC.Stg.EnforceEpt.Rewrite.rewriteTopBinds. + This pass also propagates the EPTness from binders to occurrences. + It is sound to insert evals on strict fields (Note [Strict fields in Core]), + and on strict worker arguments as well (Note [CBV Function Ids]). +* We also export the tag sigs of top level bindings to allow this optimisation + to work across module boundaries. + NB: Note that the EPT Invariant *must* be upheld, regardless of the + optimisation level; hence the tag sig is practically part of the internal ABI + of a strict data constructor or strict worker function. + Note [CBV Function Ids] contains the details. + +Finally, code generation skips the thunk check when branching on binders that +are EPT. This is done by `cgExpr`/`cgCase` in the backend. + +Evaluation +---------- +EPT enforcement can have large impact on spine-strict tree data structure +performance. For containers the reduction in runtimes with this optimization +was as follows: intmap-benchmarks: 89.30% intset-benchmarks: 90.87% @@ -63,78 +144,48 @@ lookupge-map: 70.95% With nofib being ~0.3% faster as well. -See Note [Tag inference passes] for how we proceed to generate and use this information. - -Note [Strict Field Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As part of tag inference we introduce the Strict Field Invariant. -Which consists of us saying that: - -* Pointers in strict fields must (a) point directly to the value, and - (b) must be properly tagged. - -For example, given - data T = MkT ![Int] - -the Strict Field Invariant guarantees that the first field of any `MkT` constructor -will either point directly to nil, or directly to a cons cell; -and will be tagged with `001` or `010` respectively. -It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk"). -NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs. - -This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids]. - -Why do we care? Because if we have code like: +Note that EPT enforcement may cause regressions in rare cases. +For example consider this code: -case strictPair of - SP x y -> - case x of ... + foo x = ... + let c = StrictJust x + in ... -It allows us to safely omit the code to enter x and the check -for the presence of a tag that goes along with it. -However we might still branch on the tag as usual. -See Note [Tag Inference] for how much impact this can have for -some code. +When x cannot be inferred EPT, the rewriter transforms to -This is enforced by the code GHC.Stg.InferTags.Rewrite -where we: + foo x = ... + let c = case x of x' -> StrictJust x' + in ... -* Look at all constructor allocations. -* Check if arguments to their strict fields are known to be properly tagged -* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'` +which allocates an additional thunk for `c` that returns the constructor. Boo! +This could be fixed by replicating the floating capabilities of CorePrep, but +that is a large price to pay for curing such a rare regression. -This is usually very beneficial but can cause regressions in rare edge cases where -we fail to proof that x is properly tagged, or where it simply isn't. -See Note [How untagged pointers can end up in strict fields] for how the second case -can arise. +Note [EPT enforcement lowers strict constructor worker semantics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, a saturated application of a strict constructor worker evaluates its +strict fields and thus is *not* a value; see Note [Strict fields in Core]. +This is also the semantics of strict constructor workers in STG *before* EPT +enforcement (see Note [EPT enforcement]) -For a full example of the worst case consider this code: +However, after enforcing the EPT Invariant, all constructor workers can +effectively be lazy. That is because the EPT rewriter arranges that only EPT +arguments go into strict fields, and an eval on EPT things is a no-op. -foo ... = ... - let c = StrictJust x - in ... +Thus for code-gen reasons (StgToX), all constructor workers are considered lazy +after EPT enforcement. -Here we would rewrite `let c = StrictJust x` into `let c = case x of x' -> StrictJust x'` -However that is horrible! We end up allocating a thunk for `c` first, which only when -evaluated will allocate the constructor. +Note [Why isn't the EPT Invariant enforced during Core passes?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall the definition of the EPT Invariant from Note [EPT enforcement]. +Why can't it be established as an invariant right while desugaring to Core? +The reason is that some Core optimisations, such as FloatOut, will drop or delay +evals whenever they think it useful and thus destroy the Invariant. Example: -So we do our best to establish that `x` is already tagged (which it almost always is) -to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions. - -Note that there are similar constraints around Note [CBV Function Ids]. - -Note [How untagged pointers can end up in strict fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider data Set a = Tip | Bin !a (Set a) (Set a) -We make a wrapper for Bin that evaluates its arguments - $WBin x a b = case x of xv -> Bin xv a b -Here `xv` will always be evaluated and properly tagged, just as the -Strict Field Invariant requires. - -But alas the Simplifier can destroy the invariant: see #15696. We start with + thk = f () g x = ...(case thk of xv -> Bin xv Tip Tip)... @@ -153,29 +204,13 @@ indeed it does! We float the Bin to top level: Now you can see that the argument of Bin, namely thk, points to the thunk, not to the value as it did before. -In short, although it may be rare, the output of optimisation passes -cannot guarantee to obey the Strict Field Invariant. For this reason -we run tag inference. See Note [Tag inference passes]. - -Note [Tag inference passes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tag inference proceeds in two passes: -* The first pass is an analysis to compute which binders are properly tagged. - The result is then attached to /binders/. - This is implemented by `inferTagsAnal` in GHC.Stg.InferTags -* The second pass walks over the AST checking if the Strict Field Invariant is upheld. - See Note [Strict Field Invariant]. - If required this pass modifies the program to uphold this invariant. - Tag information is also moved from /binders/ to /occurrences/ during this pass. - This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`. -* Finally the code generation uses this information to skip the thunk check when branching on - values. This is done by `cgExpr`/`cgCase` in the backend. - -Last but not least we also export the tag sigs of top level bindings to allow this optimization - to work across module boundaries. - -Note [TagInfo of functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In short, although it may be rare, the output of Core optimisation passes +might destroy the EPT Invariant, hence we need to enforce the EPT invariant +*after* passes such as FloatOut. +-} + +{- Note [TagInfo of functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The purpose of tag inference is really to figure out when we don't have to enter value closures. There the meaning of the tag is fairly obvious. For functions we never make use of the tag info so we have two choices: @@ -189,10 +224,10 @@ why we couldn't be more rigorous in dealing with functions. NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions. So option two isn't really an option without reworking this anyway. -Note [Tag inference debugging] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [EPT enforcement debugging] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is a flag -dtag-inference-checks which inserts various -compile/runtime checks in order to ensure the Strict Field Invariant +compile/runtime checks in order to ensure the EPT Invariant holds. It should cover all places where tags matter and disable optimizations which interfere with checking the invariant like generation of AP-Thunks. @@ -205,8 +240,8 @@ a different StgPass! To handle this a large part of the analysis is polymorphic over the exact StgPass we are using. Which allows us to run the analysis on the output of itself. -Note [Tag inference for interpreted code] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [EPT enforcement for interpreted code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The bytecode interpreter has a different behaviour when it comes to the tagging of binders in certain situations than the StgToCmm code generator. @@ -229,30 +264,30 @@ b) When referencing ids from other modules the Cmm backend will try to put a usually predict these cases to improve precision of the analysis. But to my knowledge the bytecode generator makes no such attempts so we must not infer imported bindings as tagged. - This is handled in GHC.Stg.InferTags.Types.lookupInfo + This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo -} {- ********************************************************************* * * - Tag inference pass + EPT enforcement pass * * ********************************************************************* -} -inferTags :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) -inferTags ppr_opts !for_bytecode logger this_mod stg_binds = do - -- pprTraceM "inferTags for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode) +enforceEpt :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) +enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do + -- pprTraceM "enforceEpt for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode) -- Annotate binders with tag information. - let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-} - inferTagsAnal for_bytecode stg_binds + let (!stg_binds_w_tags) = {-# SCC "StgEptInfer" #-} + inferTags for_bytecode stg_binds putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags) let export_tag_info = collectExportInfo stg_binds_w_tags -- Rewrite STG to uphold the strict field invariant us_t <- mkSplitUniqSupply 't' - let rewritten_binds = {-# SCC "StgTagRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] + let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] return (rewritten_binds,export_tag_info) @@ -274,8 +309,8 @@ type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders) -inferTagsAnal :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] -inferTagsAnal for_bytecode binds = +inferTags :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] +inferTags for_bytecode binds = -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds) @@ -561,7 +596,7 @@ inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ) (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ) -- Adjust let semantics to the targeted backend. --- See Note [Tag inference for interpreted code] +-- See Note [EPT enforcement for interpreted code] mkLetSig :: TagEnv p -> TagSig -> TagSig mkLetSig env in_sig | for_bytecode = TagSig TagDunno diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/EnforceEpt/Rewrite.hs similarity index 98% rename from compiler/GHC/Stg/InferTags/Rewrite.hs rename to compiler/GHC/Stg/EnforceEpt/Rewrite.hs index 7a0b63ffc1e86f97722db43e527a1e61aab7d995..a1a0dbd292bb9f89d6f7397b0f0ea6a0fdef72aa 100644 --- a/compiler/GHC/Stg/InferTags/Rewrite.hs +++ b/compiler/GHC/Stg/EnforceEpt/Rewrite.hs @@ -7,7 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} -module GHC.Stg.InferTags.Rewrite (rewriteTopBinds, rewriteOpApp) +module GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds, rewriteOpApp) where import GHC.Prelude @@ -40,7 +40,7 @@ import GHC.Utils.Outputable import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc -import GHC.Stg.InferTags.Types +import GHC.Stg.EnforceEpt.Types import Control.Monad @@ -57,7 +57,7 @@ The work of this pass is simple: * For any strict field we check if the argument is known to be properly tagged. * If it's not known to be properly tagged, we wrap the whole thing in a case, which will force the argument before allocation. -This is described in detail in Note [Strict Field Invariant]. +This is described in detail in Note [Evaluated and Properly Tagged]. The only slight complication is that we have to make sure not to invalidate free variable analysis in the process. @@ -210,7 +210,7 @@ When compiling bytecode we call myCoreToStg to get STG code first. myCoreToStg in turn calls out to stg2stg which runs the STG to STG passes followed by free variables analysis and the tag inference pass including its rewriting phase at the end. -Running tag inference is important as it upholds Note [Strict Field Invariant]. +Running tag inference is important as it upholds Note [Evaluated and Properly Tagged]. While code executed by GHCi doesn't take advantage of the SFI it can call into compiled code which does. So it must still make sure that the SFI is upheld. See also #21083 and #22042. diff --git a/compiler/GHC/Stg/InferTags/TagSig.hs b/compiler/GHC/Stg/EnforceEpt/TagSig.hs similarity index 95% rename from compiler/GHC/Stg/InferTags/TagSig.hs rename to compiler/GHC/Stg/EnforceEpt/TagSig.hs index 11697ba9db0e5b68eed60458ce937fc2c39e5069..85122a3f7bb911994743b9d4346beec305128471 100644 --- a/compiler/GHC/Stg/InferTags/TagSig.hs +++ b/compiler/GHC/Stg/EnforceEpt/TagSig.hs @@ -2,11 +2,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} --- We export this type from this module instead of GHC.Stg.InferTags.Types +-- We export this type from this module instead of GHC.Stg.EnforceEpt.Types -- because it's used by more than the analysis itself. For example in interface -- files where we record a tag signature for bindings. -- By putting the sig into its own module we can avoid module loops. -module GHC.Stg.InferTags.TagSig +module GHC.Stg.EnforceEpt.TagSig where diff --git a/compiler/GHC/Stg/InferTags/Types.hs b/compiler/GHC/Stg/EnforceEpt/Types.hs similarity index 97% rename from compiler/GHC/Stg/InferTags/Types.hs rename to compiler/GHC/Stg/EnforceEpt/Types.hs index 11ac33cc5bfce557f1ec60aa997b44f0b6eb8139..40dd93f2edba3af68d9421dd410b51d14e1ab20e 100644 --- a/compiler/GHC/Stg/InferTags/Types.hs +++ b/compiler/GHC/Stg/EnforceEpt/Types.hs @@ -5,8 +5,8 @@ {-# LANGUAGE UndecidableInstances #-} -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen -module GHC.Stg.InferTags.Types - ( module GHC.Stg.InferTags.Types +module GHC.Stg.EnforceEpt.Types + ( module GHC.Stg.EnforceEpt.Types , module TagSig) where @@ -16,7 +16,7 @@ import GHC.Core.DataCon import GHC.Core.Type (isUnliftedType) import GHC.Types.Id import GHC.Stg.Syntax -import GHC.Stg.InferTags.TagSig as TagSig +import GHC.Stg.EnforceEpt.TagSig as TagSig import GHC.Types.Var.Env import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual ) diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index 587b9e30532e7a3717e855faff7529949c4b0a50..f5bf21354eaed2b547877106fbe2c4b7ac39f4f8 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -41,8 +41,8 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader import GHC.Settings (Platform) -import GHC.Stg.InferTags (inferTags) -import GHC.Stg.InferTags.TagSig ( StgCgInfos ) +import GHC.Stg.EnforceEpt (enforceEpt) +import GHC.Stg.EnforceEpt.TagSig ( StgCgInfos ) data StgPipelineOpts = StgPipelineOpts { stgPipeline_phases :: ![StgToDo] @@ -92,7 +92,7 @@ stg2stg logger extra_vars opts this_mod binds -- annotations (which is used by code generator to compute offsets into closures) ; let (binds_sorted_with_fvs, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds') -- See Note [Tag inference for interactive contexts] - ; (cg_binds, cg_infos) <- inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs + ; (cg_binds, cg_infos) <- enforceEpt (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs ; stg_linter False "StgCodeGen" cg_binds ; pure (zip cg_binds imp_fvs, cg_infos) } diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 33087dea30b2243613e789459d88b6af66e0efdd..db8a3b98b472d474195d337392a7ddc4fb607bc3 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -73,7 +73,7 @@ module GHC.Stg.Syntax ( import GHC.Prelude -import GHC.Stg.InferTags.TagSig( TagSig ) +import GHC.Stg.EnforceEpt.TagSig( TagSig ) import GHC.Stg.Lift.Types -- To avoid having an orphan instances for BinderP, XLet etc @@ -659,9 +659,9 @@ StgPass data type indexes: each binding. See Note [Late lambda lifting in STG]. - 4. Tag inference takes in 'Vanilla and produces 'InferTagged STG, while using + 4. EPT enforcement takes in 'Vanilla and produces 'InferTagged STG, while using the InferTaggedBinders annotated AST internally. - See Note [Tag Inference]. + See Note [EPT enforcement]. 5. Stg.FVs annotates closures with their free variables. To store these annotations we use the 'CodeGen parameterisation. @@ -676,9 +676,9 @@ data StgPass = Vanilla | LiftLams -- ^ Use internally by the lambda lifting pass | InferTaggedBinders -- ^ Tag inference information on binders. - -- See Note [Tag inference passes] in GHC.Stg.InferTags + -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt | InferTagged -- ^ Tag inference information put on relevant StgApp nodes - -- See Note [Tag inference passes] in GHC.Stg.InferTags + -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt | CodeGen type family BinderP (pass :: StgPass) diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index b667008b83f539513d08e7f93ff7dcd0a1a60b33..ba2f445ff7be1d3999fcb33a333840dac8949061 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -391,7 +391,7 @@ mkRhsClosure profile use_std_ap check_tags bndr _cc -- thunk (e.g. its type) (#949) , idArity fun_id == unknownArity -- don't spoil a known call -- Ha! an Ap thunk - , not check_tags -- See Note [Tag inference debugging] + , not check_tags -- See Note [EPT enforcement debugging] = cgRhsStdThunk bndr lf_info payload where diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 93602825fc2d7bcf97a269be87857543fbb4dd9b..4bbbba46019bad627fcacadc15ef023ffa5cee2c 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -98,7 +98,7 @@ import GHC.Data.Maybe (isNothing) import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 import GHC.StgToCmm.Config -import GHC.Stg.InferTags.TagSig (isTaggedSig) +import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) ----------------------------------------------------------------------------- -- Data types and synonyms @@ -508,8 +508,8 @@ data CallMethod -- or constructor), so just return it. | InferedReturnIt -- A properly tagged value, as determined by tag inference. - -- See Note [Tag Inference] and Note [Tag inference passes] in - -- GHC.Stg.InferTags. + -- See Note [Evaluated and Properly Tagged] + -- and Note [EPT enforcement] in GHC.Stg.EnforceEpt. -- It behaves /precisely/ like `ReturnIt`, except that when debugging is -- enabled we emit an extra assertion to check that the returned value is -- properly tagged. We can use this as a check that tag inference is working @@ -583,8 +583,8 @@ getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) n_args _cg_loc _self_loop_info | Just sig <- idTagSig_maybe id - , isTaggedSig sig -- Infered to be already evaluated by Tag Inference - , n_args == 0 -- See Note [Tag Inference] + , isTaggedSig sig -- Infered to be already evaluated by EPT analysis + , n_args == 0 -- See Note [EPT enforcement] = InferedReturnIt | is_fun -- it *might* be a function, so we must "call" it (which is always safe) @@ -621,12 +621,12 @@ getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info | n_args == 0 , Just sig <- idTagSig_maybe id - , isTaggedSig sig -- Infered to be already evaluated by Tag Inference + , isTaggedSig sig -- Infered to be already evaluated by EPT analysis -- When profiling we must enter all potential functions to make sure we update the SCC -- even if the function itself is already evaluated. -- See Note [Evaluating functions with profiling] in rts/Apply.cmm , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function) - = InferedReturnIt -- See Note [Tag Inference] + = InferedReturnIt -- See Note [EPT enforcement] | might_be_a_function = SlowCall diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index e0b2c81702b0b1a52779706d73a4518687177e31..504024fc491af731f71da93f48a8aa52e1342041 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -56,7 +56,7 @@ import GHC.Utils.Panic import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List ( partition ) -import GHC.Stg.InferTags.TagSig (isTaggedSig) +import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) import GHC.Platform.Profile (profileIsProfiling) ------------------------------------------------------------------------ diff --git a/compiler/GHC/StgToJS/ExprCtx.hs b/compiler/GHC/StgToJS/ExprCtx.hs index 0df2cdf5f6cdd16459da6026b083474ebd16aa29..45fd8bd60296c690bf2ce152707867a8ad583780 100644 --- a/compiler/GHC/StgToJS/ExprCtx.hs +++ b/compiler/GHC/StgToJS/ExprCtx.hs @@ -46,7 +46,7 @@ import GHC.Types.SrcLoc import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Stg.InferTags.TagSig +import GHC.Stg.EnforceEpt.TagSig import GHC.Utils.Outputable import GHC.Utils.Panic diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 27366faa721b0bede87b4fb5ece7c16317b43185..754d08886432c9e27f22267759b233f47a03a09a 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -724,7 +724,7 @@ H2. The simplifier rewrites most case expressions scrutinizing their results. H3. Each evaluates its argument. But we want to omit this eval when the actual argument is already evaluated and properly tagged. To do this, - * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + * We have a special case in GHC.Stg.EnforceEpt.Rewrite.rewriteOpApp ensuring that any inferred tag information on the argument is retained until code generation. @@ -884,8 +884,8 @@ mostly relating to under what circumstances it evaluates its argument. Today, that story is simple: A dataToTag primop always evaluates its argument, unless tag inference determines the argument was already evaluated and correctly tagged. Getting here was a long journey, with -many similarities to the story behind Note [Strict Field Invariant] in -GHC.Stg.InferTags. See also #15696. +many similarities to the story behind Note [Evaluated and Properly Tagged] in +GHC.Stg.EnforceEpt. See also #15696. -} diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index 92517a45dae152d9b91560b7c2e001c44e133725..ba0a742593380094fadb1bebfd5962e2214f7a13 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -183,14 +183,15 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs tag = lookupNameEnv_NF tag_map src_name -- See Note [Constructor tag allocation], fixes #14657 data_con = mkDataCon src_name declared_infix prom_info - src_bangs field_lbls + src_bangs impl_bangs str_marks field_lbls univ_tvs ex_tvs noConcreteTyVars user_tvbs eq_spec ctxt arg_tys res_ty NoPromInfo rep_tycon tag stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) + (dc_rep, impl_bangs, str_marks) = + initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) ; traceIf (text "buildDataCon 2" <+> ppr src_name) ; return data_con } diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 013d337227fad464219bad6586206c33b10a8ab2..7fd0dbac5789e997196896012bd09885f903cbaf 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -1403,33 +1403,16 @@ arguments. That is the job of dmdTransformDataConSig. More precisely, * it returns the demands on the arguments; in the above example that is [SL, A] -Nasty wrinkle. Consider this code (#22475 has more realistic examples but -assume this is what the demand analyser sees) - - data T = MkT !Int Bool - get :: T -> Bool - get (MkT _ b) = b - - foo = let v::Int = I# 7 - t::T = MkT v True - in get t - -Now `v` is unused by `get`, /but/ we can't give `v` an Absent demand, -else we'll drop the binding and replace it with an error thunk. -Then the code generator (more specifically GHC.Stg.InferTags.Rewrite) -will add an extra eval of MkT's argument to give - foo = let v::Int = error "absent" - t::T = case v of v' -> MkT v' True - in get t - -Boo! Because of this extra eval (added in STG-land), the truth is that `MkT` -may (or may not) evaluate its arguments (as established in #21497). Hence the -use of `bump` in dmdTransformDataConSig, which adds in a `C_01` eval. The -`C_01` says "may or may not evaluate" which is absolutely faithful to what -InferTags.Rewrite does. - -In particular it is very important /not/ to make that a `C_11` eval, -see Note [Data-con worker strictness]. +When the data constructor worker has strict fields, an additional seq +will be inserted for each field (see (SFC3) in Note [Strict fields in Core]). +Hence we add an additional `seqDmd` for each strict field to emulate +field eval insertion. + +For example, consider `data SP a b = MkSP !a !b` and expression `MkSP x y`, +with the same sub-demand P(SL,A). +The strict fields bump up the strictness; we'd get [SL,1!A] for the field +demands. Note that the first demand was unaffected by the seq, whereas +the second, previously absent demand became `seqDmd` exactly. -} {- ********************************************************************* @@ -1629,6 +1612,29 @@ a bad fit because expression may not throw a precise exception (increasing precision of the analysis), but that's just a favourable guess. +Note [Side-effects and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Due to historic reasons and the continued effort not to cause performance +regressions downstream, Strictness Analysis is currently prone to discarding +observable side-effects (other than precise exceptions, see +Note [Precise exceptions and strictness analysis]) in some cases. For example, + f :: MVar () -> Int -> IO Int + f mv x = putMVar mv () >> (x `seq` return x) +The call to `putMVar` is an observable side-effect. Yet, Strictness Analysis +currently concludes that `f` is strict in `x` and uses call-by-value. +That means `f mv (error "boom")` will error out with the imprecise exception +rather performing the side-effect. + +This is a conscious violation of the semantics described in the paper +"a semantics for imprecise exceptions"; so it would be great if we could +identify the offending primops and extend the idea in +Note [Which scrutinees may throw precise exceptions] to general side-effects. + +Unfortunately, the existing has-side-effects classification for primops is +too conservative, listing `writeMutVar#` and even `readMutVar#` as +side-effecting. That is due to #3207. A possible way forward is described in +#17900, but no effort has been so far towards a resolution. + Note [Exceptions and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to smart about catching exceptions, but we aren't anymore. @@ -2410,7 +2416,8 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of 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] + str_field_dmd = seqDmd -- See the bit about strict fields + -- in Note [Demand transformer for data constructors] -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated). diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index d639a9fea70ae590f1bb5c84f86af29168478bef..42fb6ca35a17c0d0f6c0806d5082b454fac58ea7 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -159,7 +159,7 @@ import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Types.Unique -import GHC.Stg.InferTags.TagSig +import GHC.Stg.EnforceEpt.TagSig import GHC.Unit.Module import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 5db6524d25643330e3be8d260aebb14585429fc2..fe6686364334484fe71b62b37caea2d00a2af075 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -111,7 +111,7 @@ import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars, noConcreteTyVars ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Stg.InferTags.TagSig +import GHC.Stg.EnforceEpt.TagSig import GHC.StgToCmm.Types (LambdaFormInfo) import Data.Data ( Data ) @@ -220,7 +220,7 @@ data IdDetails -- Worker like functions are create by W/W and SpecConstr and we can expect that they -- aren't used unapplied. -- See Note [CBV Function Ids] - -- See Note [Tag Inference] + -- See Note [EPT enforcement] -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current -- module. @@ -234,14 +234,14 @@ idDetailsConcreteTvs = \ case {- Note [CBV Function Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~ A WorkerLikeId essentially allows us to constrain the calling convention for the given Id. Each such Id carries with it a list of CbvMarks with each element representing a value argument. Arguments who have a matching `MarkedCbv` entry in the list need to be passed evaluated+*properly tagged*. CallByValueFunIds give us additional expressiveness which we use to improve -runtime. This is all part of the TagInference work. See also Note [Tag Inference]. +runtime. This is all part of the EPT enforcement work. See also Note [EPT enforcement]. They allows us to express the fact that an argument is not only evaluated to WHNF once we entered it's RHS but also that an lifted argument is already *properly tagged* once we jump @@ -261,7 +261,7 @@ The invariants around the arguments of call by value function like Ids are then: * Any `WorkerLikeId` * Some `JoinId` bindings. -This works analogous to the Strict Field Invariant. See also Note [Strict Field Invariant]. +This works analogous to the EPT Invariant. See also Note [EPT enforcement]. To make this work what we do is: * During W/W and SpecConstr any worker/specialized binding we introduce diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 625b3b320c4367eb19f872ca3f9f494219dd5a89..6204dc653126fd74daa871a41b2cbe3e7539f245 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -58,7 +58,7 @@ import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, coreAltsType ) +import GHC.Core.Utils ( exprType, mkCast, coreAltsType ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Core.TyCon @@ -597,8 +597,12 @@ mkDataConWorkId wkr_name data_con = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info where - tycon = dataConTyCon data_con -- The representation TyCon - wkr_ty = dataConRepType data_con + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + univ_tvs = dataConUnivTyVars data_con + ex_tcvs = dataConExTyCoVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + str_marks = dataConRepStrictness data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo @@ -606,12 +610,19 @@ mkDataConWorkId wkr_name data_con `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 + `setDmdSigInfo` wkr_sig + -- Workers eval their strict fields + -- See Note [Strict fields in Core] `setLFInfo` wkr_lf_info - -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + wkr_sig = mkClosedDmdSig wkr_dmds topDiv + wkr_dmds = map mk_dmd str_marks + mk_dmd MarkedStrict = evalDmd + mk_dmd NotMarkedStrict = topDmd + -- See Note [LFInfo of DataCon workers and wrappers] wkr_lf_info | wkr_arity == 0 = LFCon data_con @@ -619,9 +630,6 @@ mkDataConWorkId wkr_name data_con -- LFInfo stores post-unarisation arity ----------- Workers for newtypes -------------- - univ_tvs = dataConUnivTyVars data_con - ex_tcvs = dataConExTyCoVars data_con - arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setInlinePragInfo` dataConWrapperInlinePragma @@ -789,10 +797,10 @@ mkDataConRep :: DataConBangOpts -> FamInstEnvs -> Name -> DataCon - -> UniqSM DataConRep + -> UniqSM (DataConRep, [HsImplBang], [StrictnessMark]) mkDataConRep dc_bang_opts fam_envs wrap_name data_con | not wrapper_reqd - = return NoDataConRep + = return (NoDataConRep, arg_ibangs, rep_strs) | otherwise = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys @@ -856,11 +864,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con ; return (DCR { dcr_wrap_id = wrap_id , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - -- For newtypes, dcr_bangs is always [HsLazy]. - -- See Note [HsImplBangs for newtypes]. - , dcr_bangs = arg_ibangs }) } + , dcr_arg_tys = rep_tys } + , arg_ibangs, rep_strs) } where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) @@ -918,8 +923,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. - && (any isBanged (ev_ibangs ++ arg_ibangs))) - -- Some forcing/unboxing (includes eq_spec) + && (any isUnpacked (ev_ibangs ++ arg_ibangs))) + -- Some unboxing (includes eq_spec) || isFamInstTyCon tycon -- Cast result @@ -1185,7 +1190,7 @@ dataConArgRep arg_ty HsLazy = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) dataConArgRep arg_ty (HsStrict _) - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + = ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG dataConArgRep arg_ty (HsUnpack Nothing) = dataConArgUnpack arg_ty @@ -1215,9 +1220,6 @@ wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } ------------------------ -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], mkDefaultCase (Var v) v) - unitUnboxer :: Unboxer unitUnboxer v = return ([v], \e -> e) diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 718f81a6ce1afd4d04617fa8a3871de4780789fe..db5fae7120224a7d9f3a35291046b8be444a8203 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -23,7 +23,7 @@ module GHC.Utils.Misc ( dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, - List.foldl1', foldl2, count, countWhile, all2, + List.foldl1', foldl2, count, countWhile, all2, all2Prefix, all3Prefix, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, @@ -652,6 +652,36 @@ all2 _ [] [] = True all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 _ _ _ = False +all2Prefix :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool +-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`. +-- (It generates good code nonetheless.) +-- So if one list is shorter than the other, `p` is assumed to be `True` for the +-- suffix. +all2Prefix p = foldr k z + where + k :: a -> ([b] -> Bool) -> [b] -> Bool + k x go ys' = case ys' of + (y:ys'') -> p x y && go ys'' + _ -> True + z :: [b] -> Bool + z _ = True +{-# INLINE all2Prefix #-} + +all3Prefix :: forall a b c. (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool +-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`. +-- (It generates good code nonetheless.) +-- So if one list is shorter than the others, `p` is assumed to be `True` for +-- the suffix. +all3Prefix p = foldr k z + where + k :: a -> ([b] -> [c] -> Bool) -> [b] -> [c] -> Bool + k x go ys' zs' = case (ys',zs') of + (y:ys'',z:zs'') -> p x y z && go ys'' zs'' + _ -> False + z :: [b] -> [c] -> Bool + z _ _ = True +{-# INLINE all3Prefix #-} + -- Count the number of times a predicate is true count :: (a -> Bool) -> [a] -> Int diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 59ce1710040701bf7a398862fb695733e54a4658..c7aa7ae3f9a7a17e261aa223b95e95dfb18676af 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -698,10 +698,10 @@ Library GHC.Stg.Lift.Monad GHC.Stg.Lift.Types GHC.Stg.Lint - GHC.Stg.InferTags - GHC.Stg.InferTags.Rewrite - GHC.Stg.InferTags.TagSig - GHC.Stg.InferTags.Types + GHC.Stg.EnforceEpt + GHC.Stg.EnforceEpt.Rewrite + GHC.Stg.EnforceEpt.TagSig + GHC.Stg.EnforceEpt.Types GHC.Stg.Pipeline GHC.Stg.Stats GHC.Stg.Subst diff --git a/testsuite/tests/codeGen/should_compile/T24264.hs b/testsuite/tests/codeGen/should_compile/T24264.hs index 9c790e1477c2f8e80af0a8d75cc1f9c17971abcd..6436de2881668073ff240199bc38d3db74ad7dc3 100644 --- a/testsuite/tests/codeGen/should_compile/T24264.hs +++ b/testsuite/tests/codeGen/should_compile/T24264.hs @@ -25,7 +25,8 @@ fun3 :: a -> IO a fun3 x = do pure () evaluate $! x - -- This should not push a continuation to the stack before entering 'x' + -- This ideally also should not push a continuation to the stack + -- before entering 'x'. funPair :: a -> IO (a, a) {-# OPAQUE funPair #-} diff --git a/testsuite/tests/core-to-stg/T24124.hs b/testsuite/tests/core-to-stg/T24124.hs index d996b8262e8b888a26ebb64db219e209f6f7a207..b441a4d0e83cf0445a580ecf5c008b284b9c434f 100644 --- a/testsuite/tests/core-to-stg/T24124.hs +++ b/testsuite/tests/core-to-stg/T24124.hs @@ -1,4 +1,4 @@ -module T15226b where +module T24124 where import Control.Exception diff --git a/testsuite/tests/core-to-stg/T24124.stderr b/testsuite/tests/core-to-stg/T24124.stderr index baf21e99c2d13d2eb8eaf68571a8031947e7f966..7a5dd8199c625c6bd4f9ae331c18a296bd151df3 100644 --- a/testsuite/tests/core-to-stg/T24124.stderr +++ b/testsuite/tests/core-to-stg/T24124.stderr @@ -1,46 +1,42 @@ ==================== Final STG: ==================== -T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE] - :: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b -[GblId[DataConWrapper], Arity=2, Str=<SL><SL>, Unf=OtherCon []] = - {} \r [conrep conrep1] - case conrep of conrep2 { - __DEFAULT -> - case conrep1 of conrep3 { - __DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3]; - }; - }; - -T15226b.testFun1 +T24124.testFun1 :: forall a b. a -> b -> GHC.Prim.State# GHC.Prim.RealWorld - -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] = + -> (# GHC.Prim.State# GHC.Prim.RealWorld, T24124.StrictPair a b #) +[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] = {} \r [x y void] case x of sat { __DEFAULT -> - case y of conrep { - __DEFAULT -> - case T15226b.MkStrictPair [sat conrep] of sat { + case + case y of y [OS=OneShot] { + __DEFAULT -> T24124.MkStrictPair [sat y]; + } + of + sat + { __DEFAULT -> MkSolo# [sat]; }; }; - }; -T15226b.testFun - :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=<L><ML><L>, Cpr=1, Unf=OtherCon []] = - {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; +T24124.testFun + :: forall a b. a -> b -> GHC.Types.IO (T24124.StrictPair a b) +[GblId, Arity=3, Str=<L><L><L>, Cpr=1, Unf=OtherCon []] = + {} \r [eta eta void] T24124.testFun1 eta eta GHC.Prim.void#; -T15226b.MkStrictPair [InlPrag=CONLIKE] - :: forall {a} {b}. a %1 -> b %1 -> T15226b.StrictPair a b -[GblId[DataCon], Arity=2, Caf=NoCafRefs, Unf=OtherCon []] = +T24124.MkStrictPair [InlPrag=CONLIKE] + :: forall a b. a %1 -> b %1 -> T24124.StrictPair a b +[GblId[DataCon], + Arity=2, + Caf=NoCafRefs, + Str=<SL><SL>, + Unf=OtherCon []] = {} \r [eta eta] case eta of eta { __DEFAULT -> - case eta of eta { __DEFAULT -> T15226b.MkStrictPair [eta eta]; }; + case eta of eta { __DEFAULT -> T24124.MkStrictPair [eta eta]; }; }; diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index a5154e3119308f4b40c9a2532fce08da0cf7f8ca..7adda417ddd6ab7018e05752c8c589cb7d2f4d81 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -122,7 +122,7 @@ GHC.Runtime.Heap.Layout GHC.Settings GHC.Settings.Config GHC.Settings.Constants -GHC.Stg.InferTags.TagSig +GHC.Stg.EnforceEpt.TagSig GHC.StgToCmm.Types GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index b9f2f21c1c7e8c2c727cfcad837021d4d5b2b302..bb80451ee6f279175824a413501ea48bdc931a6d 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -138,7 +138,7 @@ GHC.Runtime.Heap.Layout GHC.Settings GHC.Settings.Config GHC.Settings.Constants -GHC.Stg.InferTags.TagSig +GHC.Stg.EnforceEpt.TagSig GHC.StgToCmm.Types GHC.SysTools.Terminal GHC.Tc.Errors.Hole.FitTypes diff --git a/testsuite/tests/dmdanal/sigs/T16859.stderr b/testsuite/tests/dmdanal/sigs/T16859.stderr index bb9b878043dfa88a44bca0a60cfbebbea4d1c6da..638ec098a930a88797266f75d09be8993a98a19c 100644 --- a/testsuite/tests/dmdanal/sigs/T16859.stderr +++ b/testsuite/tests/dmdanal/sigs/T16859.stderr @@ -4,7 +4,7 @@ T16859.bar: <1!A><L> T16859.baz: <1L><1!P(L)><1C(1,L)> T16859.buz: <1!P(L,L)> T16859.foo: <1L><L> -T16859.mkInternalName: <1!P(L)><1L><1L> +T16859.mkInternalName: <1!P(L)><SL><SL> T16859.n_loc: <1!P(A,A,A,1L)> T16859.n_occ: <1!P(A,1!P(L,L),A,A)> T16859.n_sort: <1!P(1L,A,A,A)> diff --git a/testsuite/tests/simplCore/should_compile/T18013.hs b/testsuite/tests/simplCore/should_compile/T18013.hs index 08b0a057d2a57f342dfb7fa0883ba2d94baf08bb..d4e5c04e9532aa5c0a3fa53173b88ca4612694d8 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.hs +++ b/testsuite/tests/simplCore/should_compile/T18013.hs @@ -16,3 +16,7 @@ mapMaybeRule f = proc v -> case v of y <- f -< x returnA -< Just y Nothing -> returnA -< Nothing +{-# NOINLINE mapMaybeRule #-} + -- The size of mapMaybeRule is very close to the inlining threshold. + -- The NOINLINE consistently forces a worker/wrapper split to make + -- the test output more stable. diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index 738f4bf1742de3319ecb3215173d9a8ad6b15936..fb14ae807c7ac251df826d680634ebd5ff444d0a 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -131,72 +131,36 @@ Rule fired: Class op fmap (BUILTIN) ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 36, types: 86, coercions: 17, joins: 0/0} + = {terms: 51, types: 122, coercions: 17, joins: 0/0} --- RHS size: {terms: 35, types: 74, coercions: 17, joins: 0/0} -mapMaybeRule [InlPrag=[2]] - :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b) -[GblId, - Arity=1, - Str=<1!P(L,LC(S,C(1,C(1,P(L,1L)))))>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) (@b) (f [Occ=Once1!] :: Rule IO a b) -> - case f of { Rule @s ww ww1 [Occ=OnceL1!] -> - T18013a.Rule - @IO - @(Maybe a) - @(Maybe b) - @s - ww - ((\ (s2 [Occ=Once1] :: s) - (a1 [Occ=Once1!] :: Maybe a) - (s1 [Occ=Once2] :: GHC.Prim.State# GHC.Prim.RealWorld) -> - case a1 of { - Nothing -> - (# s1, - T18013a.Result @s @(Maybe b) ww (GHC.Internal.Maybe.Nothing @b) #); - Just x [Occ=Once1] -> - case ((ww1 s2 x) - `cast` <Co:4> :: IO (Result s b) - ~R# (GHC.Prim.State# GHC.Prim.RealWorld - -> (# GHC.Prim.State# GHC.Prim.RealWorld, - Result s b #))) - s1 - of - { (# ipv [Occ=Once1], ipv1 [Occ=Once1!] #) -> - case ipv1 of { Result t2 [Occ=Once1] c1 [Occ=Once1] -> - (# ipv, - T18013a.Result @s @(Maybe b) t2 (GHC.Internal.Maybe.Just @b c1) #) - } - } - }) - `cast` <Co:13> :: (s - -> Maybe a - -> GHC.Prim.State# GHC.Prim.RealWorld - -> (# GHC.Prim.State# GHC.Prim.RealWorld, - Result s (Maybe b) #)) - ~R# (s -> Maybe a -> IO (Result s (Maybe b)))) - }}] -mapMaybeRule - = \ (@a) (@b) (f :: Rule IO a b) -> - case f of { Rule @s ww ww1 -> +-- RHS size: {terms: 40, types: 73, coercions: 17, joins: 0/0} +T18013.$wmapMaybeRule [InlPrag=NOINLINE] + :: forall a b s. + s -> (s -> a -> IO (Result s b)) -> Rule IO (Maybe a) (Maybe b) +[GblId[StrictWorker([!])], + Arity=2, + Str=<1L><1C(L,C(1,C(1,P(L,1L))))>, + Unf=OtherCon []] +T18013.$wmapMaybeRule + = \ (@a) (@b) (@s) (ww :: s) (ww1 :: s -> a -> IO (Result s b)) -> + case ww1 of wild { __DEFAULT -> + case ww of wild1 { __DEFAULT -> T18013a.Rule @IO @(Maybe a) @(Maybe b) @s - ww + wild1 ((\ (s2 :: s) (a1 :: Maybe a) (s1 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case a1 of { Nothing -> (# s1, - T18013a.Result @s @(Maybe b) ww (GHC.Internal.Maybe.Nothing @b) #); + T18013a.Result + @s @(Maybe b) wild1 (GHC.Internal.Maybe.Nothing @b) #); Just x -> - case ((ww1 s2 x) + case ((wild s2 x) `cast` <Co:4> :: IO (Result s b) ~R# (GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, @@ -216,6 +180,26 @@ mapMaybeRule -> (# GHC.Prim.State# GHC.Prim.RealWorld, Result s (Maybe b) #)) ~R# (s -> Maybe a -> IO (Result s (Maybe b)))) } + } + +-- RHS size: {terms: 9, types: 21, coercions: 0, joins: 0/0} +mapMaybeRule [InlPrag=NOINLINE[final]] + :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b) +[GblId, + Arity=1, + Str=<1!P(1L,1C(L,C(1,C(1,P(L,1L)))))>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (@a) (@b) (f [Occ=Once1!] :: Rule IO a b) -> + case f of { Rule @s ww [Occ=Once1] ww1 [Occ=Once1] -> + T18013.$wmapMaybeRule @a @b @s ww ww1 + }}] +mapMaybeRule + = \ (@a) (@b) (f :: Rule IO a b) -> + case f of { Rule @s ww ww1 -> + T18013.$wmapMaybeRule @a @b @s ww ww1 + } diff --git a/testsuite/tests/simplCore/should_compile/T22309.stderr b/testsuite/tests/simplCore/should_compile/T22309.stderr index 65185b546d62bf91605d9a3a613cbccd10686104..be4e1bdd3a50331560e76a3e28c06d049bfe8413 100644 --- a/testsuite/tests/simplCore/should_compile/T22309.stderr +++ b/testsuite/tests/simplCore/should_compile/T22309.stderr @@ -1,13 +1,5 @@ ==================== Final STG: ==================== -$WMkW_NB :: NU_B %1 -> WNU_B = - \r [conrep] - case conrep of conrep1 { __DEFAULT -> MkW_NB [conrep1]; }; - -$WMkW_NA :: NU_A %1 -> WNU_A = - \r [conrep] - case conrep of conrep1 { __DEFAULT -> MkW_NA [conrep1]; }; - $WMkW_F :: UF %1 -> WU_F = \r [conrep] case conrep of conrep1 { Mk_F us -> MkW_F [us]; }; diff --git a/testsuite/tests/simplCore/should_compile/T23083.stderr b/testsuite/tests/simplCore/should_compile/T23083.stderr index ad1bf96e631fb8c34f0745c0e47b87fe86937272..089e3d57af309ab3f1523d5f9054b1429cc5f9cc 100644 --- a/testsuite/tests/simplCore/should_compile/T23083.stderr +++ b/testsuite/tests/simplCore/should_compile/T23083.stderr @@ -15,7 +15,7 @@ T23083.g let { sat [Occ=Once1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer [LclId, Unf=OtherCon []] - sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1, Dmd=SL] { __DEFAULT -> T23083.$$ @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in + sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in f sat -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/T23307.stderr b/testsuite/tests/simplCore/should_compile/T23307.stderr index f42016e9a83ea358e57e44aa3aceb557697e388d..9e9bde518856a43904ebab7831a9ff93e07ec642 100644 --- a/testsuite/tests/simplCore/should_compile/T23307.stderr +++ b/testsuite/tests/simplCore/should_compile/T23307.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 29, types: 40, coercions: 0, joins: 0/0} + = {terms: 9, types: 14, coercions: 0, joins: 0/0} -- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} T23307.$WYes [InlPrag=INLINE[final] CONLIKE] @@ -22,51 +22,5 @@ T23307.$WYes T23307.Yes @a unbx unbx1 } --- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0} -T23307.$WUnconsed [InlPrag=INLINE[final] CONLIKE] - :: forall a. a %1 -> Stream a %1 -> Unconsed a -[GblId[DataConWrapper], - Arity=2, - Str=<L><SL>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) - (conrep [Occ=Once1] :: a) - (conrep1 [Occ=Once1] :: Stream a) -> - case conrep1 of conrep2 [Occ=Once1] { __DEFAULT -> - T23307.Unconsed @a conrep conrep2 - }}] -T23307.$WUnconsed - = \ (@a) - (conrep [Occ=Once1] :: a) - (conrep1 [Occ=Once1] :: Stream a) -> - case conrep1 of conrep2 [Occ=Once1] { __DEFAULT -> - T23307.Unconsed @a conrep conrep2 - } - --- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0} -T23307.$WCons [InlPrag=INLINE[final] CONLIKE] - :: forall a. a %1 -> Stream a %1 -> Stream a -[GblId[DataConWrapper], - Arity=2, - Str=<L><SL>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) - (conrep [Occ=Once1] :: a) - (conrep1 [Occ=Once1] :: Stream a) -> - case conrep1 of conrep2 [Occ=Once1] { __DEFAULT -> - T23307.Cons @a conrep conrep2 - }}] -T23307.$WCons - = \ (@a) - (conrep [Occ=Once1] :: a) - (conrep1 [Occ=Once1] :: Stream a) -> - case conrep1 of conrep2 [Occ=Once1] { __DEFAULT -> - T23307.Cons @a conrep conrep2 - } - diff --git a/testsuite/tests/simplCore/should_compile/T23307a.stderr b/testsuite/tests/simplCore/should_compile/T23307a.stderr index 415edf23f9c3026378f55aaf3952d30711ea1808..517d6186eb8da1ddf7332fa94bed7f5ab96e1fbb 100644 --- a/testsuite/tests/simplCore/should_compile/T23307a.stderr +++ b/testsuite/tests/simplCore/should_compile/T23307a.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 28, types: 41, coercions: 0, joins: 0/0} + = {terms: 18, types: 28, coercions: 0, joins: 0/0} -- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} T23307a.$WYes [InlPrag=INLINE[final] CONLIKE] @@ -22,29 +22,6 @@ T23307a.$WYes T23307a.Yes @a unbx unbx1 } --- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0} -T23307a.$WUnconsed [InlPrag=INLINE[final] CONLIKE] - :: forall a. a %1 -> List a %1 -> Unconsed a -[GblId[DataConWrapper], - Arity=2, - Str=<L><SL>, - Unf=Unf{Src=StableSystem, TopLvl=True, - Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) - (conrep [Occ=Once1] :: a) - (conrep1 [Occ=Once1] :: List a) -> - case conrep1 of conrep2 [Occ=Once1] { __DEFAULT -> - T23307a.Unconsed @a conrep conrep2 - }}] -T23307a.$WUnconsed - = \ (@a) - (conrep [Occ=Once1] :: a) - (conrep1 [Occ=Once1] :: List a) -> - case conrep1 of conrep2 [Occ=Once1] { __DEFAULT -> - T23307a.Unconsed @a conrep conrep2 - } - -- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} T23307a.$WCons [InlPrag=INLINE[final] CONLIKE] :: forall a. Unconsed a %1 -> List a diff --git a/testsuite/tests/simplCore/should_run/T20749.hs b/testsuite/tests/simplCore/should_run/T20749.hs new file mode 100644 index 0000000000000000000000000000000000000000..debc762ee71b6c0d65275b198001785519dd9a39 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T20749.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE UnliftedDatatypes #-} +import Data.Kind +import GHC.Exts + +type StrictPair :: Type -> Type -> UnliftedType +data StrictPair a b = SP !a !b + +f :: StrictPair Int Int -> StrictPair Int Int -> Int -> Bool +{-# OPAQUE f #-} +f (SP x _) (SP _ y) z = x < y + z + +g :: Int -> [Int] -> Int +{-# OPAQUE g #-} +g x ys = h ys + where + h [] = 0 + h (y:ys) = case SP x 27 of + u -> if f u u y then x else x + h ys + +main :: IO () +main = print (g undefined []) diff --git a/testsuite/tests/simplCore/should_run/T20749.stdout b/testsuite/tests/simplCore/should_run/T20749.stdout new file mode 100644 index 0000000000000000000000000000000000000000..573541ac9702dd3969c9bc859d2b91ec1f7e6e56 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T20749.stdout @@ -0,0 +1 @@ +0 diff --git a/testsuite/tests/simplCore/should_run/T24662.hs b/testsuite/tests/simplCore/should_run/T24662.hs new file mode 100644 index 0000000000000000000000000000000000000000..ee131e88128b2135e2f880c4cf92446c75ec2826 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T24662.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MagicHash #-} + +module T24662 where + +import GHC.Exts + +f1 :: a -> Int# -> Int -> Int +{-# OPAQUE f1 #-} +f1 _ x (I# y) = I# (x +# y) + +f2 :: Int# -> a -> Int -> Int +{-# OPAQUE f2 #-} +f2 x _ (I# y) = I# (x +# y) + +loopy :: Int -> Int# +loopy x | x>0 = loopy x + | otherwise = 0# + +-- Should either let or case-bind t (preferrably the latter), but we should do +-- it consistently in foo1 and foo2. +foo1 x = let t :: Int -> Int + t = f1 True (loopy x) in + t `seq` (x, t) + +foo2 x = let t :: Int -> Int + t = f2 True (loopy x) in + t `seq` (x, t) diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 3f8aabf1443117adaf6478fb0d1bbea77a9835f9..1d22cf224e42d7a4d9ac4e17019bbcf412cb7d89 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -107,6 +107,7 @@ test('UnliftedArgRule', normal, compile_and_run, ['']) test('T21229', normal, compile_and_run, ['-O']) test('T21575', normal, compile_and_run, ['-O']) test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O']) +test('T20749', normal, compile_and_run, ['']) test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836 test('T22448', normal, compile_and_run, ['-O1']) test('T22998', normal, compile_and_run, ['-O0 -fspecialise -dcore-lint']) @@ -114,5 +115,6 @@ test('T23184', normal, compile_and_run, ['-O']) test('T23134', normal, compile_and_run, ['-O0 -fcatch-nonexhaustive-cases']) test('T23289', normal, compile_and_run, ['']) test('T23056', [only_ways(['ghci-opt'])], ghci_script, ['T23056.script']) +test('T24662', normal, compile_and_run, ['']) test('T24725', normal, compile_and_run, ['-O -dcore-lint']) test('T25096', normal, compile_and_run, ['-O -dcore-lint']) diff --git a/testsuite/tests/simplStg/should_compile/T15226b.stderr b/testsuite/tests/simplStg/should_compile/T15226b.stderr index bcd3e73a2fbdd615a8d904fe277d6c0b2aaca659..8b2c2f6b11d225768f9eb229673dfb90c8403a6b 100644 --- a/testsuite/tests/simplStg/should_compile/T15226b.stderr +++ b/testsuite/tests/simplStg/should_compile/T15226b.stderr @@ -1,11 +1,5 @@ ==================== Final STG: ==================== -T15226b.$WStr [InlPrag=INLINE[final] CONLIKE] - :: forall a. a %1 -> T15226b.Str a -[GblId[DataConWrapper], Arity=1, Str=<SL>, Unf=OtherCon []] = - {} \r [conrep] - case conrep of conrep1 { __DEFAULT -> T15226b.Str [conrep1]; }; - T15226b.bar1 :: forall a. GHC.Internal.Maybe.Maybe a @@ -18,7 +12,7 @@ T15226b.bar1 __DEFAULT -> let { sat [Occ=Once1] :: T15226b.Str (GHC.Internal.Maybe.Maybe a) - [LclId] = + [LclId, Unf=OtherCon []] = T15226b.Str! [sat]; } in MkSolo# [sat]; }; @@ -30,8 +24,12 @@ T15226b.bar [GblId, Arity=2, Str=<L><L>, Cpr=1(, 1), Unf=OtherCon []] = {} \r [eta void] T15226b.bar1 eta GHC.Prim.void#; -T15226b.Str [InlPrag=CONLIKE] :: forall {a}. a %1 -> T15226b.Str a -[GblId[DataCon], Arity=1, Caf=NoCafRefs, Unf=OtherCon []] = +T15226b.Str [InlPrag=CONLIKE] :: forall a. a %1 -> T15226b.Str a +[GblId[DataCon], + Arity=1, + Caf=NoCafRefs, + Str=<SL>, + Unf=OtherCon []] = {} \r [eta] case eta of eta { __DEFAULT -> T15226b.Str [eta]; }; diff --git a/testsuite/tests/simplStg/should_compile/T19717.stderr b/testsuite/tests/simplStg/should_compile/T19717.stderr index 12843c4f39ceaefb343ea2b2a84d428e54b86b5e..71f5ecd05aa09fdc15ca3dbc1d523bc7d08364b0 100644 --- a/testsuite/tests/simplStg/should_compile/T19717.stderr +++ b/testsuite/tests/simplStg/should_compile/T19717.stderr @@ -3,7 +3,7 @@ Foo.f :: forall {a}. a -> [GHC.Internal.Maybe.Maybe a] [GblId, Arity=1, Str=<1L>, Unf=OtherCon []] = {} \r [x] - case x of x1 [Dmd=SL] { + case x of x1 { __DEFAULT -> let { sat [Occ=Once1] :: GHC.Internal.Maybe.Maybe a diff --git a/testsuite/tests/simplStg/should_compile/inferTags002.stderr b/testsuite/tests/simplStg/should_compile/inferTags002.stderr index ef6979932bbbbd8106212142c70692c3c2f4849e..f2773acd920f95f2fea0fef1f4c11737f0923be1 100644 --- a/testsuite/tests/simplStg/should_compile/inferTags002.stderr +++ b/testsuite/tests/simplStg/should_compile/inferTags002.stderr @@ -1,88 +1,30 @@ -==================== Output Cmm ==================== -[M.$WMkT_entry() { // [R3, R2] - { info_tbls: [(cym, - label: block_cym_info - rep: StackRep [False] - srt: Nothing), - (cyp, - label: M.$WMkT_info - rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } - srt: Nothing), - (cys, - label: block_cys_info - rep: StackRep [False] - srt: Nothing)] - stack_info: arg_space: 8 - } - {offset - cyp: // global - if ((Sp + -16) < SpLim) (likely: False) goto cyv; else goto cyw; - cyv: // global - R1 = M.$WMkT_closure; - call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; - cyw: // global - I64[Sp - 16] = cym; - R1 = R2; - P64[Sp - 8] = R3; - Sp = Sp - 16; - if (R1 & 7 != 0) goto cym; else goto cyn; - cyn: // global - call (I64[R1])(R1) returns to cym, args: 8, res: 8, upd: 8; - cym: // global - I64[Sp] = cys; - _sy8::P64 = R1; - R1 = P64[Sp + 8]; - P64[Sp + 8] = _sy8::P64; - call stg_ap_0_fast(R1) returns to cys, args: 8, res: 8, upd: 8; - cys: // global - Hp = Hp + 24; - if (Hp > HpLim) (likely: False) goto cyA; else goto cyz; - cyA: // global - HpAlloc = 24; - call stg_gc_unpt_r1(R1) returns to cys, args: 8, res: 8, upd: 8; - cyz: // global - I64[Hp - 16] = M.MkT_con_info; - P64[Hp - 8] = P64[Sp + 8]; - P64[Hp] = R1; - R1 = Hp - 15; - Sp = Sp + 16; - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; - } - }, - section ""data" . M.$WMkT_closure" { - M.$WMkT_closure: - const M.$WMkT_info; - }] - - - ==================== Output Cmm ==================== [M.f_entry() { // [R2] - { info_tbls: [(cyK, - label: block_cyK_info + { info_tbls: [(cAs, + label: block_info rep: StackRep [] srt: Nothing), - (cyN, + (cAv, label: M.f_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cyN: // global - if ((Sp + -8) < SpLim) (likely: False) goto cyO; else goto cyP; - cyO: // global + _lbl_: // global + if ((Sp + -8) < SpLim) (likely: False) goto cAw; else goto cAx; + _lbl_: // global R1 = M.f_closure; call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; - cyP: // global - I64[Sp - 8] = cyK; + _lbl_: // global + I64[Sp - 8] = cAs; R1 = R2; Sp = Sp - 8; - if (R1 & 7 != 0) goto cyK; else goto cyL; - cyL: // global - call (I64[R1])(R1) returns to cyK, args: 8, res: 8, upd: 8; - cyK: // global + if (R1 & 7 != 0) goto cAs; else goto cAt; + _lbl_: // global + call (I64[R1])(R1) returns to cAs, args: 8, res: 8, upd: 8; + _lbl_: // global R1 = P64[R1 + 15]; Sp = Sp + 8; call (P64[Sp])(R1) args: 8, res: 0, upd: 8; @@ -97,47 +39,47 @@ ==================== Output Cmm ==================== [M.MkT_entry() { // [R3, R2] - { info_tbls: [(cz1, - label: block_cz1_info + { info_tbls: [(cAJ, + label: block_info rep: StackRep [False] srt: Nothing), - (cz4, + (cAM, label: M.MkT_info rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } srt: Nothing), - (cz7, - label: block_cz7_info + (cAP, + label: block_info rep: StackRep [False] srt: Nothing)] stack_info: arg_space: 8 } {offset - cz4: // global - if ((Sp + -16) < SpLim) (likely: False) goto cza; else goto czb; - cza: // global + _lbl_: // global + if ((Sp + -16) < SpLim) (likely: False) goto cAS; else goto cAT; + _lbl_: // global R1 = M.MkT_closure; call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; - czb: // global - I64[Sp - 16] = cz1; + _lbl_: // global + I64[Sp - 16] = cAJ; R1 = R2; P64[Sp - 8] = R3; Sp = Sp - 16; - if (R1 & 7 != 0) goto cz1; else goto cz2; - cz2: // global - call (I64[R1])(R1) returns to cz1, args: 8, res: 8, upd: 8; - cz1: // global - I64[Sp] = cz7; - _tyf::P64 = R1; + if (R1 & 7 != 0) goto cAJ; else goto cAK; + _lbl_: // global + call (I64[R1])(R1) returns to cAJ, args: 8, res: 8, upd: 8; + _lbl_: // global + I64[Sp] = cAP; + __locVar_::P64 = R1; R1 = P64[Sp + 8]; - P64[Sp + 8] = _tyf::P64; - call stg_ap_0_fast(R1) returns to cz7, args: 8, res: 8, upd: 8; - cz7: // global + P64[Sp + 8] = __locVar_::P64; + call stg_ap_0_fast(R1) returns to cAP, args: 8, res: 8, upd: 8; + _lbl_: // global Hp = Hp + 24; - if (Hp > HpLim) (likely: False) goto czf; else goto cze; - czf: // global + if (Hp > HpLim) (likely: False) goto cAX; else goto cAW; + _lbl_: // global HpAlloc = 24; - call stg_gc_unpt_r1(R1) returns to cz7, args: 8, res: 8, upd: 8; - cze: // global + call stg_gc_unpt_r1(R1) returns to cAP, args: 8, res: 8, upd: 8; + _lbl_: // global I64[Hp - 16] = M.MkT_con_info; P64[Hp - 8] = P64[Sp + 8]; P64[Hp] = R1; @@ -155,14 +97,14 @@ ==================== Output Cmm ==================== [M.MkT_con_entry() { // [] - { info_tbls: [(czl, + { info_tbls: [(cB3, label: M.MkT_con_info rep: HeapRep 2 ptrs { Con {tag: 0 descr:"main:M.MkT"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - czl: // global + _lbl_: // global R1 = R1 + 1; call (P64[Sp])(R1) args: 8, res: 0, upd: 8; } diff --git a/testsuite/tests/simplStg/should_compile/inferTags003.stderr b/testsuite/tests/simplStg/should_compile/inferTags003.stderr index 997a2bcdaf8f32cf5f7e9a134b03f0d174a652ee..ee5cdd219b903bf3da2e03147d3fdb7c7f0101e6 100644 --- a/testsuite/tests/simplStg/should_compile/inferTags003.stderr +++ b/testsuite/tests/simplStg/should_compile/inferTags003.stderr @@ -1,94 +1,33 @@ -==================== Output Cmm ==================== -[M.$WMkT_entry() { // [R3, R2] - { info_tbls: [(cEx, - label: block_cEx_info - rep: StackRep [False] - srt: Nothing), - (cEA, - label: M.$WMkT_info - rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } - srt: Nothing), - (cED, - label: block_cED_info - rep: StackRep [False] - srt: Nothing)] - stack_info: arg_space: 8 - } - {offset - cEA: // global - if ((Sp + -16) < SpLim) (likely: False) goto cEG; else goto cEH; // CmmCondBranch - cEG: // global - R1 = M.$WMkT_closure; // CmmAssign - call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cEH: // global - I64[Sp - 16] = cEx; // CmmStore - R1 = R2; // CmmAssign - P64[Sp - 8] = R3; // CmmStore - Sp = Sp - 16; // CmmAssign - if (R1 & 7 != 0) goto cEx; else goto cEy; // CmmCondBranch - cEy: // global - call (I64[R1])(R1) returns to cEx, args: 8, res: 8, upd: 8; // CmmCall - cEx: // global - // slowCall - I64[Sp] = cED; // CmmStore - _sEi::P64 = R1; // CmmAssign - R1 = P64[Sp + 8]; // CmmAssign - P64[Sp + 8] = _sEi::P64; // CmmStore - call stg_ap_0_fast(R1) returns to cED, args: 8, res: 8, upd: 8; // CmmCall - cED: // global - // slow_call for _sEh::P64 with pat stg_ap_0 - Hp = Hp + 24; // CmmAssign - if (Hp > HpLim) (likely: False) goto cEL; else goto cEK; // CmmCondBranch - cEL: // global - HpAlloc = 24; // CmmAssign - call stg_gc_unpt_r1(R1) returns to cED, args: 8, res: 8, upd: 8; // CmmCall - cEK: // global - // allocHeapClosure - I64[Hp - 16] = M.MkT_con_info; // CmmStore - P64[Hp - 8] = P64[Sp + 8]; // CmmStore - P64[Hp] = R1; // CmmStore - R1 = Hp - 15; // CmmAssign - Sp = Sp + 16; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - } - }, - section ""data" . M.$WMkT_closure" { - M.$WMkT_closure: - const M.$WMkT_info; - }] - - - ==================== Output Cmm ==================== [M.fun_entry() { // [R2] - { info_tbls: [(cEV, - label: block_cEV_info + { info_tbls: [(cB9, + label: block_cB9_info rep: StackRep [] srt: Nothing), - (cEY, + (cBc, label: M.fun_info rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cEY: // global - if ((Sp + -8) < SpLim) (likely: False) goto cEZ; else goto cF0; // CmmCondBranch - cEZ: // global - R1 = M.fun_closure; // CmmAssign - call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cF0: // global - I64[Sp - 8] = cEV; // CmmStore - R1 = R2; // CmmAssign - Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cEV; else goto cEW; // CmmCondBranch - cEW: // global - call (I64[R1])(R1) returns to cEV, args: 8, res: 8, upd: 8; // CmmCall - cEV: // global - R1 = P64[R1 + 15]; // CmmAssign - Sp = Sp + 8; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cBc: // global + if ((Sp + -8) < SpLim) (likely: False) goto cBd; else goto cBe; + cBd: // global + R1 = M.fun_closure; + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; + cBe: // global + I64[Sp - 8] = cB9; + R1 = R2; + Sp = Sp - 8; + if (R1 & 7 != 0) goto cB9; else goto cBa; + cBa: // global + call (I64![R1])(R1) returns to cB9, args: 8, res: 8, upd: 8; + cB9: // global + R1 = P64[R1 + 15]; + Sp = Sp + 8; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; } }, section ""data" . M.fun_closure" { @@ -100,56 +39,53 @@ ==================== Output Cmm ==================== [M.MkT_entry() { // [R3, R2] - { info_tbls: [(cFc, - label: block_cFc_info + { info_tbls: [(cBx, + label: block_cBx_info rep: StackRep [False] srt: Nothing), - (cFf, + (cBA, label: M.MkT_info rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } srt: Nothing), - (cFi, - label: block_cFi_info + (cBD, + label: block_cBD_info rep: StackRep [False] srt: Nothing)] stack_info: arg_space: 8 } {offset - cFf: // global - if ((Sp + -16) < SpLim) (likely: False) goto cFl; else goto cFm; // CmmCondBranch - cFl: // global - R1 = M.MkT_closure; // CmmAssign - call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cFm: // global - I64[Sp - 16] = cFc; // CmmStore - R1 = R2; // CmmAssign - P64[Sp - 8] = R3; // CmmStore - Sp = Sp - 16; // CmmAssign - if (R1 & 7 != 0) goto cFc; else goto cFd; // CmmCondBranch - cFd: // global - call (I64[R1])(R1) returns to cFc, args: 8, res: 8, upd: 8; // CmmCall - cFc: // global - // slowCall - I64[Sp] = cFi; // CmmStore - _tEq::P64 = R1; // CmmAssign - R1 = P64[Sp + 8]; // CmmAssign - P64[Sp + 8] = _tEq::P64; // CmmStore - call stg_ap_0_fast(R1) returns to cFi, args: 8, res: 8, upd: 8; // CmmCall - cFi: // global - // slow_call for _B1::P64 with pat stg_ap_0 - Hp = Hp + 24; // CmmAssign - if (Hp > HpLim) (likely: False) goto cFq; else goto cFp; // CmmCondBranch - cFq: // global - HpAlloc = 24; // CmmAssign - call stg_gc_unpt_r1(R1) returns to cFi, args: 8, res: 8, upd: 8; // CmmCall - cFp: // global - // allocHeapClosure - I64[Hp - 16] = M.MkT_con_info; // CmmStore - P64[Hp - 8] = P64[Sp + 8]; // CmmStore - P64[Hp] = R1; // CmmStore - R1 = Hp - 15; // CmmAssign - Sp = Sp + 16; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cBA: // global + if ((Sp + -16) < SpLim) (likely: False) goto cBG; else goto cBH; + cBG: // global + R1 = M.MkT_closure; + call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; + cBH: // global + I64[Sp - 16] = cBx; + R1 = R2; + P64[Sp - 8] = R3; + Sp = Sp - 16; + if (R1 & 7 != 0) goto cBx; else goto cBy; + cBy: // global + call (I64![R1])(R1) returns to cBx, args: 8, res: 8, upd: 8; + cBx: // global + I64[Sp] = cBD; + _tB0::P64 = R1; + R1 = P64[Sp + 8]; + P64[Sp + 8] = _tB0::P64; + call stg_ap_0_fast(R1) returns to cBD, args: 8, res: 8, upd: 8; + cBD: // global + Hp = Hp + 24; + if (Hp > HpLim) (likely: False) goto cBL; else goto cBK; + cBL: // global + HpAlloc = 24; + call stg_gc_unpt_r1(R1) returns to cBD, args: 8, res: 8, upd: 8; + cBK: // global + I64[Hp - 16] = M.MkT_con_info; + P64[Hp - 8] = P64[Sp + 8]; + P64[Hp] = R1; + R1 = Hp - 15; + Sp = Sp + 16; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; } }, section ""data" . M.MkT_closure" { @@ -161,16 +97,16 @@ ==================== Output Cmm ==================== [M.MkT_con_entry() { // [] - { info_tbls: [(cFw, + { info_tbls: [(cBX, label: M.MkT_con_info rep: HeapRep 2 ptrs { Con {tag: 0 descr:"main:M.MkT"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cFw: // global - R1 = R1 + 1; // CmmAssign - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + cBX: // global + R1 = R1 + 1; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; } }] diff --git a/testsuite/tests/simplStg/should_compile/inferTags004.hs b/testsuite/tests/simplStg/should_compile/inferTags004.hs index d341f8f595638374d6e4c2155f06c5be7267e193..82171370936d0716e4c71284dd9e29577153b150 100644 --- a/testsuite/tests/simplStg/should_compile/inferTags004.hs +++ b/testsuite/tests/simplStg/should_compile/inferTags004.hs @@ -1,11 +1,11 @@ {-# LANGUAGE BangPatterns, UnboxedTuples #-} -module InferTags004 where +module EnforceEpt004 where x :: Int x = x f :: a -> (# Int, a #) --- Adapted from a TODO in InferTags. +-- Adapted from a TODO in EnforceEpt. -- f's tag signature should indicate that the second component -- of its result is properly tagged: TagTuple[TagDunno,TagProper] f g = case g of !g' -> (# x, g' #) diff --git a/testsuite/tests/simplStg/should_compile/inferTags004.stderr b/testsuite/tests/simplStg/should_compile/inferTags004.stderr index 4306da0ed40c4e12054609b9b43bf5af9bbdbbec..c5f1ac863d81f7fb70a2360aadcaccbf7761341d 100644 --- a/testsuite/tests/simplStg/should_compile/inferTags004.stderr +++ b/testsuite/tests/simplStg/should_compile/inferTags004.stderr @@ -1,13 +1,13 @@ ==================== CodeGenAnal STG: ==================== Rec { -(InferTags004.x, <TagDunno>) = {} \u [] InferTags004.x; +(EnforceEpt004.x, <TagDunno>) = {} \u [] EnforceEpt004.x; end Rec } -(InferTags004.f, <TagTuple[TagDunno, TagProper]>) = +(EnforceEpt004.f, <TagTuple[TagDunno, TagProper]>) = {} \r [(g, <TagDunno>)] case g of (g', <TagProper>) { - __DEFAULT -> (#,#) [InferTags004.x g']; + __DEFAULT -> (#,#) [EnforceEpt004.x g']; };