[Git][ghc/ghc][wip/T20749] 2 commits: CorePrep: Attach evaldUnfolding to floats to detect more values
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Fri Apr 26 12:48:29 UTC 2024
Sebastian Graf pushed to branch wip/T20749 at Glasgow Haskell Compiler / GHC
Commits:
386233b0 by Sebastian Graf at 2024-04-26T14:47:58+02:00
CorePrep: Attach evaldUnfolding to floats to detect more values
See `Note [Pin evaluatedness on floats]`.
- - - - -
d2eee16b by Sebastian Graf at 2024-04-26T14:47:58+02:00
Make DataCon workers strict in strict fields (#20749)
This patch tweaks `exprIsConApp_maybe`, `exprIsHNF` and friends, and Demand
Analysis so that they exploit and maintain strictness of DataCon workers. See
`Note [Strict fields in Core]` for details.
Very little needed to change, and it puts field seq insertion done by Tag
Inference into a new perspective: That of *implementing* strict field semantics.
Before Tag Inference, DataCon workers are strict. Afterwards they are
effectively lazy and field seqs happen around use sites. History has shown
that there is no other way to guarantee taggedness and thus the STG Strict Field
Invariant.
Knock-on changes:
* `exprIsHNF` previously used `exprOkForSpeculation` on unlifted arguments
instead of recursing into `exprIsHNF`. That regressed the termination
analysis in CPR analysis (which simply calls out to `exprIsHNF`), so I made
it call `exprOkForSpeculation`, too.
* There's a small regression in Demand Analysis, visible in the changed test
output of T16859: Previously, a field seq on a variable would give that
variable a "used exactly once" demand, now it's "used at least once",
because `dmdTransformDataConSig` accounts for future uses of the field
that actually all go through the case binder (and hence won't re-enter the
potential thunk). The difference should hardly be observable.
* The Simplifier's fast path for data constructors only applies to lazy
data constructors now. I observed regressions involving Data.Binary.Put's
`Pair` data type.
* Unfortunately, T21392 does no longer reproduce after this patch, so I marked
it as "not broken" in order to track whether we regress again in the future.
Fixes #20749, the satisfying conclusion of an annoying saga (cf. the ideas
in #21497 and #22475).
Co-Authored-By: Jaro Reinders <jaro.reinders at gmail.com>
- - - - -
29 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Utils/Misc.hs
- testsuite/tests/dmdanal/sigs/T16859.stderr
- testsuite/tests/ghci/should_run/T21052.stdout
- testsuite/tests/simplCore/should_compile/T23083.stderr
- + testsuite/tests/simplCore/should_run/T20749.hs
- + testsuite/tests/simplCore/should_run/T20749.stdout
- + testsuite/tests/simplCore/should_run/T24662.hs
- testsuite/tests/simplCore/should_run/all.T
- testsuite/tests/simplStg/should_compile/T19717.stderr
- testsuite/tests/simplStg/should_compile/inferTags002.stderr
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -640,6 +640,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
=====================================
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,64 @@ 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 seq 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:
+
+ * `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the
+ strict arguments of a DataCon worker are values/ok-for-spec themselves.
+
+ * `exprIsConApp_maybe` inserts field seqs in the `FloatBind`s it returns, so
+ that the Simplifier, Constant-folding, the pattern-match checker, etc.
+ all see the inserted field seqs 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 seqs 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 seq on `xs`, thus
+ case xs of xs' { __DEFAULT -> b }
+
+ * 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].
+
+ * 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 in STG by Note [Tag Inference]:
+It performs field seq insertion to statically guarantee *taggedness* of strict
+fields, establishing the Note [STG Strict Field Invariant]. (Happily, most
+of those seqs are immediately detected as redundant by tag inference and are
+omitted.) From then on, DataCon worker semantics are actually lazy, hence it is
+important that STG passes maintain the Strict Field Invariant.
+
+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 +2216,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
=====================================
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
@@ -901,43 +908,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
@@ -963,8 +935,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]
@@ -973,6 +945,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,
@@ -1008,7 +993,6 @@ we consult HsImplBang:
The boolean flag is used only for this warning.
See #11270 for motivation.
-
************************************************************************
* *
\subsection{Instances}
@@ -1110,6 +1094,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
@@ -1135,13 +1124,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
@@ -1163,7 +1154,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
@@ -1180,6 +1173,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,
@@ -1192,7 +1187,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,
@@ -1435,20 +1431,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
=====================================
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
=====================================
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
=====================================
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
=====================================
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)
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2204,14 +2204,14 @@ 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]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Fast path for lazy data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For applications of a 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)
+* Though they might be strict (see Note [Strict fields in Core] in GHC.Core),
+ we will exploit that strictness through their demand signature
So it's fine to zoom straight to `rebuild` which just rebuilds the
call in a very straightforward way.
@@ -2235,7 +2235,7 @@ simplVar env var
simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
simplIdF env var cont
- | isDataConWorkId var -- See Note [Fast path for data constructors]
+ | isDataConWorkId var -- See Note [Fast path for lazy data constructors]
= rebuild env (Var var) cont
| otherwise
= case substId env var of
@@ -3420,7 +3420,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
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1277,11 +1277,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)
@@ -1324,8 +1321,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 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
@@ -1411,6 +1410,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 seq 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
=====================================
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,
@@ -290,6 +290,7 @@ import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.Maybe ( orElse, isJust, firstJust )
+import GHC.List (build)
-- $type_classification
-- #type_classification#
@@ -2031,6 +2032,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.
--
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1493,18 +1493,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
@@ -1515,7 +1520,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
@@ -1523,90 +1528,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
@@ -1626,7 +1567,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
@@ -1641,6 +1582,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
@@ -1672,6 +1614,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
@@ -1852,7 +1838,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]
@@ -1867,13 +1853,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]
@@ -1923,7 +1907,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
@@ -1932,6 +1916,17 @@ app_ok fun_ok primop_ok fun args
| otherwise
= expr_ok fun_ok primop_ok arg
+ -- Used for DataCon worker arguments
+ 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
@@ -2157,12 +2152,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)
@@ -2186,7 +2183,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)
@@ -2194,26 +2191,63 @@ 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
+ 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
+ | isMarkedStrict str || mightBeUnliftedType a_ty = 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]
@@ -2775,7 +2809,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 Strict Field Invariant! See Note [STG Strict Field Invariant] 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
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -644,7 +644,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
| otherwise
= snocFloat floats new_float
- new_float = mkNonRecFloat env is_unlifted bndr1 rhs1
+ (new_float, _bndr2) = mkNonRecFloat env is_unlifted bndr1 rhs1
; return (env2, floats1, Nothing) }
@@ -729,9 +729,9 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
- ; let float = mkNonRecFloat env False v rhs2
+ ; let (float, v') = mkNonRecFloat env False v rhs2
; return ( snocFloat floats2 float
- , cpeEtaExpand arity (Var v)) })
+ , cpeEtaExpand arity (Var v')) })
-- Wrap floating ticks
; let (floats4, rhs4) = wrapTicks floats3 rhs3
@@ -907,10 +907,10 @@ cpeRhsE env (Case scrut bndr ty alts)
; alts'' <- mapM (sat_alt env') alts'
; case alts'' of
- [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]
- | let is_unlifted = isUnliftedType (idType bndr2)
- , let float = mkCaseFloat is_unlifted bndr2 scrut'
- -> return (snocFloat floats float, rhs)
+-- [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]
+-- | let is_unlifted = isUnliftedType (idType bndr2)
+-- , let float = mkCaseFloat is_unlifted bndr2 scrut'
+-- -> return (snocFloat floats float, rhs)
_ -> return (floats, Case scrut' bndr2 (cpSubstTy env ty) alts'') }
where
sat_alt env (Alt con bs rhs)
@@ -1570,8 +1570,9 @@ cpeArg env dmd arg
; let arity = cpeArgArity env dec floats1 arg2
arg3 = cpeEtaExpand arity arg2
-- See Note [Eta expansion of arguments in CorePrep]
- ; let arg_float = mkNonRecFloat env is_unlifted v arg3
- ; return (snocFloat floats2 arg_float, varToCoreExpr v) }
+ ; let (arg_float, v') = mkNonRecFloat env is_unlifted v arg3
+ ; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2)
+ ; return (snocFloat floats2 arg_float, varToCoreExpr v') }
}
cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity
@@ -1793,10 +1794,10 @@ cpeEtaExpand arity expr
Note [Pin demand info on floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We pin demand info on floated lets, so that we can see the one-shot thunks.
+We pin demand info on floated lets, so that we can see one-shot thunks.
For example,
f (g x)
-where `f` uses its argument at least once, creates a Float for `y = g x` and we
+where `f` uses its argument at most once, creates a Float for `y = g x` and we
should better pin appropriate demand info on `y`.
Note [Flatten case-binds]
@@ -1807,7 +1808,7 @@ Suppose we have the following call, where f is strict:
`case` out because `f` is strict.)
In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind`
- Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl
+ Float (a = case x of y { DEFAULT -> blah }) CaseBound top-lvl
with the call `f a`. When we wrap that `Float` we will get
@@ -1826,8 +1827,8 @@ This is easy to avoid: turn that
into a FloatingBind of its own. This is easily done in the Case
equation for `cpsRhsE`. Then our example will generate /two/ floats:
- Float (y = x) CaseBound top_lvl
- Float (a = blah) CaseBound top_lvl
+ Float (y = x) CaseBound str-ctx
+ Float (a = blah) CaseBound top-lvl
and we'll end up with nested cases.
@@ -1840,6 +1841,124 @@ Of course, the Simplifier never leaves us with an argument like this, but we
and the above footwork in cpsRhsE avoids generating a nested case.
+Note [Pin evaluatedness on floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a call to a CBV function, such as a DataCon worker with *strict* fields,
+in a *lazy* context, such as in the arg of a lazy function call to `f`:
+
+
+ data Box a = Box !a
+ ... f (Box e) ... -- f lazy, Box strict
+
+(A live example of this is T24730, inspired by $walexGetByte.)
+During ANFisation, we will `mkNonRecFloat` for `e`, binding it to a
+fresh binder `sat`, and binding `Box sat` as well to a fresh binder `sat2`.
+We want to avoid allocating a thunk for `sat2` as often as possible, building
+on the let floating mechanism in Case (2) of Note [wantFloatLocal].
+
+Note that this mechanism requires `sat` to be detected as a value after
+floating out any ok-for-spec floats, according to `exprIsHNF`. This means we
+need an `evaldUnfolding` on `sat`, and `mkNonRecFloat` must do the pinning.
+
+There are two interesting cases:
+
+ 1. When `e = I# (x +# 1#)`, we decompose into
+ case x +# 1# of x' ->
+ ---
+ I# x'
+ where everything above --- are floats and below --- is the residual RHS.
+ Here, `I# x'` is a value because `x'` is (NB: x' is a variable of unlifted type).
+ Following Case (2) of Note [wantFloatLocal], we want to float out the
+ ok-for-spec `x +# 1#` computation in order not to allocate a thunk for Box's
+ field, to get
+ case x +# 1# of x' ->
+ let sat = I# x' in
+ ---
+ Box sat
+ And since we pin an `evaldUnfolding` on `sat`, we may even float out of
+ `f`'s lazy argument, again by Case (2) of Note [wantFloatLocal]
+ case x +# 1# of x' ->
+ let sat = I# x' in
+ let sat2 = Box sat in
+ f sat2
+ If `sat` didn't have the `evaldUnfolding`, we'd get a large thunk in f's arg:
+ let sat2 =
+ case x +# 1# of x' ->
+ let sat = I# x' in
+ Box sat in
+ f sat2
+ 2.
+
+Although `e` might not be a value, it might still decompose into floats that are
+ok-for-spec and a value, for example
+ e = I# (x +# 1#)
+decomposes into
+Following Case (2) of Note [wantFloatLocal], we want to float out the
+ok-for-spec `x +# 1#` computation in order not to allocate a thunk for Box's
+field, to get
+ case x +# 1# of x' ->
+ let sat = I# x' in
+ Box sat
+Nice! But now we want to do the same for the argument to `f`, to get
+ case x +# 1# of x' ->
+ let sat = I# x' in
+ let sat2 = Box sat in
+ f sat2
+(NB: Since all floats are ok-for-spec, we may float out of the lazy argument.)
+BUT, in order to do that in Case (2) of Note [wantFloatLocal], we must detect
+`Box sat` as a value according to `exprIsHNF`; otherwise floating would be
+unproductive. Crucially, this means we need `sat` to look evaluated, because
+it ends up in a strict field.
+We achieve this by attaching and `evaldUnfolding` to `sat` in `mkNonRecFloat`.
+
+*When
+
+ 1. When `e=Just y` is a value, we will float `sat=Just y` as far as possible,
+ to top-level, even. It is important that we mark `sat` as evaluated (via
+ setting its unfolding to `evaldUnfolding`), otherwise we get a superfluous
+ thunk to carry out the field seq on Box's field, because
+ `exprIsHNF sat == False`:
+
+ let sat = Just y in
+ let sat2 = case sat of x { __DEFAULT } -> Box x in
+ -- NONONO, want just `sat2 = Box x`
+ f sat2
+
+ This happened in $walexGetByte, where the thunk caused additional
+ allocation.
+
+ 2. Similarly, when `e` is not a value, we still know that it is strictly
+ evaluated. Hence it is going to be case-bound, and we anticipate that `sat`
+ will be a case binder which is *always* evaluated.
+ Hence in this case, we also mark `sat` as evaluated via its unfolding.
+ This happened in GHC.Linker.Deps.$wgetLinkDeps, where without
+ `evaldUnfolding` we ended up with this:
+
+ Word64Map = ... | Bin ... ... !Word64Map !Word64Map
+ case ... of { Word64Map.Bin a b l r ->
+ case insert ... of sat { __DEFAULT ->
+ case Word64Map.Bin a b l sat of sat2 { __DEFAULT ->
+ f sat2
+ }}}
+
+ Note that *the DataCon app `Bin a b l sat` was case-bound*, because it was
+ not detected to be a value according to `exprIsHNF`.
+ That is because the strict field `sat` lacked the `evaldUnfolding`,
+ although it ended up being case-bound.
+
+ Small wrinkle:
+ It could be that `sat=insert ...` 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=insert ...`: If
+ it says `TopLvlFloatable`, we are conservative and will not give `sat` an
+ `evaldUnfolding`.
+
+TLDR; when creating a new float `sat=e` in `mkNonRecFloat`, 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.
+
Note [Speculative evaluation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since call-by-value is much cheaper than call-by-need, we case-bind arguments
@@ -2123,15 +2242,16 @@ zipManyFloats = foldr zipFloats emptyFloats
mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind
mkCaseFloat is_unlifted bndr scrut
- = Float (NonRec bndr scrut) bound info
+ = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info)
+ -- -- <+> ppr is_lifted <+> ppr is_strict
+ -- -- <+> ppr ok_for_spec <+> ppr evald
+ -- $$ ppr scrut) $
+ Float (NonRec bndr scrut) bound info
where
(bound, info)
-{-
-Eventually we want the following code, when #20749 is fixed.
- | is_lifted, is_hnf = (LetBound, TopLvlFloatable)
- -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should
- -- let-bind `StrictBox x'` after Note [Flatten case-binds].
--}
+-- | is_lifted, is_hnf = (LetBound, TopLvlFloatable)
+-- -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should
+-- -- let-bind `StrictBox x'` after Note [Flatten case-binds].
| exprIsTickedString scrut = (CaseBound, TopLvlFloatable)
-- String literals are unboxed (so must be case-bound) and float to
-- the top-level
@@ -2141,15 +2261,16 @@ Eventually we want the following code, when #20749 is fixed.
_is_lifted = not is_unlifted
_is_hnf = exprIsHNF scrut
-mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind
+mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> (FloatingBind, Id)
mkNonRecFloat env is_unlifted bndr rhs
= -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)
- -- <+> ppr is_lifted <+> ppr is_strict
- -- <+> ppr ok_for_spec
+ -- <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted"
+ -- <+> if ok_for_spec then text "ok-for-spec" else empty
+ -- <+> if evald then text "evald" else empty
-- $$ ppr rhs) $
- Float (NonRec bndr rhs) bound info
+ (Float (NonRec bndr' rhs) bound info, bndr')
where
- (bound, info)
+ !(bound, info)
| is_lifted, is_hnf = (LetBound, TopLvlFloatable)
-- is_lifted: We currently don't allow unlifted values at the
-- top-level or inside letrecs
@@ -2180,6 +2301,11 @@ mkNonRecFloat env is_unlifted bndr rhs
is_rec_call = (`elemUnVarSet` cpe_rec_ids env)
is_data_con = isJust . isDataConId_maybe
+ -- See Note [Pin evaluatedness on floats]
+ evald = is_hnf --- || (bound == CaseBound && info /= TopLvlFloatable)
+ bndr' | evald = bndr `setIdUnfolding` evaldUnfolding
+ | otherwise = bndr
+
-- | Wrap floats around an expression
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds floats body
@@ -2285,6 +2411,10 @@ data FloatDecision
= FloatNone
| FloatAll
+instance Outputable FloatDecision where
+ ppr FloatNone = text "none"
+ ppr FloatAll = text "all"
+
executeFloatDecision :: FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)
executeFloatDecision dec floats rhs
= case dec of
@@ -2706,7 +2836,7 @@ cpeBigNatLit env i = assert (i >= 0) $ do
let
litAddrRhs = Lit (LitString words)
-- not "mkLitString"; that does UTF-8 encoding, which we don't want here
- litAddrFloat = mkNonRecFloat env True litAddrId litAddrRhs
+ (litAddrFloat, litAddrId') = mkNonRecFloat env True litAddrId litAddrRhs
contentsLength = mkIntLit platform (toInteger (BS.length words))
@@ -2719,7 +2849,7 @@ cpeBigNatLit env i = assert (i >= 0) $ do
copyContentsCall =
Var (primOpId CopyAddrToByteArrayOp)
`App` Type realWorldTy
- `App` Var litAddrId
+ `App` Var litAddrId'
`App` Var mutableByteArrayId
`App` mkIntLit platform 0
`App` contentsLength
=====================================
compiler/GHC/Stg/InferTags.hs
=====================================
@@ -64,8 +64,8 @@ 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]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [STG Strict Field Invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As part of tag inference we introduce the Strict Field Invariant.
Which consists of us saying that:
@@ -81,7 +81,7 @@ 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].
+This works analogous to how CBV functions work. See also Note [CBV Function Ids].
Why do we care? Because if we have code like:
@@ -103,7 +103,7 @@ where we:
* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'`
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.
+we fail to prove 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.
@@ -124,15 +124,33 @@ Note that there are similar constraints around Note [CBV Function Ids].
Note [How untagged pointers can end up in strict fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the resolution of #20749 where Core passes assume that DataCon workers
+evaluate their strict fields, it is pretty simple to see how the Simplifier
+might exploit that knowledge to drop evals. Example:
+
+ data T a = MkT !a
+ f :: [Int] -> T [Int]
+ f xs = xs `seq` MkT xs
+
+in Core we will have
+
+ f = \xs -> MkT @[Int] xs
+
+No eval left there.
+
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.
+Note [STG Strict Field Invariant] requires.
+
+But alas, the Simplifier can destroy the invariant: see #15696.
+Indeed, as Note [Strict fields in Core] explains, Core passes
+assume that Data constructor workers evaluate their strict fields,
+so the Simplifier will drop seqs freely.
-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,7 +171,7 @@ 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
+cannot guarantee to obey the Note [STG Strict Field Invariant]. For this reason
we run tag inference. See Note [Tag inference passes].
Note [Tag inference passes]
@@ -163,7 +181,7 @@ Tag inference proceeds in two passes:
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].
+ See Note [STG 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)`.
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -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 [STG Strict Field Invariant].
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 [STG Strict Field Invariant].
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.
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -884,7 +884,7 @@ 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
+many similarities to the story behind Note [STG Strict Field Invariant] in
GHC.Stg.InferTags. See also #15696.
-}
=====================================
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 }
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -1391,33 +1391,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 (Note [Strict fields in Core]).
+Hence we add an additional `seqDmd` for each strict field to emulate
+field seq 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.
-}
{- *********************************************************************
@@ -1617,6 +1600,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.
@@ -2333,7 +2339,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).
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -260,7 +260,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 Strict Field Invariant. See also Note [STG Strict Field Invariant].
To make this work what we do is:
* During W/W and SpecConstr any worker/specialized binding we introduce
=====================================
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)
=====================================
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,30 @@ all2 _ [] [] = True
all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
all2 _ _ _ = False
+all2Prefix :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`.
+-- 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 x go ys' = case ys' of
+ (y:ys'') -> p x y && go ys''
+ _ -> True
+ z _ = True
+{-# INLINE all2Prefix #-}
+
+all3Prefix :: (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool
+-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`.
+-- 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 x go ys' zs' = case (ys',zs') of
+ (y:ys'',z:zs'') -> p x y z && go ys'' zs''
+ _ -> False
+ z _ _ = True
+{-# INLINE all3Prefix #-}
+
-- Count the number of times a predicate is true
count :: (a -> Bool) -> [a] -> Int
=====================================
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)>
=====================================
testsuite/tests/ghci/should_run/T21052.stdout
=====================================
@@ -5,7 +5,7 @@ BCO_toplevel :: GHC.Types.IO [GHC.Types.Any]
{} \u []
let {
sat :: [GHC.Types.Any]
- [LclId] =
+ [LclId, Unf=OtherCon []] =
:! [GHC.Tuple.() GHC.Types.[]];
} in GHC.Internal.Base.returnIO sat;
=====================================
testsuite/tests/simplCore/should_compile/T23083.stderr
=====================================
@@ -14,8 +14,8 @@ T23083.g
= \ (f [Occ=Once1!] :: (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) (h [Occ=OnceL1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) ->
let {
sat [Occ=Once1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer
- [LclId]
- 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
+ [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
f sat
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
=====================================
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 [])
=====================================
testsuite/tests/simplCore/should_run/T20749.stdout
=====================================
@@ -0,0 +1 @@
+0
=====================================
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)
=====================================
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,3 +115,4 @@ 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, [''])
=====================================
testsuite/tests/simplStg/should_compile/T19717.stderr
=====================================
@@ -3,15 +3,15 @@
Foo.f :: forall {a}. a -> [GHC.Internal.Maybe.Maybe a]
[GblId, Arity=1, Str=<1L>, Unf=OtherCon []] =
{} \r [x]
- case x of x1 {
+ case x of x1 [Dmd=SL] {
__DEFAULT ->
let {
sat [Occ=Once1] :: GHC.Internal.Maybe.Maybe a
- [LclId] =
+ [LclId, Unf=OtherCon []] =
GHC.Internal.Maybe.Just! [x1]; } in
let {
sat [Occ=Once1] :: [GHC.Internal.Maybe.Maybe a]
- [LclId] =
+ [LclId, Unf=OtherCon []] =
:! [sat GHC.Types.[]];
} in : [sat sat];
};
=====================================
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;
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a3cc62dda8025ac99284a6dfbe4446d7a05c193...d2eee16b6f7e16d42db5c37a3483f9e0135fc7c0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a3cc62dda8025ac99284a6dfbe4446d7a05c193...d2eee16b6f7e16d42db5c37a3483f9e0135fc7c0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240426/6c572011/attachment-0001.html>
More information about the ghc-commits
mailing list