[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Fix nasty bug in occurrence analyser
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Jul 27 04:14:51 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2bb3db36 by Simon Peyton Jones at 2024-07-27T00:14:34-04:00
Fix nasty bug in occurrence analyser
As #25096 showed, the occurrence analyser was getting one-shot info
flat out wrong.
This commit does two things:
* It fixes the bug and actually makes the code a bit tidier too.
The work is done in the new function
GHC.Core.Opt.OccurAnal.mkRhsOccEnv,
especially the bit that prepares the `occ_one_shots` for the RHS.
See Note [The OccEnv for a right hand side]
* When floating out a binding we must be conservative about one-shot
info. But we were zapping the entire demand info, whereas we only
really need zap the /top level/ cardinality.
See Note [Floatifying demand info when floating]
in GHC.Core.Opt.SetLevels
For some reason there is a 2.2% improvement in compile-time allocation
for CoOpt_Read. Otherwise nickels and dimes.
Metric Decrease:
CoOpt_Read
- - - - -
f6ac3d94 by Torsten Schmits at 2024-07-27T00:14:34-04:00
add missing cell in flavours table
- - - - -
15 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Utils/Outputable.hs
- hadrian/doc/flavours.md
- testsuite/tests/simplCore/should_compile/T21286.stderr
- testsuite/tests/simplCore/should_compile/spec-inline.stderr
- + testsuite/tests/simplCore/should_run/T25096.hs
- + testsuite/tests/simplCore/should_run/T25096.stdout
- testsuite/tests/simplCore/should_run/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1039,10 +1039,10 @@ dmdTransform env var sd
TopLevel
| isInterestingTopLevelFn var
-- Top-level things will be used multiple times or not at
- -- all anyway, hence the multDmd below: It means we don't
+ -- all anyway, hence the `floatifyDmd`: it means we don't
-- have to track whether @var@ is used strictly or at most
- -- once, because ultimately it never will.
- -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness
+ -- once, because ultimately it never will
+ -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd))
| otherwise
-> fn_ty -- don't bother tracking; just annotate with 'topDmd' later
-- Everything else:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1035,8 +1035,6 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
| otherwise
= (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )
where
- is_join_point = isJoinPoint mb_join
-
--------- Right hand side ---------
-- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have
-- join j = Just (f x) in ...
@@ -1044,12 +1042,9 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
-- let y = f x in join j = Just y in ...
-- That's that OccRhs would do; but there's no point because
-- j will never be scrutinised.
- env1 | is_join_point = setTailCtxt env
- | otherwise = setNonTailCtxt rhs_ctxt env -- Zap occ_join_points
+ rhs_env = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs
rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf
- -- See Note [Sources of one-shot information]
- rhs_env = addOneShotsFromDmd bndr env1
-- See Note [Join arity prediction based on joinRhsArity]
-- Match join arity O from mb_join_arity with manifest join arity M as
-- returned by of occAnalLamTail. It's totally OK for them to mismatch;
@@ -1059,16 +1054,15 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
final_bndr_with_rules
| noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
| otherwise = bndr `setIdSpecialisation` mkRuleInfo rules'
- `setIdUnfolding` unf2
+ `setIdUnfolding` unf1
final_bndr_no_rules
| noBinderSwaps env = bndr -- See Note [Unfoldings and rules]
- | otherwise = bndr `setIdUnfolding` unf2
+ | otherwise = bndr `setIdUnfolding` unf1
--------- Unfolding ---------
-- See Note [Join points and unfoldings/rules]
unf = idUnfolding bndr
WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf
- unf2 = markNonRecUnfoldingOneShots mb_join unf1
adj_unf_uds = adjustTailArity mb_join unf_tuds
--------- Rules ---------
@@ -1143,10 +1137,8 @@ occAnalRec !_ lvl
| isDeadOcc occ -- Check for dead code: see Note [Dead code]
= WUD body_uds binds
| otherwise
- = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
+ = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr
!(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
- !unf' = markNonRecUnfoldingOneShots mb_join (idUnfolding tagged_bndr)
- !bndr' = tagged_bndr `setIdUnfolding` unf'
in WUD (body_uds `andUDs` rhs_uds')
(NonRec bndr' rhs' : binds)
where
@@ -1751,10 +1743,9 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
-- Instead, do the occAnalLamTail call here and postpone adjustTailUsage
-- until occAnalRec. In effect, we pretend that the RHS becomes a
-- non-recursive join point and fix up later with adjustTailUsage.
- rhs_env | isJoinId bndr = setTailCtxt env
- | otherwise = setNonTailCtxt OccRhs env
- -- If bndr isn't an /existing/ join point, it's safe to zap the
- -- occ_join_points, because they can't occur in RHS.
+ rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs
+ -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint),
+ -- it's safe to zap the occ_join_points, because they can't occur in RHS.
WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs
-- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders
@@ -2168,7 +2159,7 @@ occAnalLamTail env expr
in WTUD (TUD (joinRhsArity expr) usage) expr'
occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
--- Does not markInsidLam etc for the outmost batch of lambdas
+-- Does not markInsideLam etc for the outmost batch of lambdas
occ_anal_lam_tail env expr@(Lam {})
= go env [] expr
where
@@ -2309,20 +2300,8 @@ occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)
-{- Note [Join point RHSs]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- x = e
- join j = Just x
-
-We want to inline x into j right away, so we don't want to give
-the join point a RhsCtxt (#14137). It's not a huge deal, because
-the FloatIn pass knows to float into join point RHSs; and the simplifier
-does not float things out of join point RHSs. But it's a simple, cheap
-thing to do. See #14137.
-
-Note [Occurrences in stable unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Occurrences in stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
f p = BIG
{-# INLINE g #-}
@@ -2358,16 +2337,32 @@ So we have a fast-path that keeps the old tree if the occ_bs_env is
empty. This just saves a bit of allocation and reconstruction; not
a big deal.
-This fast path exposes a tricky cornder, though (#22761). Supose we have
+Two tricky corners:
+
+* Dead bindings (#22761). Supose we have
Unfolding = \x. let y = foo in x+1
-which includes a dead binding for `y`. In occAnalUnfolding we occ-anal
-the unfolding and produce /no/ occurrences of `foo` (since `y` is
-dead). But if we discard the occ-analysed syntax tree (which we do on
-our fast path), and use the old one, we still /have/ an occurrence of
-`foo` -- and that can lead to out-of-scope variables (#22761).
+ which includes a dead binding for `y`. In occAnalUnfolding we occ-anal
+ the unfolding and produce /no/ occurrences of `foo` (since `y` is
+ dead). But if we discard the occ-analysed syntax tree (which we do on
+ our fast path), and use the old one, we still /have/ an occurrence of
+ `foo` -- and that can lead to out-of-scope variables (#22761).
+
+ Solution: always keep occ-analysed trees in unfoldings and rules, so they
+ have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core.
+
+* One-shot binders. Consider
+ {- f has Stable unfolding \p q -> blah
+ Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -}
+ f = \x y. blah
+
+ Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has
+ occ_one_shots = [NoOneShortInfo, OneShotLam]
+ This will put OneShotLam on the \y. And it'll put it on the \q. But the
+ noBinderSwap check will mean that we discard this new occ-anal'd unfolding
+ and keep the old one, with no OneShotInfo.
-Solution: always keep occ-analysed trees in unfoldings and rules, so they
-have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core.
+ This looks a little inconsistent, but the Stable unfolding is just used for
+ inlinings; OneShotInfo isn't a lot of use here.
Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2598,7 +2593,7 @@ occAnalArgs !env fun args !one_shots
| otherwise
= case one_shots of
[] -> (env_args, []) -- Fast path; one_shots is often empty
- (os : one_shots') -> (addOneShots os env_args, one_shots')
+ (os : one_shots') -> (setOneShots os env_args, one_shots')
{-
Applications are dealt with specially because we want
@@ -2910,42 +2905,125 @@ setScrutCtxt !env alts
-- non-default alternative. That in turn influences
-- pre/postInlineUnconditionally. Grep for "occ_int_cxt"!
+{- Note [The OccEnv for a right hand side]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+How do we create the OccEnv for a RHS (in mkRhsOccEnv)?
+
+For a non-join point binding, x = rhs
+
+ * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles
+
+ * occ_join_points: zap them!
+
+ * occ_one_shots: initialise from the idDemandInfo;
+ see Note [Sources of one-shot information]
+
+For a join point binding, j x = rhs
+
+ * occ_encl: Consider
+ x = e
+ join j = Just x
+ We want to inline x into j right away, so we don't want to give the join point
+ a OccRhs (#14137); we want OccVanilla. It's not a huge deal, because the
+ FloatIn pass knows to float into join point RHSs; and the simplifier does not
+ float things out of join point RHSs. But it's a simple, cheap thing to do.
+
+ * occ_join_points: no need to zap.
+
+ * occ_one_shots: we start with one-shot-info from the context, which indeed
+ applies to the /body/ of the join point, after walking past the binders.
+ So we add to the front a OneShotInfo for each value-binder of the join
+ point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point
+ binders caused #25096.)
+
+ For the join point binders themselves, of a /non-recursive/ join point,
+ we make the binder a OneShotLam. Again see `extendOneShotsForJoinPoint`.
+
+ These one-shot infos then get attached to the binder by `occAnalLamTail`.
+-}
+
setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv
setNonTailCtxt ctxt !env
= env { occ_encl = ctxt
, occ_one_shots = []
- , occ_join_points = zapped_jp_env }
- where
- -- zapped_jp_env is basically just emptyVarEnv (hence zapped). See (W3) of
- -- Note [Occurrence analysis for join points] Zapping improves efficiency,
- -- slightly, if you accidentally introduce a bug, in which you zap [jx :-> uds] and
- -- then find an occurrence of jx anyway, you might lose those uds, and
- -- that might mean we don't record all occurrencs, and that means we
- -- duplicate a redex.... a very nasty bug (which I encountered!). Hence
- -- this DEBUG code which doesn't remove jx from the envt; it just gives it
- -- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch
- -- this bug before it does any damage.
-#ifdef DEBUG
- zapped_jp_env = mapVarEnv (\ _ -> emptyVarEnv) (occ_join_points env)
-#else
- zapped_jp_env = emptyVarEnv
-#endif
+ , occ_join_points = zapJoinPointInfo (occ_join_points env) }
setTailCtxt :: OccEnv -> OccEnv
-setTailCtxt !env
- = env { occ_encl = OccVanilla }
+setTailCtxt !env = env { occ_encl = OccVanilla }
-- Preserve occ_one_shots, occ_join points
-- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):
- -- see Note [Join point RHSs]
-addOneShots :: OneShots -> OccEnv -> OccEnv
-addOneShots os !env
+mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv
+-- See Note [The OccEnv for a right hand side]
+-- For a join point:
+-- - Keep occ_one_shots, occ_joinPoints from the context
+-- - But push enough OneShotInfo onto occ_one_shots to account
+-- for the join-point value binders
+-- - Set occ_encl to OccVanilla
+-- For non-join points
+-- - Zap occ_one_shots and occ_join_points
+-- - Set occ_encl to specified OccEncl
+mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points })
+ is_rec encl jp_hood bndr rhs
+ | JoinPoint join_arity <- jp_hood
+ = env { occ_encl = OccVanilla
+ , occ_one_shots = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots
+ , occ_join_points = ctxt_join_points }
+
+ | otherwise
+ = env { occ_encl = encl
+ , occ_one_shots = argOneShots (idDemandInfo bndr)
+ -- argOneShots: see Note [Sources of one-shot information]
+ , occ_join_points = zapJoinPointInfo ctxt_join_points }
+
+zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo
+-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped).
+-- See (W3) of Note [Occurrence analysis for join points]
+--
+-- Zapping improves efficiency, slightly, if you accidentally introduce a bug,
+-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you
+-- might lose those uds, and that might mean we don't record all occurrencs, and
+-- that means we duplicate a redex.... a very nasty bug (which I encountered!).
+-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it
+-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this
+-- bug before it does any damage.
+#ifdef DEBUG
+zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info
+#else
+zapJoinPointInfo _ = emptyVarEnv
+#endif
+
+extendOneShotsForJoinPoint
+ :: RecFlag -> JoinArity -> CoreExpr
+ -> [OneShotInfo] -> [OneShotInfo]
+-- Push enough OneShortInfos on the front of ctxt_one_shots
+-- to account for the value lambdas of the join point
+extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots
+ = go join_arity rhs
+ where
+ -- For a /non-recursive/ join point we can mark all
+ -- its join-lambda as one-shot; and it's a good idea to do so
+ -- But not so for recursive ones
+ os = case is_rec of
+ NonRecursive -> OneShotLam
+ Recursive -> NoOneShotInfo
+
+ go 0 _ = ctxt_one_shots
+ go n (Lam b rhs)
+ | isId b = os : go (n-1) rhs
+ | otherwise = go (n-1) rhs
+ go _ _ = [] -- Not enough lambdas. This can legitimately happen.
+ -- e.g. let j = case ... in j True
+ -- This will become an arity-1 join point after the
+ -- simplifier has eta-expanded it; but it may not have
+ -- enough lambdas /yet/. (Lint checks that JoinIds do
+ -- have enough lambdas.)
+
+setOneShots :: OneShots -> OccEnv -> OccEnv
+setOneShots os !env
| null os = env -- Fast path for common case
| otherwise = env { occ_one_shots = os }
-addOneShotsFromDmd :: Id -> OccEnv -> OccEnv
-addOneShotsFromDmd bndr = addOneShots (argOneShots (idDemandInfo bndr))
-
isRhsEnv :: OccEnv -> Bool
isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
OccRhs -> True
@@ -3732,17 +3810,10 @@ adjustNonRecRhs :: JoinPointHood
-> WithUsageDetails CoreExpr
-- ^ This function concentrates shared logic between occAnalNonRecBind and the
-- AcyclicSCC case of occAnalRec.
--- * It applies 'markNonRecJoinOneShots' to the RHS
--- * and returns the adjusted rhs UsageDetails combined with the body usage
+-- It returns the adjusted rhs UsageDetails combined with the body usage
adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)
- = WUD rhs_uds' rhs'
- where
- --------- Marking (non-rec) join binders one-shot ---------
- !rhs' | JoinPoint ja <- mb_join_arity = markNonRecJoinOneShots ja rhs
- | otherwise = rhs
+ = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs
- --------- Adjusting right-hand side usage ---------
- rhs_uds' = adjustTailUsage mb_join_arity rhs_wuds
adjustTailUsage :: JoinPointHood
-> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail
@@ -3760,33 +3831,6 @@ adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails
adjustTailArity mb_rhs_ja (TUD ja usage)
= markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage
-markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
--- For a /non-recursive/ join point we can mark all
--- its join-lambda as one-shot; and it's a good idea to do so
-markNonRecJoinOneShots join_arity rhs
- = go join_arity rhs
- where
- go 0 rhs = rhs
- go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)
- (go (n-1) rhs)
- go _ rhs = rhs -- Not enough lambdas. This can legitimately happen.
- -- e.g. let j = case ... in j True
- -- This will become an arity-1 join point after the
- -- simplifier has eta-expanded it; but it may not have
- -- enough lambdas /yet/. (Lint checks that JoinIds do
- -- have enough lambdas.)
-
-markNonRecUnfoldingOneShots :: JoinPointHood -> Unfolding -> Unfolding
--- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding
-markNonRecUnfoldingOneShots mb_join_arity unf
- | JoinPoint ja <- mb_join_arity
- , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf
- , isStableSource src
- , let !tmpl' = markNonRecJoinOneShots ja tmpl
- = unf{uf_tmpl=tmpl'}
- | otherwise
- = unf
-
type IdWithOccInfo = Id
tagLamBinders :: UsageDetails -- Of scope
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1874,7 +1874,6 @@ cloneLetVars is_rec
env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
dest_lvl vs
= do { let vs1 = map zap vs
- -- See Note [Zapping the demand info]
; (subst', vs2) <- case is_rec of
NonRecursive -> cloneBndrs subst vs1
Recursive -> cloneRecIdBndrs subst vs1
@@ -1887,9 +1886,12 @@ cloneLetVars is_rec
; return (env', vs2) }
where
zap :: Var -> Var
- zap v | isId v = zap_join (zapIdDemandInfo v)
+ -- See Note [Floatifying demand info when floating]
+ -- and Note [Zapping JoinId when floating]
+ zap v | isId v = zap_join (floatifyIdDemandInfo v)
| otherwise = v
+ -- See Note [Zapping JoinId when floating]
zap_join | isTopLvl dest_lvl = zapJoinId
| otherwise = id
@@ -1898,16 +1900,38 @@ add_id id_env (v, v1)
| isTyVar v = delVarEnv id_env v
| otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)
-{-
-Note [Zapping the demand info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-VERY IMPORTANT: we must zap the demand info if the thing is going to
-float out, because it may be less demanded than at its original
-binding site. Eg
- f :: Int -> Int
- f x = let v = 3*4 in v+x
-Here v is strict; but if we float v to top level, it isn't any more.
-
-Similarly, if we're floating a join point, it won't be one anymore, so we zap
-join point information as well.
+{- Note [Zapping JoinId when floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we are floating a join point, it won't be one anymore, so we zap
+the join point information.
+
+Note [Floatifying demand info when floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When floating we must lazify the outer demand info on the Id
+because it may be less demanded than at its original binding site.
+For example:
+ f :: Int -> Int
+ f x = let v = 3*4 in v+x
+Here v is strict and used at most once; but if we float v to top level,
+that isn't true any more. Specifically, we lose track of v's cardinality info:
+ * if `f` is called multiple times, then `v` is used more than once
+ * if `f` is never called, then `v` is never evaluated.
+
+But NOTE that we only need to adjust the /top-level/ cardinality info.
+For example
+ let x = (e1,e2)
+ in ...(case x of (a,b) -> a+b)...
+If we float x outwards, it may no longer be strict, but IF it is ever
+evaluated THEN its components will be evaluated. So we to lazify and
+many-ify its demand-info, not discard it entirely.
+
+Same if we have
+ let f = \x y . blah
+ in ...(f a b)...(f c d)...
+Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can
+keep that `1C` called-once inner demand. It's only the outer strictness
+that we kill.
+
+Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the
+fact that `v` may be used any number of times, from zero upwards.
-}
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -971,7 +971,7 @@ addLetBndrInfo new_bndr new_arity_type new_unf
-- Demand info: Note [Setting the demand info]
info3 | isEvaldUnfolding new_unf
- = zapDemandInfo info2 `orElse` info2
+ = lazifyDemandInfo info2 `orElse` info2
| otherwise
= info2
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1485,11 +1485,12 @@ specBind top_lvl env (NonRec fn rhs) do_body
-- This is important: see Note [Update unfolding after specialisation]
-- And in any case cloneBndrSM discards non-Stable unfoldings
- fn3 = zapIdDemandInfo fn2
+ fn3 = floatifyIdDemandInfo fn2
-- We zap the demand info because the binding may float,
-- which would invalidate the demand info (see #17810 for example).
-- Destroying demand info is not terrible; specialisation is
-- always followed soon by demand analysis.
+ -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels
body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds
`extendInScope` fn3
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -38,7 +38,7 @@ module GHC.Types.Demand (
-- *** Demands used in PrimOp signatures
lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
-- ** Other @Demand@ operations
- oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd,
+ oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd,
peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, strictCallArity,
mkWorkerDemand, subDemandIfEvaluated,
-- ** Extracting one-shot information
@@ -608,22 +608,22 @@ multCard (Card a) (Card b)
--
-- Examples (using Note [Demand notation]):
--
--- * 'seq' puts demand @1A@ on its first argument: It evaluates the argument
--- strictly (@1@), but not any deeper (@A@).
--- * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument
+-- * 'seq' puts demand `1A` on its first argument: It evaluates the argument
+-- strictly (`1`), but not any deeper (`A`).
+-- * 'fst' puts demand `1P(1L,A)` on its argument: It evaluates the argument
-- pair strictly and the first component strictly, but no nested info
--- beyond that (@L@). Its second argument is not used at all.
--- * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the
--- argument function with one argument, exactly once (@1@). No info
--- on how the result of that call is evaluated (@L@).
--- * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates
+-- beyond that (`L`). Its second argument is not used at all.
+-- * '$' puts demand `1C(1,L)` on its first argument: It calls (`C`) the
+-- argument function with one argument, exactly once (`1`). No info
+-- on how the result of that call is evaluated (`L`).
+-- * 'maybe' puts demand `MC(M,L)` on its second argument: It evaluates
-- the argument function at most once ((M)aybe) and calls it once when
-- it is evaluated.
--- * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@
--- multiplied by two, so we get @S@ (used at least once, possibly multiple
+-- * `fst p + fst p` puts demand `SP(SL,A)` on `p`: It's `1P(1L,A)`
+-- multiplied by two, so we get `S` (used at least once, possibly multiple
-- times).
--
--- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled
+-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled
-- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of
-- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and
-- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there
@@ -1013,6 +1013,11 @@ strictifyDictDmd _ dmd = dmd
lazifyDmd :: Demand -> Demand
lazifyDmd = multDmd C_01
+-- | Adjust the demand on a binding that may float outwards
+-- See Note [Floatifying demand info when floating]
+floatifyDmd :: Demand -> Demand
+floatifyDmd = multDmd C_0N
+
-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@.
mkCalledOnceDmd :: SubDemand -> SubDemand
mkCalledOnceDmd sd = mkCall C_11 sd
@@ -2651,7 +2656,12 @@ So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',
but it's always clear from context which "overload" is meant. It's like
return-type inference of e.g. 'read'.
-Examples are in the haddock for 'Demand'.
+Examples are in the haddock for 'Demand'. Here are some more:
+ SA Strict, but does not look at subcomponents (`seq`)
+ SP(L,L) Strict boxed pair, components lazy
+ S!P(L,L) Strict unboxed pair, components lazy
+ LP(SA,SA) Lazy pair, but if it is evaluated will evaluated its components
+ LC(1C(L)) Lazy, but if called will apply the result exactly once
This is the syntax for demand signatures:
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -54,7 +54,7 @@ module GHC.Types.Id (
setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
- zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
+ zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
zapIdUsedOnceInfo, zapIdTailCallInfo,
zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding,
transferPolyIdInfo, scaleIdBy, scaleVarBy,
@@ -969,12 +969,11 @@ setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id
updOneShotInfo :: Id -> OneShotInfo -> Id
-- Combine the info in the Id with new info
updOneShotInfo id one_shot
- | do_upd = setIdOneShotInfo id one_shot
- | otherwise = id
- where
- do_upd = case (idOneShotInfo id, one_shot) of
- (NoOneShotInfo, _) -> True
- (OneShotLam, _) -> False
+ | OneShotLam <- one_shot
+ , NoOneShotInfo <- idOneShotInfo id
+ = setIdOneShotInfo id OneShotLam
+ | otherwise
+ = id
-- The OneShotLambda functions simply fiddle with the IdInfo flag
-- But watch out: this may change the type of something else
@@ -991,8 +990,9 @@ zapLamIdInfo = zapInfo zapLamInfo
zapFragileIdInfo :: Id -> Id
zapFragileIdInfo = zapInfo zapFragileInfo
-zapIdDemandInfo :: Id -> Id
-zapIdDemandInfo = zapInfo zapDemandInfo
+floatifyIdDemandInfo :: Id -> Id
+-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels
+floatifyIdDemandInfo = zapInfo floatifyDemandInfo
zapIdUsageInfo :: Id -> Id
zapIdUsageInfo = zapInfo zapUsageInfo
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -35,7 +35,8 @@ module GHC.Types.Id.Info (
-- ** Zapping various forms of Info
zapLamInfo, zapFragileInfo,
- zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
+ lazifyDemandInfo, floatifyDemandInfo,
+ zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo,
zapTailCallInfo, zapCallArityInfo, trimUnfolding,
-- ** The ArityInfo type
@@ -855,11 +856,21 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
is_safe_dmd dmd = not (isStrUsedDmd dmd)
--- | Remove all demand info on the 'IdInfo'
-zapDemandInfo :: IdInfo -> Maybe IdInfo
-zapDemandInfo info = Just (info {demandInfo = topDmd})
-
--- | Remove usage (but not strictness) info on the 'IdInfo'
+-- | Lazify (remove the top-level demand, only) the demand in `IdInfo`
+-- Keep nested demands; see Note [Floatifying demand info when floating]
+-- in GHC.Core.Opt.SetLevels
+lazifyDemandInfo :: IdInfo -> Maybe IdInfo
+lazifyDemandInfo info@(IdInfo { demandInfo = dmd })
+ = Just (info {demandInfo = lazifyDmd dmd })
+
+-- | Floatify the demand in `IdInfo`
+-- But keep /nested/ demands; see Note [Floatifying demand info when floating]
+-- in GHC.Core.Opt.SetLevels
+floatifyDemandInfo :: IdInfo -> Maybe IdInfo
+floatifyDemandInfo info@(IdInfo { demandInfo = dmd })
+ = Just (info {demandInfo = floatifyDmd dmd })
+
+-- | Remove usage (but not strictness) info on the `IdInfo`
zapUsageInfo :: IdInfo -> Maybe IdInfo
zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1261,7 +1261,7 @@ data BindingSite
data JoinPointHood
= JoinPoint {-# UNPACK #-} !Int -- The JoinArity (but an Int here because
- | NotJoinPoint -- synonym JoinArity is defined in Types.Basic
+ | NotJoinPoint -- synonym JoinArity is defined in Types.Basic)
deriving( Eq )
isJoinPoint :: JoinPointHood -> Bool
=====================================
hadrian/doc/flavours.md
=====================================
@@ -108,6 +108,7 @@ when compiling the `compiler` library, and `hsGhc` when compiling/linking the GH
</tr>
<tr>
<th>release (same as perf with -haddock)</td>
+ <td></td>
<td>-O<br>-H64m</td>
<td>-O<br>-H64m</td>
<td></td>
=====================================
testsuite/tests/simplCore/should_compile/T21286.stderr
=====================================
@@ -7,10 +7,10 @@ Rule fired: Class op fromInteger (BUILTIN)
Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
+Rule fired: SPEC/T21286 g @Int (T21286)
Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
Rule fired: SPEC/T21286 g @Int (T21286)
-Rule fired: SPEC/T21286 g @Int (T21286)
Rule fired: ==# (BUILTIN)
Rule fired: tagToEnum# (BUILTIN)
Rule fired: tagToEnum# (BUILTIN)
=====================================
testsuite/tests/simplCore/should_compile/spec-inline.stderr
=====================================
@@ -88,7 +88,7 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int
GHC.Types.I# ww
}}]
Roman.foo_go
- = \ (u :: Maybe Int) (ds :: Maybe Int) ->
+ = \ (u :: Maybe Int) (ds [OS=OneShot] :: Maybe Int) ->
case Roman.$wgo u ds of ww { __DEFAULT -> GHC.Types.I# ww }
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
=====================================
testsuite/tests/simplCore/should_run/T25096.hs
=====================================
@@ -0,0 +1,20 @@
+module Main where
+
+import System.IO.Unsafe
+import Control.Monad
+
+main :: IO ()
+main = do
+ foo "test" 10
+
+foo :: String -> Int -> IO ()
+foo x n = go n
+ where
+ oops = unsafePerformIO (putStrLn "Once" >> pure (cycle x))
+
+ go 0 = return ()
+ go n = do
+ -- `oops` should be shared between loop iterations
+ let p = take n oops
+ let !_ = unsafePerformIO (putStrLn p >> pure ())
+ go (n-1)
=====================================
testsuite/tests/simplCore/should_run/T25096.stdout
=====================================
@@ -0,0 +1,11 @@
+Once
+testtestte
+testtestt
+testtest
+testtes
+testte
+testt
+test
+tes
+te
+t
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -115,3 +115,4 @@ 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('T24725', normal, compile_and_run, ['-O -dcore-lint'])
+test('T25096', normal, compile_and_run, ['-O -dcore-lint'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/944992e7512ab89a02f270819e559e402c2cf2ed...f6ac3d94d595a8b5b751464f1f23d1c16a60a7c5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/944992e7512ab89a02f270819e559e402c2cf2ed...f6ac3d94d595a8b5b751464f1f23d1c16a60a7c5
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/20240727/31ffb7f7/attachment-0001.html>
More information about the ghc-commits
mailing list