[Git][ghc/ghc][wip/T24251a] 2 commits: wibble dropping evals
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Mar 23 17:22:48 UTC 2024
Simon Peyton Jones pushed to branch wip/T24251a at Glasgow Haskell Compiler / GHC
Commits:
d9299d71 by Simon Peyton Jones at 2024-03-23T16:37:03+00:00
wibble dropping evals
- - - - -
2417f339 by Simon Peyton Jones at 2024-03-23T17:17:36+00:00
Account for bottoming functions in OccurAnal
This fixes #24582, a small but long-standing bug
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- + testsuite/tests/perf/compiler/T24582.hs
- testsuite/tests/perf/compiler/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -14,12 +14,14 @@ import GHC.Types.Var.Env ( mkInScopeSet )
import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding
, idInlineActivation, setInlineActivation
, zapIdOccInfo, zapIdUsageInfo, idInlinePragma
- , isJoinId, idJoinPointHood, idUnfolding, isDeadBinder )
+ , isJoinId, idJoinPointHood, idUnfolding
+ , zapIdUnfolding, isDeadBinder )
import GHC.Core.Utils ( mkAltExpr, exprIsTickedString
, stripTicksE, stripTicksT, mkTicks )
import GHC.Core.FVs ( exprFreeVars )
import GHC.Core.Type ( tyConAppArgs )
import GHC.Core
+import GHC.Core.Utils ( exprIsTrivial )
import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe )
import GHC.Utils.Outputable
import GHC.Types.Basic
@@ -714,8 +716,10 @@ cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
cseCase env scrut bndr ty alts
- | Just body' <- caseElim scrut' bndr' alts'
- = Let (NonRec bndr' scrut') body'
+ | Just body <- caseElim scrut bndr alts
+ , -- See Note [Eliminating redundant cases]
+ let zapped_bndr = zapIdUnfolding bndr -- Wrinkle (ERC1)
+ = cseExpr env (Let (NonRec zapped_bndr scrut) body)
| otherwise
= Case scrut' bndr' ty' alts'
@@ -753,7 +757,7 @@ cseCase env scrut bndr ty alts
where
(env', args') = addBinders alt_env args
-caseElim :: OutExpr -> OutId -> [OutAlt] -> Maybe OutExpr
+caseElim :: InExpr -> InId -> [InAlt] -> Maybe InExpr
-- Can we eliminate the case altogether? If so return the body.
-- Note [Eliminating redundant cases]
caseElim scrut case_bndr alts
@@ -781,7 +785,8 @@ isEvaldSoon (v1,v2) expr
go (Case scrut cb _ alts)
= go scrut ||
- (all go_alt alts &&
+ (exprIsTrivial scrut &&
+ all go_alt alts &&
not (hit cb) && -- Check for
all ok_alt alts) -- shadowing
-- ok_alt only runs if things look good
@@ -844,7 +849,44 @@ turning K2 into 'x' increases the number of live variables. But
Note [Eliminating redundant cases]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Still to be written... TODO
+Consider
+ case x of x' { DEFAULT ->
+ case y of y' { DEFAULT ->
+ let v = <thunk> in
+ case x' of { True -> e1; False -> e2 }
+ body }}}
+
+The initial `seq` of `x` is redundant. But the Simplifier is generally
+careful not to drop that outer `case x` based on its demand-info: see Note
+[Case-to-let for strictly-used binders] in GHC.Core.Opt.Simplify.Iteration.
+
+Instead we piggy-back on CSE to eliminate it, based on peeking at the body
+of the case, using isEvaldSonn, to see `x` is evaluated "soon" in the code
+path that follows. If so we transform the `case` to a `let`
+ let x' = x in
+ case y of y' ... etc...
+
+
+The notion of "soon" is a bit squishy. We allow
+interchanging eval's (as in the `case x` vs `case y` above. But what about
+ case x of x' { DEFAULT ->
+ case (f y) of y' { DEFAULT ->
+ case x' of { True -> e1; False -> e2 }
+If we drop the `seq` on `x` we fall vicitm of #21741. There is nothing
+wrong semantically with dropping the `seq`, but the case of #21741 it causes
+a big space leak.
+
+To so the conditions in isEvaldSoon are quite narrow: the two evals are
+separated only by lets and other evals on /variables/.
+
+As Note [Case-to-let for strictly-used binders] point out, dropping the eval is
+not a huge deal, because the inner eval should just be a multi-way jump (no actual
+eval), but it tidies up the code. By putting it here in CSE we don't impose a
+significant peformance penalty.
+
+Wrinkle (ERC1):
+ x' will have an (OtherCon []) unfolding on it. We want to zap that
+ unfolding before turning it into (let x' = x in ...).
Note [Combine case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -983,7 +983,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
| mb_join@(JoinPoint {}) <- idJoinPointHood bndr
= -- Analyse the RHS and /then/ the body
let -- Analyse the rhs first, generating rhs_uds
- !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env ire mb_join bndr rhs
+ !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs
rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of
-- Note [Occurrence analysis for join points]
@@ -1009,7 +1009,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- => join arity O of Note [Join arity prediction based on joinRhsArity]
(tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
- !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env ire mb_join tagged_bndr rhs
+ !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs
in WUD (foldr andUDs body_uds rhs_uds_s) -- Note `andUDs`
(combine [NonRec final_bndr rhs'] body)
@@ -1024,10 +1024,10 @@ occAnalNonRecBody env bndr thing_inside
in WUD inner_uds (occ, res)
-----------------
-occAnalNonRecRhs :: OccEnv -> ImpRuleEdges -> JoinPointHood
- -> Id -> CoreExpr
+occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges
+ -> JoinPointHood -> Id -> CoreExpr
-> ([UsageDetails], Id, CoreExpr)
-occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
+occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs
| null rules, null imp_rule_infos
= -- Fast path for common case of no rules. This is only worth
-- 0.1% perf on average, but it's also only a line or two of code
@@ -1046,7 +1046,7 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
-- j will never be scrutinised.
env1 | is_join_point = setTailCtxt env
| otherwise = setNonTailCtxt rhs_ctxt env -- Zap occ_join_points
- rhs_ctxt = mkNonRecRhsCtxt bndr unf
+ rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf
-- See Note [Sources of one-shot information]
rhs_env = addOneShotsFromDmd bndr env1
@@ -1092,9 +1092,9 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
[ l `andUDs` adjustTailArity mb_join r
| (_,l,r) <- rules_w_uds ]
-mkNonRecRhsCtxt :: Id -> Unfolding -> OccEncl
+mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl
-- Precondition: Id is not a join point
-mkNonRecRhsCtxt bndr unf
+mkNonRecRhsCtxt lvl bndr unf
| certainly_inline = OccVanilla -- See Note [Cascading inlines]
| otherwise = OccRhs
where
@@ -1103,11 +1103,12 @@ mkNonRecRhsCtxt bndr unf
-- has set the OccInfo for this binder before calling occAnalNonRecRhs
case idOccInfo bndr of
OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }
- -> active && not_stable
+ -> active && not stable_unf && not top_bottoming
_ -> False
active = isAlwaysActive (idInlineActivation bndr)
- not_stable = not (isStableUnfolding unf)
+ stable_unf = isStableUnfolding unf
+ top_bottoming = isTopLevel lvl && isDeadEndId bndr
-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
@@ -2410,7 +2411,7 @@ float ==>
This is worse than the slow cascade, so we only want to say "certainly_inline"
if it really is certain. Look at the note with preInlineUnconditionally
-for the various clauses.
+for the various clauses. See #24582 for an example of the two getting out of sync.
************************************************************************
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -749,7 +749,7 @@ prepareRhs env top_lvl occ rhs0
| is_expandable = anfise rhs0
| otherwise = return (emptyLetFloats, rhs0)
where
- -- We can' use exprIsExpandable because the WHOLE POINT is that
+ -- We can't use exprIsExpandable because the WHOLE POINT is that
-- we want to treat (K <big>) as expandable, because we are just
-- about "anfise" the <big> expression. exprIsExpandable would
-- just say no!
=====================================
testsuite/tests/perf/compiler/T24582.hs
=====================================
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fmax-simplifier-iterations=20 #-}
+-- This module made the Simplifier iterate for ever
+
+module T24582(woo) where
+
+
+foo :: String -> Int -> a
+{-# NOINLINE foo #-}
+foo s _ = error s
+
+f :: (Int->Int) -> Int
+{-# NOINLINE f #-}
+f g = g 3
+
+x :: Int -> a
+x = foo "urk"
+
+woo = f x
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -716,3 +716,8 @@ test ('LookupFusion',
test('T24471',
[req_th, collect_compiler_stats('all', 5)],
multimod_compile, ['T24471', '-v0 -O'])
+
+test ('T24582',
+ [ collect_compiler_stats('bytes allocated',5) ],
+ compile,
+ ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/47840e7407f57734190658778c9a42f19d3786a2...2417f3397040d302e041bc73b0a7c15a94ec79fe
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/47840e7407f57734190658778c9a42f19d3786a2...2417f3397040d302e041bc73b0a7c15a94ec79fe
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/20240323/97475f84/attachment-0001.html>
More information about the ghc-commits
mailing list