[Git][ghc/ghc][wip/T22404] Another try at making occ_anal_lam_tail more inefficient
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Jul 27 08:22:00 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
73c78274 by Simon Peyton Jones at 2023-07-27T09:21:23+01:00
Another try at making occ_anal_lam_tail more inefficient
Avoid the environment swizzling when there are no binder swaps
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -2175,13 +2175,14 @@ occAnalLamTail env expr
occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
-- Does not markInsidLam etc for the outmost batch of lambdas
occ_anal_lam_tail env expr@(Lam {})
- = go env emptyVarSet [] expr
+ = go env [] expr
where
- go :: OccEnv -> VarSet -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr
- go env bndr_set rev_bndrs (Lam bndr body)
+ go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr
+ go env rev_bndrs (Lam bndr body)
| isTyVar bndr
- = go env (bndr_set `extendVarSet` bndr) (bndr:rev_bndrs) body
- -- Important: Do not modify occ_encl, so that with a RHS like
+ = go env (bndr:rev_bndrs) body
+ -- Important: Unlike a value binder, do not modify occ_encl
+ -- to OccVanilla, so that with a RHS like
-- \(@ x) -> K @x (f @x)
-- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain
-- from inlining f. See the beginning of Note [Cascading inlines].
@@ -2196,10 +2197,10 @@ occ_anal_lam_tail env expr@(Lam {})
-- due to explicit use of the magic 'oneShot' function.
-- See Note [The oneShot function]
env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
- in go env' (bndr_set `extendVarSet` bndr') (bndr':rev_bndrs) body
+ in go env' (bndr':rev_bndrs) body
- go env bndr_set rev_bndrs body
- = addInScope env bndr_set $ \env ->
+ go env rev_bndrs body
+ = addInScope env rev_bndrs $ \env ->
let !(WUD usage body') = occ_anal_lam_tail env body
wrap_lam body bndr = Lam (tagLamBinder usage bndr) body
in WUD (usage `addLamCoVarOccs` rev_bndrs)
@@ -2935,25 +2936,32 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
addInScopeList :: OccEnv -> [Var]
-> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
{-# INLINE addInScopeList #-}
-addInScopeList env bndrs = addInScope env (mkVarSet bndrs)
+addInScopeList env bndrs = addInScope env bndrs
addInScopeOne :: OccEnv -> Id
-> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
{-# INLINE addInScopeOne #-}
-addInScopeOne env bndr = addInScope env (unitVarSet bndr)
+addInScopeOne env bndr = addInScope env [bndr]
-addInScope :: OccEnv -> VarSet
+addInScope :: OccEnv -> [Var]
-> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
{-# INLINE addInScope #-}
-- This function is called a lot, so we want to inline the fast path
-- The bndr_set must include TyVars as well as Ids, because of (BS3)
-- in Note [Binder swap]
-addInScope env bndr_set thing_inside
+addInScope env bndrs thing_inside
+ | isEmptyVarEnv (occ_bs_env env)
+ , isEmptyVarEnv (occ_join_points env)
+ , WUD uds res <- thing_inside env
+ = WUD (delBndrsFromUDs bndrs uds) res
+
+ | otherwise
= WUD uds' res
where
+ bndr_set = mkVarSet bndrs
!(env', bad_joins) = preprocess_env env bndr_set
!(WUD uds res) = thing_inside env'
- uds' = postprocess_uds bndr_set bad_joins uds
+ uds' = postprocess_uds bndrs bad_joins uds
preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)
preprocess_env env@(OccEnv { occ_join_points = join_points
@@ -2965,6 +2973,8 @@ preprocess_env env@(OccEnv { occ_join_points = join_points
drop_shadowed_swaps :: OccEnv -> OccEnv
-- See Note [The binder-swap substitution] (BS3)
drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env })
+ | isEmptyVarEnv swap_env
+ = env
| bs_rng_vars `intersectsVarSet` bndr_set
= env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| otherwise
@@ -2989,9 +2999,9 @@ preprocess_env env@(OccEnv { occ_join_points = join_points
not (bndr_fm `disjointUFM` join_uds) ||
rest
-postprocess_uds :: VarSet -> JoinPointInfo -> UsageDetails -> UsageDetails
-postprocess_uds bndr_set bad_joins uds
- = add_bad_joins (delBndrsFromUDs bndr_set uds)
+postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails
+postprocess_uds bndrs bad_joins uds
+ = add_bad_joins (delBndrsFromUDs bndrs uds)
where
add_bad_joins :: UsageDetails -> UsageDetails
-- Add usage info for occ_join_points that we cannot push inwards
@@ -3585,17 +3595,14 @@ mkSimpleDetails env = UD { ud_env = env
modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails
modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }
-delBndrsFromUDs :: VarSet -> UsageDetails -> UsageDetails
+delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails
-- Delete these binders from the UsageDetails
-delBndrsFromUDs bndr_set (UD { ud_env = env, ud_z_many = z_many
- , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail })
- = UD { ud_env = env `minusUFM` bndr_fm
- , ud_z_many = z_many `minusUFM` bndr_fm
- , ud_z_in_lam = z_in_lam `minusUFM` bndr_fm
- , ud_z_tail = z_tail `minusUFM` bndr_fm }
- where
- bndr_fm :: UniqFM Var Var
- bndr_fm = getUniqSet bndr_set
+delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many
+ , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail })
+ = UD { ud_env = env `delVarEnvList` bndrs
+ , ud_z_many = z_many `delVarEnvList` bndrs
+ , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs
+ , ud_z_tail = z_tail `delVarEnvList` bndrs }
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73c782743d267d55f69012cd7ba5f4571e7d33f6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/73c782743d267d55f69012cd7ba5f4571e7d33f6
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/20230727/531a89d3/attachment-0001.html>
More information about the ghc-commits
mailing list