[Git][ghc/ghc][wip/T22404] Sundry perf improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jul 14 11:35:28 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
78e96385 by Simon Peyton Jones at 2023-07-14T12:34:57+01:00
Sundry perf improvements
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unfold/Make.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -954,17 +954,37 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
= let !(WUD body_uds res) = addInScope env [bndr] thing_inside
in WUD body_uds (combine [NonRec bndr rhs] res)
+ -- Fast path for top level, non-recursive bindings, with no unfoldings or rules
+ | TopLevel <- lvl
+ , not (idHasRules bndr)
+ , not (bndr `elemVarEnv` ire)
+ = let !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
+ in if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
+ then WUD body_uds body
+ else let
+ unf = idUnfolding bndr
+ rhs_env = addOneShotsFromDmd bndr $
+ setNonTailCtxt OccRhs env
+ !rhs_wuds@(WTUD _ rhs') = occAnalLamTail rhs_env rhs
+ !(WTUD (TUD _ unf_uds) _) = occAnalUnfolding rhs_env unf
+ rhs_uds = adjustTailUsage Nothing rhs_wuds
+ full_rhs_uds | isStableUnfolding unf = rhs_uds `andUDs` markAllNonTail unf_uds
+ | otherwise = rhs_uds
+
+ in WUD (full_rhs_uds `andUDs` body_uds) -- Note `andUDs`
+ (combine [NonRec tagged_bndr rhs'] body)
+
-- /Existing/ non-recursive join points
-- Analyse the RHS and /then/ the body
| NotTopLevel <- lvl
, mb_join@(Just {}) <- isJoinId_maybe bndr
= 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 ire mb_join bndr rhs
rhs_uds = foldr1 orUDs rhs_uds_s -- Note orUDs
-- Now analyse the body, adding the join point
-- into the environment with addJoinPoint
- WUD body_uds (tagged_bndr, body)
+ !(WUD body_uds (tagged_bndr, body))
= occAnalNonRecBody env NotTopLevel bndr' $ \env ->
thing_inside (addJoinPoint env bndr' rhs_uds)
in
@@ -977,7 +997,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- Analyse the body and /then/ the RHS
| otherwise
= let
- WUD body_uds (tagged_bndr, body) = occAnalNonRecBody env lvl bndr thing_inside
+ !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
in if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
then WUD body_uds body
else let
@@ -985,7 +1005,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- See Note [Join points and unfoldings/rules]
-- => join arity O of Note [Join arity prediction based on joinRhsArity]
mb_join = willBeJoinId_maybe tagged_bndr
- (rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env ire mb_join tagged_bndr rhs
+ !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env ire mb_join tagged_bndr rhs
in WUD (foldr andUDs body_uds rhs_uds_s) -- Note `andUDs`
(combine [NonRec final_bndr rhs'] body)
@@ -993,6 +1013,8 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
occAnalNonRecBody :: OccEnv -> TopLevelFlag -> Id
-> (OccEnv -> WithUsageDetails r) -- Scope of the bind
-> (WithUsageDetails (Id, r))
+{-# INLINE occAnalNonRecBody #-}
+-- INLINE: it's small and higher order, just a macro really
occAnalNonRecBody env lvl bndr thing_inside
= addInScope env [bndr] $ \env ->
let !(WUD inner_uds res) = thing_inside env
@@ -1016,7 +1038,7 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
| otherwise = OccRhs
-- See Note [Sources of one-shot information]
- rhs_env = env1 { occ_one_shots = argOneShots dmd }
+ 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;
@@ -1061,7 +1083,6 @@ occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs
-> active && not_stable
_ -> False
- dmd = idDemandInfo bndr
active = isAlwaysActive (idInlineActivation bndr)
not_stable = not (isStableUnfolding unf)
@@ -1108,7 +1129,7 @@ occAnalRec !_ lvl
(AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
(WUD body_uds binds)
= WUD (body_uds `andUDs` rhs_uds')
- (NonRec bndr' rhs' : binds)
+ (NonRec bndr' rhs' : binds)
where
tagged_bndr = tagNonRecBinder lvl body_uds bndr
mb_join_arity = willBeJoinId_maybe tagged_bndr
@@ -2114,7 +2135,7 @@ occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
-- manifest arity and adjustTailUsage does the fixup.
-- See Note [Adjusting right-hand sides]
occAnalLamTail env expr
- = let WUD usage expr' = occ_anal_lam_tail env expr
+ = let !(WUD usage expr') = occ_anal_lam_tail env expr
in WTUD (TUD (joinRhsArity expr) usage) expr'
occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
@@ -2122,7 +2143,7 @@ occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
occ_anal_lam_tail env (Lam bndr expr)
| isTyVar bndr
= addInScope env [bndr] $ \env ->
- let WUD usage expr' = occ_anal_lam_tail env expr
+ let !(WUD usage expr') = occ_anal_lam_tail env expr
in WUD usage (Lam bndr expr')
-- Important: Do not modify occ_encl, so that with a RHS like
-- \(@ x) -> K @x (f @x)
@@ -2141,7 +2162,7 @@ occ_anal_lam_tail env (Lam bndr expr)
-- See Note [The oneShot function]
env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
- WUD usage expr' = occ_anal_lam_tail env1 expr
+ !(WUD usage expr') = occ_anal_lam_tail env1 expr
bndr2 = tagLamBinder usage bndr1
in WUD usage (Lam bndr2 expr')
@@ -2454,7 +2475,7 @@ occAnal env (Tick tickish body)
= WUD (markAllNonTail usage) (Tick tickish body')
| Breakpoint _ _ ids _ <- tickish
- = WUD (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body')
+ = WUD (usage_lam `andUDs` foldl' addManyOccId emptyDetails ids) (Tick tickish body')
-- never substitute for any of the Ids in a Breakpoint
| otherwise
@@ -2521,7 +2542,9 @@ occAnal env (Let bind body)
= occAnalBind env NotTopLevel noImpRuleEdges bind
(\env -> occAnal env body) mkLets
-occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr
+occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr]
+ -> [OneShots] -- Very commonly empty, notably prior to dmd anal
+ -> WithUsageDetails CoreExpr
-- The `fun` argument is just an accumulating parameter,
-- the base for building the application we return
occAnalArgs !env fun args !one_shots
@@ -2535,8 +2558,12 @@ occAnalArgs !env fun args !one_shots
where
!(WUD arg_uds arg') = occAnal arg_env arg
!(arg_env, one_shots')
- | isTypeArg arg = (env, one_shots)
- | otherwise = addOneShots env_args one_shots
+ | isTypeArg arg
+ = (env, one_shots)
+ | otherwise
+ = case one_shots of
+ [] -> (env, []) -- Fast path; one_shots is often empty
+ (os : one_shots') -> (addOneShots os env_args, one_shots')
{-
Applications are dealt with specially because we want
@@ -2856,11 +2883,13 @@ setTailCtxt !env
-- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):
-- see Note [Join point RHSs]
-addOneShots :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
-addOneShots !env one_shots
- = case one_shots of
- [] -> (env, [])
- (os:oss) -> (env { occ_one_shots = os }, oss)
+addOneShots :: OneShots -> OccEnv -> OccEnv
+addOneShots 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
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -443,23 +443,30 @@ emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv
getRules :: RuleEnv -> Id -> [CoreRule]
-- Given a RuleEnv and an Id, find the visible rules for that Id
-- See Note [Where rules are found]
-getRules (RuleEnv { re_local_rules = local_rules
- , re_home_rules = home_rules
- , re_eps_rules = eps_rules
+--
+-- This function is quite heavily used, so it's worth trying to make it efficient
+getRules (RuleEnv { re_local_rules = local_rule_base
+ , re_home_rules = home_rule_base
+ , re_eps_rules = eps_rule_base
, re_visible_orphs = orphs }) fn
+ | isLocalId fn
+ = idCoreRules fn
+
| Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers
= [] -- and wrappers, which never have any rules
| otherwise
- = idCoreRules fn ++
- get local_rules ++
- find_visible home_rules ++
- find_visible eps_rules
-
+ = case (get local_rule_base, get home_rule_base, get eps_rule_base) of
+ ([], [], []) -> idCoreRules fn
+ (local_rules, home_rules, eps_rules) -> local_rules ++
+ drop_orphs home_rules ++
+ drop_orphs eps_rules ++
+ idCoreRules fn
where
fn_name = idName fn
- find_visible rb = filter (ruleIsVisible orphs) (get rb)
+ drop_orphs [] = [] -- Fast path
+ drop_orphs xs = filter (ruleIsVisible orphs) xs
get rb = lookupNameEnv rb fn_name `orElse` []
ruleIsVisible :: ModuleSet -> CoreRule -> Bool
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -180,24 +180,6 @@ instance Outputable CallCtxt where
ppr RuleArgCtxt = text "RuleArgCtxt"
{-
-Note [Occurrence analysis of unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do occurrence-analysis of unfoldings once and for all, when the
-unfolding is built, rather than each time we inline them.
-
-But given this decision it's vital that we do
-*always* do it. Consider this unfolding
- \x -> letrec { f = ...g...; g* = f } in body
-where g* is (for some strange reason) the loop breaker. If we don't
-occ-anal it when reading it in, we won't mark g as a loop breaker, and
-we may inline g entirely in body, dropping its binding, and leaving
-the occurrence in f out of scope. This happened in #8892, where
-the unfolding in question was a DFun unfolding.
-
-But more generally, the simplifier is designed on the
-basis that it is looking at occurrence-analysed expressions, so better
-ensure that they actually are.
-
Note [Calculate unfolding guidance on the non-occ-anal'd expression]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notice that we give the non-occur-analysed expression to
=====================================
compiler/GHC/Core/Unfold/Make.hs
=====================================
@@ -86,7 +86,7 @@ mkDFunUnfolding bndrs con ops
= DFunUnfolding { df_bndrs = bndrs
, df_con = con
, df_args = map occurAnalyseExpr ops }
- -- See Note [Occurrence analysis of unfoldings]
+ -- See Note [OccInfo in unfoldings and rules] in GHC.Core
mkDataConUnfolding :: CoreExpr -> Unfolding
-- Used for non-newtype data constructors with non-trivial wrappers
@@ -338,7 +338,7 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
mkCoreUnfolding src top_lvl expr precomputed_cache guidance
= CoreUnfolding { uf_tmpl = cache `seq`
occurAnalyseExpr expr
- -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]
+ -- occAnalyseExpr: see Note [OccInfo in unfoldings and rules] in GHC.Core
-- See #20905 for what a discussion of this 'seq'.
-- We are careful to make sure we only
-- have one copy of an unfolding around at once.
@@ -459,7 +459,7 @@ With that in mind we want to maintain the invariant that each unfolding only ref
a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding.
* The template of the unfolding is the result of performing occurrence analysis
- (Note [Occurrence analysis of unfoldings])
+ (Note [OccInfo in unfoldings and rules] in GHC.Core)
* Predicates are applied to the unanalysed expression
Therefore if we are not thoughtful about forcing you can end up in a situation where the
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78e96385b274a9e7804cc96525d1c6d586cfcdde
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/78e96385b274a9e7804cc96525d1c6d586cfcdde
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/20230714/d7fd6109/attachment-0001.html>
More information about the ghc-commits
mailing list