[Git][ghc/ghc][wip/T20749] 2 commits: Simplifier: Eta expand arguments (#23083)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue Mar 7 13:19:21 UTC 2023
Sebastian Graf pushed to branch wip/T20749 at Glasgow Haskell Compiler / GHC
Commits:
12c83c35 by Sebastian Graf at 2023-03-07T14:00:36+01:00
Simplifier: Eta expand arguments (#23083)
Previously, we'd only eta expand let bindings and lambdas,
now we'll also eta expand arguments such as in T23083:
```hs
g f h = f (h `seq` (h $))
```
Unless `-fpedantic-bottoms` is set, we'll now transform to
```hs
g f h = f (\eta -> h eta)
```
Tweaking the Simplifier to eta-expand in args was a bit more painful than expected:
* `tryEtaExpandRhs` and `findRhsArity` previously only worked on bindings.
But eta expansion of non-recursive bindings is morally the same as eta
expansion of arguments. And in fact the binder was never really looked at in
the non-recursive case.
I was able to make `findRhsArity` cater for both arguments and bindings, as
well as have a new function `tryEtaExpandArg` that shares most of its code
with that of `tryEtaExpandRhs`.
* The Simplifier had a function `simplArg` that wasn't called in `rebuildCall`,
which seems to be the main way to simplify args. Hence I consolidated the
code path to call `simplArg`, too, renaming to `simplLazyArg`.
Fixes #23083.
- - - - -
964dbea3 by Sebastian Graf at 2023-03-07T14:18:43+01: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).
- - - - -
26 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/ConstantFold.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/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Stats.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.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/simplCore/should_compile/T18013.stderr
- + testsuite/tests/simplCore/should_compile/T23083.hs
- + testsuite/tests/simplCore/should_compile/T23083.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplStg/should_compile/inferTags002.stderr
- testsuite/tests/stranal/sigs/T16859.stderr
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -615,6 +615,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
(mkTyVarBinders SpecifiedSpec user_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,
@@ -994,6 +994,60 @@ 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.
+Conversely, 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 insert 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.
+
+ * The demand signature of a data constructor is strict in strict field
+ position, whereas is it's normally lazy. Likewise the demand *transformer*
+ of a DataCon worker can add 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 very 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
@@ -2080,6 +2134,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
=====================================
@@ -48,7 +48,8 @@ module GHC.Core.DataCon (
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe,
dataConImplicitTyThings,
- dataConRepStrictness, dataConImplBangs, dataConBoxer,
+ dataConRepStrictness, dataConRepStrictness_maybe,
+ dataConImplBangs, dataConBoxer,
splitDataProductType_maybe,
@@ -59,7 +60,7 @@ module GHC.Core.DataCon (
isVanillaDataCon, isNewDataCon, isTypeDataCon,
classDataCon, dataConCannotMatch,
dataConUserTyVarsNeedWrapper, checkDataConTyVars,
- isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,
+ isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,
specialPromotedDc,
-- ** Promotion related functions
@@ -95,6 +96,7 @@ import GHC.Types.Unique.FM ( UniqFM )
import GHC.Types.Unique.Set
import GHC.Builtin.Uniques( mkAlphaTyVarUnique )
import GHC.Data.Graph.UnVar -- UnVarSet and operations
+import GHC.Data.Maybe (orElse)
import GHC.Utils.Outputable
import GHC.Utils.Misc
@@ -502,6 +504,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 it has the same length as 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;
@@ -777,13 +791,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
@@ -852,43 +859,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
@@ -914,8 +886,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]
@@ -959,6 +931,17 @@ we consult HsImplBang:
The boolean flag is used only for this warning.
See #11270 for motivation.
+* 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.
+
Note [Data con representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The dcRepType field contains the type of the representation of a constructor
@@ -974,14 +957,14 @@ what it means is the DataCon with all Unpacking having been applied.
We can think of this as the Core representation.
Here's an example illustrating the Core representation:
- data Ord a => T a = MkT Int! a Void#
+ data Ord a => T a = MkT !Int a Void#
Here
T :: Ord a => Int -> a -> Void# -> T a
but the rep type is
Trep :: Int# -> a -> Void# -> T a
Actually, the unboxed part isn't implemented yet!
-Not that this representation is still *different* from runtime
+Note that this representation is still *different* from runtime
representation. (Which is what STG uses after unarise).
This is how T would end up being used in STG post-unarise:
@@ -1106,6 +1089,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
@@ -1131,13 +1119,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.
-> [InvisTVBinder] -- ^ User-written 'TyVarBinder's.
-- These must be Inferred/Specified.
-- See @Note [TyVarBinders in DataCons]@
@@ -1156,7 +1146,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 user_tvbs
eq_spec theta
@@ -1173,6 +1165,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,
@@ -1184,7 +1178,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,
@@ -1412,19 +1407,27 @@ isNullaryRepDataCon :: DataCon -> Bool
isNullaryRepDataCon dc = dataConRepArity dc == 0
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
+ = dataConRepStrictness_maybe dc
+ `orElse` map (const NotMarkedStrict) (dataConRepArgTys dc)
+
+dataConRepStrictness_maybe :: DataCon -> Maybe [StrictnessMark]
+-- ^ Give the demands on the runtime arguments of a Core DataCon worker
+-- application or `Nothing` if all of them are lazy.
+-- The length of the list matches `dataConRepArgTys` (e.g., the number
+-- of runtime arguments).
+dataConRepStrictness_maybe dc
+ | null (dcStricts dc) = Nothing
+ | otherwise = Just (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
=====================================
@@ -872,9 +872,16 @@ exprEtaExpandArity opts e
* *
********************************************************************* -}
-findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr
- -> (Bool, SafeArityType)
--- This implements the fixpoint loop for arity analysis
+findRhsArity
+ :: ArityOpts
+ -> Maybe Id -- ^ `Just bndr` when it's a recursive RHS bound by bndr
+ -> Bool -- ^ Is it a join binding?
+ -> [OneShotInfo] -- ^ The one-shot info from the use sites, perhaps from
+ -- `idDemandOneShots` of the binder
+ -> CoreExpr -- ^ The RHS (or argument expression)
+ -> Type -- ^ Type of the CoreExpr
+ -> (Bool, SafeArityType)
+-- ^ This implements the fixpoint loop for arity analysis
-- See Note [Arity analysis]
--
-- The Bool is True if the returned arity is greater than (exprArity rhs)
@@ -884,8 +891,8 @@ findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr
-- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr'
-- See Note [Arity trimming]
-findRhsArity opts is_rec bndr rhs
- | isJoinId bndr
+findRhsArity opts mb_rec_bndr is_join use_one_shots rhs rhs_ty
+ | is_join
= (False, join_arity_type)
-- False: see Note [Do not eta-expand join points]
-- But do return the correct arity and bottom-ness, because
@@ -900,28 +907,27 @@ findRhsArity opts is_rec bndr rhs
old_arity = exprArity rhs
init_env :: ArityEnv
- init_env = findRhsArityEnv opts (isJoinId bndr)
+ init_env = findRhsArityEnv opts is_join
-- Non-join-points only
- non_join_arity_type = case is_rec of
- Recursive -> go 0 botArityType
- NonRecursive -> step init_env
+ non_join_arity_type = case mb_rec_bndr of
+ Just bndr -> go 0 bndr botArityType
+ Nothing -> step init_env
arity_increased = arityTypeArity non_join_arity_type > old_arity
-- Join-points only
-- See Note [Arity for non-recursive join bindings]
-- and Note [Arity for recursive join bindings]
- join_arity_type = case is_rec of
- Recursive -> go 0 botArityType
- NonRecursive -> trimArityType ty_arity (cheapArityType rhs)
+ join_arity_type = case mb_rec_bndr of
+ Just bndr -> go 0 bndr botArityType
+ Nothing -> trimArityType ty_arity (cheapArityType rhs)
- ty_arity = typeArity (idType bndr)
- id_one_shots = idDemandOneShots bndr
+ ty_arity = typeArity rhs_ty
step :: ArityEnv -> SafeArityType
step env = trimArityType ty_arity $
safeArityType $ -- See Note [Arity invariants for bindings], item (3)
- arityType env rhs `combineWithDemandOneShots` id_one_shots
+ arityType env rhs `combineWithDemandOneShots` use_one_shots
-- trimArityType: see Note [Trim arity inside the loop]
-- combineWithDemandOneShots: take account of the demand on the
-- binder. Perhaps it is always called with 2 args
@@ -934,8 +940,8 @@ findRhsArity opts is_rec bndr rhs
-- is assumed to be sound. In other words, arities should never
-- decrease. Result: the common case is that there is just one
-- iteration
- go :: Int -> SafeArityType -> SafeArityType
- go !n cur_at@(AT lams div)
+ go :: Int -> Id -> SafeArityType -> SafeArityType
+ go !n bndr cur_at@(AT lams div)
| not (isDeadEndDiv div) -- the "stop right away" case
, length lams <= old_arity = cur_at -- from above
| next_at == cur_at = cur_at
@@ -944,7 +950,7 @@ findRhsArity opts is_rec bndr rhs
= warnPprTrace (debugIsOn && n > 2)
"Exciting arity"
(nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $
- go (n+1) next_at
+ go (n+1) bndr next_at
where
next_at = step (extendSigEnv init_env bndr cur_at)
@@ -964,30 +970,6 @@ combineWithDemandOneShots at@(AT lams div) oss
zip_lams ((ch,os1):lams) (os2:oss)
= (ch, os1 `bestOneShot` os2) : zip_lams lams oss
-idDemandOneShots :: Id -> [OneShotInfo]
-idDemandOneShots bndr
- = call_arity_one_shots `zip_lams` dmd_one_shots
- where
- call_arity_one_shots :: [OneShotInfo]
- call_arity_one_shots
- | call_arity == 0 = []
- | otherwise = NoOneShotInfo : replicate (call_arity-1) OneShotLam
- -- Call Arity analysis says the function is always called
- -- applied to this many arguments. The first NoOneShotInfo is because
- -- if Call Arity says "always applied to 3 args" then the one-shot info
- -- we get is [NoOneShotInfo, OneShotLam, OneShotLam]
- call_arity = idCallArity bndr
-
- dmd_one_shots :: [OneShotInfo]
- -- If the demand info is C(x,C(1,C(1,.))) then we know that an
- -- application to one arg is also an application to three
- dmd_one_shots = argOneShots (idDemandInfo bndr)
-
- -- Take the *longer* list
- zip_lams (lam1:lams1) (lam2:lams2) = (lam1 `bestOneShot` lam2) : zip_lams lams1 lams2
- zip_lams [] lams2 = lams2
- zip_lams lams1 [] = lams1
-
{- Note [Arity analysis]
~~~~~~~~~~~~~~~~~~~~~~~~
The motivating example for arity analysis is this:
@@ -1461,7 +1443,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/ConstantFold.hs
=====================================
@@ -46,7 +46,7 @@ import GHC.Core
import GHC.Core.Make
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe )
import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )
-import GHC.Core.Utils ( cheapEqExpr, exprIsHNF
+import GHC.Core.Utils ( cheapEqExpr, exprOkForSpeculation
, stripTicksTop, stripTicksTopT, mkTicks )
import GHC.Core.Multiplicity
import GHC.Core.Rules.Config
@@ -1936,7 +1936,7 @@ Things to note
Implementing seq#. The compiler has magic for SeqOp in
-- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
+- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <ok-for-spec> s)
- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#
@@ -1951,7 +1951,7 @@ Implementing seq#. The compiler has magic for SeqOp in
seqRule :: RuleM CoreExpr
seqRule = do
[Type _ty_a, Type _ty_s, a, s] <- getArgs
- guard $ exprIsHNF a
+ guard $ exprOkForSpeculation a
return $ mkCoreUnboxedTuple [s, a]
-- spark# :: forall a s . a -> State# s -> (# State# s, a #)
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -297,9 +297,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
+ -- Annyingly, 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]
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -814,6 +814,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,
extendTvSubst, extendCvSubst,
@@ -216,9 +215,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)
@@ -273,9 +269,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
=====================================
@@ -32,7 +32,7 @@ import GHC.Core.Reduction
import GHC.Core.Coercion.Opt ( optCoercion )
import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
import GHC.Core.DataCon
- ( DataCon, dataConWorkId, dataConRepStrictness
+ ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepStrictness_maybe
, dataConRepArgTys, isUnboxedTupleDataCon
, StrictnessMark (..) )
import GHC.Core.Opt.Stats ( Tick(..) )
@@ -1517,7 +1517,7 @@ rebuild env expr cont
ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag
, sc_cont = cont, sc_hole_ty = fun_ty }
-- See Note [Avoid redundant simplification]
- -> do { (_, _, arg') <- simplArg env dup_flag fun_ty se arg
+ -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing topDmd se arg
; rebuild env (App expr arg') cont }
completeBindX :: SimplEnv
@@ -1633,7 +1633,6 @@ simplCast env body co0 cont0
, sc_hole_ty = coercionLKind co }) }
-- NB! As the cast goes past, the
-- type of the hole changes (#16312)
-
-- (f |> co) e ===> (f (e |> co1)) |> co2
-- where co :: (s1->s2) ~ (t1->t2)
-- co1 :: t1 ~ s1
@@ -1652,7 +1651,7 @@ simplCast env body co0 cont0
-- See Note [Avoiding exponential behaviour]
MCo co1 ->
- do { (dup', arg_se', arg') <- simplArg env dup fun_ty arg_se arg
+ do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing topDmd arg_se arg
-- When we build the ApplyTo we can't mix the OutCoercion
-- 'co' with the InExpr 'arg', so we simplify
-- to make it all consistent. It's a bit messy.
@@ -1678,17 +1677,21 @@ simplCast env body co0 cont0
-- See Note [Representation polymorphism invariants] in GHC.Core
-- test: typecheck/should_run/EtaExpandLevPoly
-simplArg :: SimplEnv -> DupFlag
- -> OutType -- Type of the function applied to this arg
- -> StaticEnv -> CoreExpr -- Expression with its static envt
- -> SimplM (DupFlag, StaticEnv, OutExpr)
-simplArg env dup_flag fun_ty arg_env arg
+simplLazyArg :: SimplEnv -> DupFlag
+ -> OutType -- Type of the function applied to this arg
+ -> Maybe ArgInfo
+ -> Demand -- Demand on the argument expr
+ -> StaticEnv -> CoreExpr -- Expression with its static envt
+ -> SimplM (DupFlag, StaticEnv, OutExpr)
+simplLazyArg env dup_flag fun_ty mb_arg_info arg_dmd arg_env arg
| isSimplified dup_flag
= return (dup_flag, arg_env, arg)
| otherwise
= do { let arg_env' = arg_env `setInScopeFromE` env
- ; arg' <- simplExprC arg_env' arg (mkBoringStop (funArgTy fun_ty))
- ; return (Simplified, zapSubstEnv arg_env', arg') }
+ ; let arg_ty = funArgTy fun_ty
+ ; arg1 <- simplExprC arg_env' arg (mkLazyArgStop arg_ty mb_arg_info)
+ ; (_arity_type, arg2) <- tryEtaExpandArg env arg_dmd arg1 arg_ty
+ ; return (Simplified, zapSubstEnv arg_env', arg2) }
-- Return a StaticEnv that includes the in-scope set from 'env',
-- because arg' may well mention those variables (#20639)
@@ -2091,14 +2094,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.
@@ -2122,7 +2125,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 -- See Note [Fast path for lazy data constructors]
+ , Nothing <- dataConRepStrictness_maybe dc
= rebuild env (Var var) cont
| otherwise
= case substId env var of
@@ -2281,12 +2285,9 @@ rebuildCall env fun_info
-- There is no benefit (unlike in a let-binding), and we'd
-- have to be very careful about bogus strictness through
-- floating a demanded let.
- = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
- (mkLazyArgStop arg_ty fun_info)
+ = do { let (dmd:_) = ai_dmds fun_info
+ ; (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) dmd arg_se arg
; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
- where
- arg_ty = funArgTy fun_ty
-
---------- No further useful info, revert to generic rebuild ------------
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
@@ -3304,7 +3305,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
@@ -3723,7 +3724,7 @@ mkDupableContWithDmds env dmds
do { let (dmd:cont_dmds) = dmds -- Never fails
; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont
; let env' = env `setInScopeFromF` floats1
- ; (_, se', arg') <- simplArg env' dup hole_ty se arg
+ ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing dmd se arg
; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'
; let all_floats = floats1 `addLetFloats` let_floats2
; return ( all_floats
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -9,7 +9,7 @@ The simplifier utilities
module GHC.Core.Opt.Simplify.Utils (
-- Rebuilding
rebuildLam, mkCase, prepareAlts,
- tryEtaExpandRhs, wantEtaExpansion,
+ tryEtaExpandRhs, tryEtaExpandArg, wantEtaExpansion,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally,
@@ -461,8 +461,9 @@ mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont
-- See Note [RHS of lets] in GHC.Core.Unfold
mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd)
-mkLazyArgStop :: OutType -> ArgInfo -> SimplCont
-mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd
+mkLazyArgStop :: OutType -> Maybe ArgInfo -> SimplCont
+mkLazyArgStop ty Nothing = mkBoringStop ty
+mkLazyArgStop ty (Just fun_info) = Stop ty (lazyArgContext fun_info) arg_sd
where
arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
@@ -1738,7 +1739,7 @@ rebuildLam env bndrs@(bndr:_) body cont
, seEtaExpand env
, any isRuntimeVar bndrs -- Only when there is at least one value lambda already
, Just body_arity <- exprEtaExpandArity (seArityOpts env) body
- = do { tick (EtaExpansion bndr)
+ = do { tick (EtaExpansion Nothing)
; let body' = etaExpandAT in_scope body_arity body
; traceSmpl "eta expand" (vcat [text "before" <+> ppr body
, text "after" <+> ppr body'])
@@ -1859,25 +1860,48 @@ tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
-> SimplM (ArityType, OutExpr)
-- See Note [Eta-expanding at let bindings]
tryEtaExpandRhs env bind_cxt bndr rhs
+ = tryEtaExpandArgOrRhs env mb_rec_bndr (isJoinBC bind_cxt)
+ (idDemandOneShots bndr) rhs (idType bndr)
+ where
+ mb_rec_bndr = case bindContextRec bind_cxt of
+ Recursive -> Just bndr
+ NonRecursive -> Nothing
+
+tryEtaExpandArg :: SimplEnv -> Demand -> OutExpr -> OutType
+ -> SimplM (ArityType, OutExpr)
+-- See Note [Eta-expanding at let bindings]
+tryEtaExpandArg env arg_dmd arg arg_ty
+ = tryEtaExpandArgOrRhs env Nothing False (argOneShots arg_dmd) arg arg_ty
+
+tryEtaExpandArgOrRhs
+ :: SimplEnv
+ -> Maybe OutId -- ^ `Just bndr` when it's a recursive RHS bound by bndr
+ -> Bool -- ^ Is it a join binding?
+ -> [OneShotInfo] -- ^ The one-shot info from the use sites, perhaps from
+ -- `idDemandOneShots` of the binder
+ -> OutExpr -- ^ The RHS (or argument expression)
+ -> OutType -- ^ Type of the CoreExpr
+ -> SimplM (ArityType, OutExpr)
+-- See Note [Eta-expanding at let bindings]
+tryEtaExpandArgOrRhs env mb_rec_bndr is_join use_one_shots rhs rhs_ty
| do_eta_expand -- If the current manifest arity isn't enough
-- (never true for join points)
, seEtaExpand env -- and eta-expansion is on
, wantEtaExpansion rhs
= -- Do eta-expansion.
- assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $
+ assertPpr( not is_join ) (ppr mb_rec_bndr) $
-- assert: this never happens for join points; see GHC.Core.Opt.Arity
-- Note [Do not eta-expand join points]
- do { tick (EtaExpansion bndr)
+ do { tick (EtaExpansion mb_rec_bndr)
; return (arity_type, etaExpandAT in_scope arity_type rhs) }
| otherwise
- = return (arity_type, rhs)
+ = pprTrace "tryEtaExpandArgOrRhs" (ppr mb_rec_bndr $$ ppr arity_type $$ ppr rhs) $ return (arity_type, rhs)
where
in_scope = getInScope env
arity_opts = seArityOpts env
- is_rec = bindContextRec bind_cxt
- (do_eta_expand, arity_type) = findRhsArity arity_opts is_rec bndr rhs
+ (do_eta_expand, arity_type) = findRhsArity arity_opts mb_rec_bndr is_join use_one_shots rhs rhs_ty
wantEtaExpansion :: CoreExpr -> Bool
-- Mostly True; but False of PAPs which will immediately eta-reduce again
@@ -1890,6 +1914,30 @@ wantEtaExpansion (Var {}) = False
wantEtaExpansion (Lit {}) = False
wantEtaExpansion _ = True
+idDemandOneShots :: Id -> [OneShotInfo]
+idDemandOneShots bndr
+ = call_arity_one_shots `zip_lams` dmd_one_shots
+ where
+ call_arity_one_shots :: [OneShotInfo]
+ call_arity_one_shots
+ | call_arity == 0 = []
+ | otherwise = NoOneShotInfo : replicate (call_arity-1) OneShotLam
+ -- Call Arity analysis says the function is always called
+ -- applied to this many arguments. The first NoOneShotInfo is because
+ -- if Call Arity says "always applied to 3 args" then the one-shot info
+ -- we get is [NoOneShotInfo, OneShotLam, OneShotLam]
+ call_arity = idCallArity bndr
+
+ dmd_one_shots :: [OneShotInfo]
+ -- If the demand info is C(x,C(1,C(1,.))) then we know that an
+ -- application to one arg is also an application to three
+ dmd_one_shots = argOneShots (idDemandInfo bndr)
+
+ -- Take the *longer* list
+ zip_lams (lam1:lams1) (lam2:lams2) = (lam1 `bestOneShot` lam2) : zip_lams lams1 lams2
+ zip_lams [] lams2 = lams2
+ zip_lams lams1 [] = lams1
+
{-
Note [Eta-expanding at let bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Stats.hs
=====================================
@@ -226,7 +226,7 @@ data Tick -- See Note [Which transformations are innocuous]
| RuleFired FastString -- Rule name
| LetFloatFromLet
- | EtaExpansion Id -- LHS binder
+ | EtaExpansion (Maybe Id) -- LHS binder, if recursive
| EtaReduction Id -- Binder on outer lambda
| BetaReduction Id -- Lambda binder
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1219,11 +1219,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) co)
+ , (subst', float, bndr) <- case_bind subst arg arg_type
+ = go subst' (float:floats) fun (CC (Var bndr : args) co)
| otherwise
= go subst floats fun (CC (subst_expr subst arg : args) co)
@@ -1262,8 +1259,9 @@ 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 co
+ , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args
+ = succeedWith in_scope' (seq_floats ++ floats) $
+ pushCoDataCon con args' co
-- Look through data constructor wrappers: they inline late (See Note
-- [Activation for data constructor wrappers]) but we want to do
@@ -1349,6 +1347,36 @@ 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])
+ mkFieldSeqFloats in_scope dc args
+ | Nothing <- dataConRepStrictness_maybe 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 = (in_scope, floats, arg:args)
+ | Var v <- arg, is_evald v = (in_scope, floats, arg:args)
+ | otherwise = (in_scope', float:floats, Var bndr:args)
+ where
+ is_evald v = isId v && isEvaldUnfolding (idUnfolding v)
+ (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 -> Coercion
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1252,18 +1252,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
@@ -1274,98 +1279,34 @@ exprIsCheapX ok_app e
go _ (Type {}) = True
go _ (Coercion {}) = True
go n (Cast e _) = go n e
- go n (Case scrut _ _ alts) = ok scrut &&
- and [ go n rhs | Alt _ _ rhs <- alts ]
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 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 (Case scrut _ _ alts) = not expandable && ok scrut &&
+ and [ go n rhs | Alt _ _ rhs <- alts ]
+ 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
@@ -1384,7 +1325,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
@@ -1399,6 +1340,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
@@ -1430,6 +1372,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
@@ -1573,10 +1559,10 @@ expr_ok fun_ok primop_ok (Case scrut bndr _ alts)
&& altsAreExhaustive alts
expr_ok fun_ok primop_ok other_expr
- | (expr, args) <- collectArgs other_expr
+ | (expr, val_args) <- collectValArgs other_expr
= case stripTicksTopE (not . tickishCounts) expr of
Var f ->
- app_ok fun_ok primop_ok f args
+ app_ok fun_ok primop_ok f val_args
-- 'LitRubbish' is the only literal that can occur in the head of an
-- application and will not be matched by the above case (Var /= Lit).
@@ -1590,8 +1576,8 @@ expr_ok fun_ok primop_ok other_expr
_ -> False
-----------------------------
-app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
-app_ok fun_ok primop_ok fun args
+app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool
+app_ok fun_ok primop_ok fun val_args
| not (fun_ok fun)
= False -- This code path is only taken for Note [Speculative evaluation]
| otherwise
@@ -1600,21 +1586,22 @@ 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 {} -> True
- -- The strictness of the constructor has already
- -- been expressed by its "wrapper", so we don't need
- -- to take the arguments into account
+ DataConWorkId dc
+ | Just str_marks <- dataConRepStrictness_maybe dc
+ -> all3Prefix field_ok str_marks val_arg_tys val_args
+ | otherwise
+ -> all2Prefix arg_ok val_arg_tys val_args
ClassOpId _ is_terminating_result
| is_terminating_result -- See Note [exprOkForSpeculation and type classes]
- -> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $
+ -> assertPpr (n_val_args == 1) (ppr fun $$ ppr val_args) $
True
-- assert: terminating result type => can't be applied;
-- c.f the _other case below
PrimOpId op _
| primOpIsDiv op
- , [arg1, Lit lit] <- args
+ , [arg1, Lit lit] <- val_args
-> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1
-- Special case for dividing operations that fail
-- In general they are NOT ok-for-speculation
@@ -1632,13 +1619,13 @@ app_ok fun_ok primop_ok fun args
| otherwise
-> primop_ok op -- Check the primop itself
- && and (zipWith arg_ok arg_tys args) -- Check the arguments
+ && all2Prefix arg_ok val_arg_tys val_args -- Check the arguments
_other -- Unlifted and terminating types;
-- Also c.f. the Var case of exprIsHNF
| isTerminatingType fun_ty -- See Note [exprOkForSpeculation and type classes]
|| definitelyUnliftedType fun_ty
- -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)
+ -> assertPpr (n_val_args == 0) (ppr fun $$ ppr val_args)
True -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#)
-- are non-functions and so will have no value args. The assert is
-- just to check this.
@@ -1647,7 +1634,7 @@ app_ok fun_ok primop_ok fun args
-- Partial applications
| idArity fun > n_val_args ->
- and (zipWith arg_ok arg_tys args) -- Check the arguments
+ all2Prefix arg_ok val_arg_tys val_args -- Check the arguments
-- Functions that terminate fast without raising exceptions etc
-- See Note [Discarding unnecessary unsafeEqualityProofs]
@@ -1659,18 +1646,27 @@ app_ok fun_ok primop_ok fun args
-- see Note [exprOkForSpeculation and evaluated variables]
where
fun_ty = idType fun
- n_val_args = valArgCount args
+ n_val_args = length val_args
(arg_tys, _) = splitPiTys fun_ty
+ val_arg_tys = mapMaybe anonPiTyBinderType_maybe arg_tys
-- Used for arguments to primops and to partial applications
- arg_ok :: PiTyVarBinder -> CoreExpr -> Bool
- arg_ok (Named _) _ = True -- A type argument
- arg_ok (Anon ty _) arg -- A term argument
- | definitelyLiftedType (scaledThing ty)
+ arg_ok :: Type -> CoreExpr -> Bool
+ arg_ok ty arg
+ | definitelyLiftedType ty
= True -- See Note [Primops with lifted arguments]
| otherwise
= expr_ok fun_ok primop_ok arg
+ -- Used for DataCon worker arguments
+ field_ok :: StrictnessMark -> Type -> CoreExpr -> Bool
+ field_ok str ty arg -- A term argument
+ | NotMarkedStrict <- str -- iff it's a lazy field
+ , definitelyLiftedType 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
@@ -1937,12 +1933,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)
@@ -1966,31 +1964,57 @@ 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 _ = 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
+ -- First handle saturated applications of DataCons with strict fields
+ | Just dc <- isDataConWorkId_maybe id -- DataCon
+ , Just str_marks <- dataConRepStrictness_maybe dc -- with strict fields
+ , assert (val_args `leLength` str_marks) True
+ , val_args `equalLength` str_marks -- in a saturated app
+ = all3Prefix check_field str_marks val_arg_tys val_args
+
+ -- Now all applications except saturated DataCon apps with strict fields
+ | idArity id > length val_args
+ -- PAP: Check unlifted val_args
+ || is_con id && isNothing (isDataConWorkId_maybe id >>= dataConRepStrictness_maybe)
+ -- Either a lazy DataCon or a CONLIKE.
+ -- Hence we only need to check unlifted val_args here.
+ -- NB: We assume that CONLIKEs are lazy, which is their entire
+ -- point.
+ = all2Prefix check_arg val_arg_tys val_args
+
+ | otherwise
+ = False
+ where
+ fun_ty = idType id
+ (arg_tys,_) = splitPiTys fun_ty
+ val_arg_tys = mapMaybe anonPiTyBinderType_maybe arg_tys
+ -- 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
+ -- 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 str a_ty a
+ = isMarkedStrict str || mightBeUnliftedType a_ty ==> is_hnf_like a
+ a ==> b = not a || b
+ infixr 1 ==>
{-
Note [exprIsHNF Tick]
@@ -2551,7 +2575,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/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:
@@ -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 MkT 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
=====================================
@@ -64,7 +64,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.
@@ -217,7 +217,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
it's 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/TyCl/Build.hs
=====================================
@@ -176,12 +176,13 @@ 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 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
=====================================
@@ -1390,33 +1390,8 @@ 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, they act as additional
+seqs; hence we add an additional `C_11` eval.
-}
{- *********************************************************************
@@ -1616,6 +1591,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.
@@ -2326,7 +2324,7 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of
mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv
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 = C_11 :* seqSubDmd -- See Note [Strict fields in Core]
-- | 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
=====================================
@@ -220,7 +220,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
=====================================
@@ -56,7 +56,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
@@ -586,8 +586,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
@@ -595,15 +599,19 @@ mkDataConWorkId wkr_name data_con
`setInlinePragInfo` wkr_inline_prag
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
- -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon
+ `setDmdSigInfo` wkr_sig
+ -- Workers eval their strict fields
+ -- See Note [Strict fields in Core]
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
+
----------- 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
@@ -686,10 +694,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
@@ -744,11 +752,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)
@@ -798,8 +803,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
|| (dataConUserTyVarsNeedWrapper data_con
-- If the data type was written with GADT syntax and
@@ -1077,7 +1082,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
@@ -1107,9 +1112,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
=====================================
@@ -27,7 +27,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,
@@ -646,6 +646,25 @@ 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 xs ys = go xs ys
+ where go (x:xs) (y:ys) = p x y && go xs ys
+ go _ _ = True
+{-# INLINABLE 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 xs ys zs = go xs ys zs
+ where
+ go (x:xs) (y:ys) (z:zs) = p x y z && go xs ys zs
+ go _ _ _ = True
+{-# INLINABLE all3Prefix #-}
+
-- Count the number of times a predicate is true
count :: (a -> Bool) -> [a] -> Int
=====================================
testsuite/tests/simplCore/should_compile/T18013.stderr
=====================================
@@ -17,6 +17,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @((), _) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op pure (BUILTIN)
Rule fired: Class op . (BUILTIN)
@@ -25,6 +27,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @((), _) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Arrow (BUILTIN)
Rule fired: Class op $p1Arrow (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
@@ -38,6 +42,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @((), _) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op first (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
@@ -48,6 +54,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @(_, ()) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op pure (BUILTIN)
Rule fired: Class op . (BUILTIN)
@@ -56,6 +64,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @((), _) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op . (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
@@ -70,6 +80,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @((), _) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Arrow (BUILTIN)
Rule fired: Class op $p1Arrow (BUILTIN)
Rule fired: Class op id (BUILTIN)
@@ -83,6 +95,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @((), _) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op ||| (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
@@ -98,6 +112,8 @@ Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
+Rule fired: mkRule @((), _) (T18013a)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op pure (BUILTIN)
Rule fired: Class op . (BUILTIN)
@@ -108,22 +124,6 @@ Rule fired: Class op >>= (BUILTIN)
Rule fired: Class op pure (BUILTIN)
Rule fired: mkRule @((), _) (T18013a)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @(_, ()) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
-Rule fired: mkRule @((), _) (T18013a)
-Rule fired: Class op fmap (BUILTIN)
Rule fired: mkRule @(_, ()) (T18013a)
Rule fired: Class op fmap (BUILTIN)
Rule fired: mkRule @(_, ()) (T18013a)
@@ -138,9 +138,9 @@ 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,
+ Str=<1!P(SL,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!] ->
@@ -219,36 +219,41 @@ mapMaybeRule
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T18013.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T18013.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T18013.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18013.$trModule3 = GHC.Types.TrNameS T18013.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T18013.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T18013.$trModule2 = "T18013"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T18013.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18013.$trModule1 = GHC.Types.TrNameS T18013.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T18013.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18013.$trModule
= GHC.Types.Module T18013.$trModule3 T18013.$trModule1
=====================================
testsuite/tests/simplCore/should_compile/T23083.hs
=====================================
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+module T23083 where
+
+g :: ((Integer -> Integer) -> Integer) -> (Integer -> Integer) -> Integer
+g f h = f (h `seq` (h $))
=====================================
testsuite/tests/simplCore/should_compile/T23083.stderr
=====================================
@@ -0,0 +1,36 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 21, types: 17, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 6, types: 6, coercions: 0, joins: 0/0}
+g :: ((Integer -> Integer) -> Integer) -> (Integer -> Integer) -> Integer
+[GblId, Arity=2, Str=<1C(1,L)><LC(S,L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 60] 50 0}]
+g = \ (f :: (Integer -> Integer) -> Integer) (h :: Integer -> Integer) -> f (\ (eta :: Integer) -> h eta)
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule4 :: GHC.Prim.Addr#
+[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T23083.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule3 :: GHC.Types.TrName
+[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T23083.$trModule3 = GHC.Types.TrNameS T23083.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule2 :: GHC.Prim.Addr#
+[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T23083.$trModule2 = "T23083"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule1 :: GHC.Types.TrName
+[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T23083.$trModule1 = GHC.Types.TrNameS T23083.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule :: GHC.Types.Module
+[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T23083.$trModule = GHC.Types.Module T23083.$trModule3 T23083.$trModule1
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -417,7 +417,10 @@ test('T21391', normal, compile, ['-O -dcore-lint'])
test('T22112', normal, compile, ['-O -dsuppress-uniques -dno-typeable-binds -ddump-simpl'])
test('T21391a', normal, compile, ['-O -dcore-lint'])
# We don't want to see a thunk allocation for the insertBy expression after CorePrep.
-test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken(21392) ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques'])
+# Unfortunately, this test is no longer broken after we made workers strict in strict fields,
+# so it is no longer a reproducer for T21392. Still, it doesn't hurt if we test that we don't
+# regress again.
+test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]') ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques'])
test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O'])
test('T21801', normal, compile, ['-O -dcore-lint'])
test('T21848', [grep_errmsg(r'SPEC wombat') ], compile, ['-O -ddump-spec'])
@@ -476,3 +479,4 @@ test('T23012', normal, compile, ['-O'])
test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
+test('T23083', [ grep_errmsg(r'f.*eta') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dppr-cols=99999'])
=====================================
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;
}
=====================================
testsuite/tests/stranal/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)>
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/77ef96d9d50fd8512e9bd4324ea5446f1eac1159...964dbea3d708012ecae9077c9e4faa4c88e34a0d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/77ef96d9d50fd8512e9bd4324ea5446f1eac1159...964dbea3d708012ecae9077c9e4faa4c88e34a0d
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/20230307/78cbe786/attachment-0001.html>
More information about the ghc-commits
mailing list