[Git][ghc/ghc][wip/T22404] Dealing with lambdas again
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sun Jul 23 22:10:50 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
702dc152 by Simon Peyton Jones at 2023-07-23T23:09:38+01:00
Dealing with lambdas again
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -942,14 +942,14 @@ occAnalBind
-> WithUsageDetails r -- Of the whole let(rec)
occAnalBind env lvl ire (Rec pairs) thing_inside combine
- = addInScope env (map fst pairs) $ \env ->
+ = addInScopeList env (map fst pairs) $ \env ->
let WUD body_uds body' = thing_inside env
WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds
in WUD bind_uds (combine binds' body')
occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
| isTyVar bndr -- A type let; we don't gather usage info
- = let !(WUD body_uds res) = addInScope env [bndr] thing_inside
+ = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside
in WUD body_uds (combine [NonRec bndr rhs] res)
-- /Existing/ non-recursive join points
@@ -1022,7 +1022,7 @@ occAnalNonRecBody :: OccEnv -> Id
-> (OccEnv -> WithUsageDetails r) -- Scope of the bind
-> (WithUsageDetails (OccInfo, r))
occAnalNonRecBody env bndr thing_inside
- = addInScope env [bndr] $ \env ->
+ = addInScopeOne env bndr $ \env ->
let !(WUD inner_uds res) = thing_inside env
!occ = lookupLetDetails inner_uds bndr
in WUD inner_uds (occ, res)
@@ -2157,19 +2157,19 @@ 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 [] expr
+ = go env emptyVarSet [] expr
where
- go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr
- go env rev_bndrs (Lam bndr expr)
+ go :: OccEnv -> IdSet -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr
+ go env id_set rev_bndrs (Lam bndr body)
| isTyVar bndr
- = go env (bndr:rev_bndrs) expr
- -- Important: Do not modify occ_encl, 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].
+ = go env id_set (bndr:rev_bndrs) body
+ -- Important: Do not modify occ_encl, 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].
| otherwise
- = let (env_one_shots', bndr1)
+ = let (env_one_shots', bndr')
= case occ_one_shots env of
[] -> ([], bndr)
(os : oss) -> (oss, updOneShotInfo bndr os)
@@ -2177,17 +2177,15 @@ occ_anal_lam_tail env expr@(Lam {})
-- one-shot info might be better than what we can infer, e.g.
-- due to explicit use of the magic 'oneShot' function.
-- See Note [The oneShot function]
- env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
- in go env1 (bndr1 : rev_bndrs) expr
-
- go env rev_bndrs expr
- = let bndrs = reverse rev_bndrs in
- addInScope env bndrs $ \env ->
- let !(WUD usage expr') = occ_anal_lam_tail env expr
- bndrs' = tagLamBinders usage bndrs
- in WUD (usage `addLamCoVarOccs` bndrs)
- (mkLams bndrs' expr')
- -- addLamCoVarOccs: see Note [Gather occurrences of coercion variables]
+ env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
+ in go env' (id_set `extendVarSet` bndr') (bndr':rev_bndrs) body
+
+ go env id_set rev_bndrs body
+ = addInScope env id_set $ \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)
+ (foldl' wrap_lam body' rev_bndrs)
-- For casts, keep going in the same lambda-group
-- See Note [Occurrence analysis for lambda binders]
@@ -2266,7 +2264,7 @@ occAnalUnfolding !env unf
-- scope remain in scope; there is no cloning etc.
unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
- -> let WUD uds args' = addInScope env bndrs $ \ env ->
+ -> let WUD uds args' = addInScopeList env bndrs $ \ env ->
occAnalList env args
in WTUD (TUD 0 uds) (unf { df_args = args' })
-- No need to use tagLamBinders because we
@@ -2287,11 +2285,11 @@ occAnalRules !env bndr
where
rule' = rule { ru_args = args', ru_rhs = rhs' }
- WUD lhs_uds args' = addInScope env bndrs $ \env ->
+ WUD lhs_uds args' = addInScopeList env bndrs $ \env ->
occAnalList env args
lhs_uds' = markAllManyNonTail lhs_uds
- WUD rhs_uds rhs' = addInScope env bndrs $ \env ->
+ WUD rhs_uds rhs' = addInScopeList env bndrs $ \env ->
occAnal env rhs
-- Note [Rules are extra RHSs]
-- Note [Rule dependency info]
@@ -2532,7 +2530,7 @@ occAnal env (Case scrut bndr ty alts)
WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut
WUD alts_usage (tagged_bndr, alts')
- = addInScope env [bndr] $ \env ->
+ = addInScopeOne env bndr $ \env ->
let alt_env = addBndrSwap scrut' bndr $
setTailCtxt env -- Kill off OccRhs
WUD alts_usage alts' = do_alts alt_env alts
@@ -2552,7 +2550,7 @@ occAnal env (Case scrut bndr ty alts)
WUD uds2 alts' = do_alts env alts
do_alt !env (Alt con bndrs rhs)
- = addInScope env bndrs $ \ env ->
+ = addInScopeList env bndrs $ \ env ->
let WUD rhs_usage rhs' = occAnal env rhs
tagged_bndrs = tagLamBinders rhs_usage bndrs
in -- See Note [Binders in case alternatives]
@@ -2915,14 +2913,23 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
OccRhs -> True
_ -> False
-addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a)
- -> WithUsageDetails a
+addInScopeList :: OccEnv -> [Var]
+ -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
+{-# INLINE addInScopeList #-}
+addInScopeList env bndrs = addInScope env (mkVarSet bndrs)
+
+addInScopeOne :: OccEnv -> Id
+ -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
+{-# INLINE addInScopeOne #-}
+addInScopeOne env bndr = addInScope env (unitVarSet bndr)
+
+addInScope :: OccEnv -> IdSet
+ -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
{-# INLINE addInScope #-}
-- This function is called a lot, so we want to inline the fast path
-addInScope env bndrs thing_inside
+addInScope env bndr_set thing_inside
= 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
@@ -3523,7 +3530,9 @@ addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
-- Add any CoVars free in the type of a lambda-binder
-- See Note [Gather occurrences of coercion variables]
addLamCoVarOccs uds bndrs
- = uds `addManyOccs` coVarsOfTypes [ idType id | id <- bndrs, isId id ]
+ = foldr add uds bndrs
+ where
+ add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr)
emptyDetails :: UsageDetails
emptyDetails = mkSimpleDetails emptyVarEnv
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/702dc152cad9d894ce34ef2f398fabac6764de91
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/702dc152cad9d894ce34ef2f398fabac6764de91
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/20230723/44eab16c/attachment-0001.html>
More information about the ghc-commits
mailing list