[Git][ghc/ghc][wip/T22404] More wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Dec 24 15:39:55 UTC 2022
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
bf14e837 by Simon Peyton Jones at 2022-12-24T15:39:25+00:00
More wibbles
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -58,7 +58,7 @@ import GHC.Utils.Misc
import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
-import Data.List (mapAccumL, mapAccumR)
+import Data.List (mapAccumL)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import qualified Data.List.NonEmpty as NE
@@ -94,8 +94,8 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
init_env = initOccEnv { occ_rule_act = active_rule
, occ_unf_act = active_unf }
- (WithUsageDetails final_usage occ_anald_binds) = go init_env binds
- (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel
+ WithUsageDetails final_usage occ_anald_binds = go binds init_env
+ WithUsageDetails _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel
imp_rule_edges
(flattenBinds binds)
initial_uds
@@ -127,14 +127,10 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
-- Not BuiltinRules; see Note [Plugin rules]
, let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]
- go :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind]
- go !_ []
- = WithUsageDetails initial_uds []
- go env (bind:binds)
- = WithUsageDetails final_usage (bind' ++ binds')
- where
- (WithUsageDetails bs_usage binds') = go env binds
- (WithUsageDetails final_usage bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage
+ go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind]
+ go [] _ = WithUsageDetails initial_uds []
+ go (bind:binds) env = occAnalBind env TopLevel
+ imp_rule_edges bind (go binds) (++)
{- *********************************************************************
* *
@@ -731,34 +727,48 @@ data WithUsageDetails a = WithUsageDetails !UsageDetails !a
-- occAnalBind
------------------------------------------------------------------
-occAnalBind :: OccEnv -- The incoming OccEnv
- -> TopLevelFlag
- -> ImpRuleEdges
- -> CoreBind
- -> UsageDetails -- Usage details of scope
- -> WithUsageDetails [CoreBind] -- Of the whole let(rec)
+occAnalBind
+ :: OccEnv
+ -> TopLevelFlag
+ -> ImpRuleEdges
+ -> CoreBind
+ -> (OccEnv -> WithUsageDetails r) -- Scope of the bind
+ -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds
+ -> WithUsageDetails r -- Of the whole let(rec)
+
+occAnalBind env lvl ire (Rec pairs) thing_inside combine
+ = addInScope env (map fst pairs) $ \env ->
+ let WithUsageDetails body_uds body' = thing_inside env
+ WithUsageDetails bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds
+ in WithUsageDetails 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
+ = WithUsageDetails body_uds (combine [NonRec bndr rhs] body')
-occAnalBind !env lvl top_env (NonRec binder rhs) body_usage
- = occAnalNonRecBind env lvl top_env binder rhs body_usage
-occAnalBind env lvl top_env (Rec pairs) body_usage
- = occAnalRecBind env lvl top_env pairs body_usage
+ | isDeadBinder tagged_bndr
+ = WithUsageDetails body_uds body' -- Drop dead code
------------------
-occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr
- -> UsageDetails -> WithUsageDetails [CoreBind]
-occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage
- | isTyVar bndr -- A type let; we don't gather usage info
- = WithUsageDetails body_usage [NonRec bndr rhs]
+ | otherwise
+ = WithUsageDetails (bind_uds `andUDs` body_uds) (combine binds' body')
- | not (bndr `usedIn` body_usage) -- It's not mentioned
- = WithUsageDetails body_usage []
+ where
+ WithUsageDetails body_uds (tagged_bndr, body')
+ = addInScope env [bndr] $ \env ->
+ let WithUsageDetails usage res = thing_inside env
+ tagged_bndr = tagNonRecBinder lvl usage bndr
+ in WithUsageDetails usage (tagged_bndr, res)
+ WithUsageDetails bind_uds binds' = occAnalNonRecIdBind env ire tagged_bndr rhs
- | otherwise -- It's mentioned in the body
- = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr rhs']
+
+-----------------
+occAnalNonRecIdBind :: OccEnv -> ImpRuleEdges -> Id -> CoreExpr
+ -> WithUsageDetails [CoreBind]
+occAnalNonRecIdBind !env imp_rule_edges tagged_bndr rhs
+ = WithUsageDetails rhs_usage [NonRec final_bndr rhs']
where
- (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr
- final_bndr = tagged_bndr `setIdUnfolding` unf'
- `setIdSpecialisation` mkRuleInfo rules'
+ final_bndr = tagged_bndr `setIdUnfolding` unf'
+ `setIdSpecialisation` mkRuleInfo rules'
rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds
-- Get the join info from the *new* decision
@@ -773,19 +783,18 @@ occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage
-- See Note [Sources of one-shot information]
rhs_env = env1 { occ_one_shots = argOneShots dmd }
- (WithUsageDetails rhs_uds rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs
+ WithUsageDetails rhs_uds rhs' = occAnalRhs rhs_env NonRecursive mb_join_arity rhs
--------- Unfolding ---------
-- See Note [Unfoldings and join points]
- unf | isId bndr = idUnfolding bndr
- | otherwise = NoUnfolding
- (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf
+ unf = idUnfolding tagged_bndr
+ WithUsageDetails unf_uds unf' = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf
--------- Rules ---------
-- See Note [Rules are extra RHSs] and Note [Rule dependency info]
- rules_w_uds = occAnalRules rhs_env mb_join_arity bndr
+ rules_w_uds = occAnalRules rhs_env mb_join_arity tagged_bndr
rules' = map fstOf3 rules_w_uds
- imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr)
+ imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges tagged_bndr)
-- imp_rule_uds: consider
-- h = ...
-- g = ...
@@ -805,9 +814,9 @@ occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage
-> active && not_stable
_ -> False
- dmd = idDemandInfo bndr
- active = isAlwaysActive (idInlineActivation bndr)
- not_stable = not (isStableUnfolding (idUnfolding bndr))
+ dmd = idDemandInfo tagged_bndr
+ active = isAlwaysActive (idInlineActivation tagged_bndr)
+ not_stable = not (isStableUnfolding unf)
-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
@@ -817,7 +826,7 @@ occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
-- * compute strongly-connected components
-- * feed those components to occAnalRec
-- See Note [Recursive bindings: the grand plan]
-occAnalRecBind !env lvl imp_rule_edges pairs body_usage
+occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage
= foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs
where
sccs :: [SCC Details]
@@ -830,7 +839,6 @@ occAnalRecBind !env lvl imp_rule_edges pairs body_usage
bndrs = map fst pairs
bndr_set = mkVarSet bndrs
- rhs_env = env `addInScope` bndrs
-----------------------------
@@ -847,10 +855,10 @@ occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
= WithUsageDetails body_uds binds -- See Note [Dead code]
| otherwise -- It's mentioned in the body
- = WithUsageDetails (body_uds' `andUDs` rhs_uds')
+ = WithUsageDetails (body_uds `andUDs` rhs_uds')
(NonRec tagged_bndr rhs : binds)
where
- (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr
+ tagged_bndr = tagNonRecBinder lvl body_uds bndr
rhs_uds' = adjustRhsUsage mb_join_arity rhs rhs_uds
mb_join_arity = willBeJoinId_maybe tagged_bndr
@@ -1818,18 +1826,19 @@ occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails CoreExpr)
-- The caller does that, either in occAnal (Lam {}), or in adjustRhsUsage
-- See Note [Adjusting right-hand sides]
-occAnalLam env (Lam bndr expr)
+occAnalLam env (Lam bndr body)
| isTyVar bndr
- = let env1 = addOneInScope env bndr
- WithUsageDetails usage expr' = occAnalLam env1 expr
- in WithUsageDetails usage (Lam bndr expr')
- -- Important: Keep the 'env' unchanged so that with a RHS like
+ = addInScope env [bndr] $ \env ->
+ let WithUsageDetails usage body' = occAnalLam env body
+ in WithUsageDetails usage (Lam bndr 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 -- So 'bndr' is an Id
- = let (env_one_shots', bndr1)
+ = addInScope env [bndr] $ \env ->
+ let (env_one_shots', bndr1)
= case occ_one_shots env of
[] -> ([], bndr)
(os : oss) -> (oss, updOneShotInfo bndr os)
@@ -1839,10 +1848,9 @@ occAnalLam env (Lam bndr expr)
-- See Note [The oneShot function]
env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
- env2 = addOneInScope env1 bndr
- (WithUsageDetails usage expr') = occAnalLam env2 expr
- (usage', bndr2) = tagLamBinder usage bndr1
- in WithUsageDetails usage' (Lam bndr2 expr')
+ WithUsageDetails usage body' = occAnalLam env1 body
+ bndr2 = tagLamBinder usage bndr1
+ in WithUsageDetails usage (Lam bndr2 body')
-- For casts, keep going in the same lambda-group
-- See Note [Occurrence analysis for lambda binders]
@@ -1940,7 +1948,7 @@ occAnalUnfolding !env is_rec mb_join_arity unf
unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src ->
let
- (WithUsageDetails usage rhs') = occAnalRhs env is_rec mb_join_arity rhs
+ WithUsageDetails usage rhs' = occAnalRhs env is_rec mb_join_arity rhs
unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]
| otherwise = unf { uf_tmpl = rhs' }
@@ -1955,14 +1963,11 @@ occAnalUnfolding !env is_rec mb_join_arity unf
-- scope remain in scope; there is no cloning etc.
unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
- -> WithUsageDetails final_usage (unf { df_args = args' })
- where
- env' = env `addInScope` bndrs
- (WithUsageDetails usage args') = occAnalList env' args
- final_usage = markAllManyNonTail (delDetailsList usage bndrs)
- `addLamCoVarOccs` bndrs
- `delDetailsList` bndrs
- -- delDetailsList; no need to use tagLamBinders because we
+ -> let WithUsageDetails uds args' = addInScope env bndrs $ \ env ->
+ occAnalList env args
+ uds' = markAllManyNonTail uds
+ in WithUsageDetails uds' (unf { df_args = args' })
+ -- No need to use tagLamBinders because we
-- never inline DFuns so the occ-info on binders doesn't matter
unf -> WithUsageDetails emptyDetails unf
@@ -1979,20 +1984,19 @@ occAnalRules !env mb_join_arity bndr
occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
= (rule', lhs_uds', rhs_uds')
where
- env' = env `addInScope` bndrs
rule' | noBinderSwaps env = rule -- Note [Unfoldings and rules]
| otherwise = rule { ru_args = args', ru_rhs = rhs' }
- (WithUsageDetails lhs_uds args') = occAnalList env' args
- lhs_uds' = markAllManyNonTail (lhs_uds `delDetailsList` bndrs)
- `addLamCoVarOccs` bndrs
+ WithUsageDetails lhs_uds args' = addInScope env bndrs $ \env ->
+ occAnalList env args
- (WithUsageDetails rhs_uds rhs') = occAnal env' rhs
+ lhs_uds' = markAllManyNonTail lhs_uds
+ WithUsageDetails rhs_uds rhs' = addInScope env bndrs $ \env ->
+ occAnal env rhs
-- Note [Rules are extra RHSs]
-- Note [Rule dependency info]
rhs_uds' = markAllNonTailIf (not exact_join) $
- markAllMany $
- rhs_uds `delDetailsList` bndrs
+ markAllMany rhs_uds
exact_join = exactJoin mb_join_arity args
-- See Note [Join points and unfoldings/rules]
@@ -2214,23 +2218,39 @@ occAnal env expr@(Lam {})
markAllNonTail usage
in WithUsageDetails final_usage expr'
-occAnal env (Case scrut bndr ty alts)
+occAnal env expr@(Case scrut bndr ty alts)
= let
- (WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut
- alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr
- (alts_usage_s, alts') = mapAndUnzip (do_alt alt_env) alts
- alts_usage = foldr orUDs emptyDetails alts_usage_s
- (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr
- total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1
+ WithUsageDetails scrut_usage scrut' = occAnal (scrutCtxt env alts) scrut
+
+ WithUsageDetails alts_usage (tagged_bndr, alts')
+ = addInScope env [bndr] $ \env ->
+ let alt_env = addBndrSwap scrut' bndr $
+ env { occ_encl = OccVanilla }
+ WithUsageDetails alts_usage alts' = do_alts alt_env alts
+ tagged_bndr = tagLamBinder alts_usage bndr
+ in WithUsageDetails alts_usage (tagged_bndr, alts')
+
+ total_usage = markAllNonTail scrut_usage `andUDs` alts_usage
-- Alts can have tail calls, but the scrutinee can't
+
in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts')
where
+ do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]
+ do_alts _ [] = WithUsageDetails emptyDetails []
+ do_alts env [alt] = WithUsageDetails uds [alt']
+ where
+ WithUsageDetails uds alt' = do_alt env alt
+ do_alts env (alt:alts) = WithUsageDetails (uds1 `orUDs` uds2) (alt':alts')
+ where
+ WithUsageDetails uds1 alt' = do_alt env alt
+ WithUsageDetails uds2 alts' = do_alts env alts
+
do_alt !env (Alt con bndrs rhs)
- = let
- (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs
- (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
- in -- See Note [Binders in case alternatives]
- (alt_usg, Alt con tagged_bndrs rhs1)
+ = addInScope env bndrs $ \ env ->
+ let WithUsageDetails rhs_usage rhs' = occAnal env rhs
+ tagged_bndrs = tagLamBinders rhs_usage bndrs
+ in -- See Note [Binders in case alternatives]
+ WithUsageDetails rhs_usage (Alt con tagged_bndrs rhs')
occAnal env (Let bind body)
| NonRec bndr rhs <- bind
@@ -2238,21 +2258,18 @@ occAnal env (Let bind body)
, not (isStableUnfolding (realIdUnfolding bndr))
, not (idHasRules bndr)
= let WithUsageDetails rhs_usage rhs' = occAnalRhs env NonRecursive mb_join rhs
- body_env = env { occ_encl = OccVanilla }
- `addJoinPoint` (bndr, rhs_usage)
- WithUsageDetails body_usage body' = occAnal body_env body
- (body_usage', bndr') = tagNonRecBinder NotTopLevel body_usage bndr
- in if (bndr `usedIn` body_usage)
- then WithUsageDetails body_usage' (Let (NonRec bndr' rhs') body')
- else WithUsageDetails body_usage body'
+ in addInScope env [bndr] $ \ body_env ->
+ let body_env1 = body_env { occ_join_points = extendVarEnv (occ_join_points env)
+ bndr rhs_usage }
+ WithUsageDetails body_usage body' = occAnal body_env1 body
+ bndr' = tagNonRecBinder NotTopLevel body_usage bndr
+ in if (bndr `usedIn` body_usage)
+ then WithUsageDetails body_usage (Let (NonRec bndr' rhs') body')
+ else WithUsageDetails body_usage body'
| otherwise
- = let
- body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind
- WithUsageDetails body_usage body' = occAnal body_env body
- WithUsageDetails final_usage binds' = occAnalBind env NotTopLevel
- noImpRuleEdges bind body_usage
- in WithUsageDetails final_usage (mkLets binds' body')
+ = occAnalBind env NotTopLevel noImpRuleEdges bind
+ (\env -> occAnal env body) mkLets
occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr
-- The `fun` argument is just an accumulating parameter,
@@ -2565,44 +2582,36 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
OccRhs -> True
_ -> False
-addOneInScope :: OccEnv -> CoreBndr -> OccEnv
--- Needed for all Vars not just Ids
--- See Note [The binder-swap substitution] (BS3)
-addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars
- , occ_join_points = join_points }) bndr
- | bndr `elemVarSet` rng_vars = env1 { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
- | otherwise = env1 { occ_bs_env = swap_env `delVarEnv` bndr }
- where
- env1 = env { occ_join_points = join_points `delVarEnv` bndr }
-
addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a
-- Needed for all Vars not just Ids
-- See Note [The binder-swap substitution] (BS3)
addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = bs_rng_vars
, occ_join_points = join_points }) bndrs thing_inside
- | any (`elemVarSet` rng_vars) bndrs || anyVarEnv bad_join_rhs
- = let stripped_env = env { occ_bs_env = emptyVarEnv
- , occ_bs_rng = emptyVarSet
- , occ_join_points = emptyVarEnv }
- !WithUsageDetail uds res = thing_inside stripped_env
- uds_with_joins = nonDetStrictFoldVarEnv andUDs uds join_points
- in WithUsageDetails uds_with_joins res
+ | any (`elemVarSet` bs_rng_vars) bndrs
+ = fix_up_uds $
+ thing_inside (env1 { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet })
| otherwise
- = thing_inside (env { occ_bs_env = swap_env `delVarEnvList` bndrs
- , occ_join_points = join_points `delVarEnvList` bndrs }
+ = fix_up_uds $
+ thing_inside (env1 { occ_bs_env = swap_env `delVarEnvList` bndrs })
where
+ env1 | isEmptyVarEnv bad_joins = env
+ | otherwise = env { occ_join_points = good_joins }
+
+ fix_up_uds (WithUsageDetails uds res)
+ = with_joins `seq`
+ WithUsageDetails with_joins res
+ where
+ trimmed_uds = uds `delDetails` bndrs
+ with_co_var_occs = trimmed_uds `addManyOccs` coVarOccs bndrs
+ with_joins = nonDetStrictFoldUFM andUDs with_co_var_occs bad_joins
+
+ (bad_joins, good_joins) = partitionVarEnv bad_join_rhs join_points
+
bad_join_rhs :: UsageDetails -> Bool
bad_join_rhs (UD { ud_env = rhs_usage }) = any (`elemVarEnv` rhs_usage) bndrs
-addJoinPoint :: OccEnv -> (Id,UsageDetails) -> OccEnv
-addJoinPoint env (bndr, uds)
- = env1 { occ_join_points = extendVarEnv (occ_join_points env) bndr uds1 }
- where
- uds1 = addManyOccId uds bndr
- env1 = env `addOneInScope` bndr
-
--------------------
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
-- If (f,g), (g,h) are in the input, then (f,h) is in the output
@@ -3079,18 +3088,18 @@ addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set
-- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes
-addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
--- Add any CoVars free in the type of a lambda-binder
+coVarOccs :: [Var] -> VarSet
+-- Add any CoVars free in the types of a telescope of lambda-binders
-- See Note [Gather occurrences of coercion variables]
-addLamCoVarOccs uds bndrs
- = uds `addManyOccs` coVarsOfTypes (map varType bndrs)
-
-delDetails :: UsageDetails -> Id -> UsageDetails
-delDetails ud bndr
- = ud `alterUsageDetails` (`delVarEnv` bndr)
+coVarOccs bndrs
+ = foldr get emptyVarSet bndrs
+ where
+ get bndr cvs = (cvs `delVarSet` bndr) `unionVarSet`
+ coVarsOfType (varType bndr)
-delDetailsList :: UsageDetails -> [Id] -> UsageDetails
-delDetailsList ud bndrs
+delDetails :: UsageDetails -> [Id] -> UsageDetails
+-- Delete these binders from the UsageDetails
+delDetails ud bndrs
= ud `alterUsageDetails` (`delVarEnvList` bndrs)
emptyDetails :: UsageDetails
@@ -3104,9 +3113,10 @@ isEmptyDetails = isEmptyVarEnv . ud_env
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
-markAllMany ud = ud { ud_z_many = ud_env ud }
-markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud }
-markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }
+markAllMany ud = ud { ud_z_many = ud_env ud }
+markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud }
+markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }
+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
@@ -3116,9 +3126,6 @@ markAllInsideLamIf False ud = ud
markAllNonTailIf True ud = markAllNonTail ud
markAllNonTailIf False ud = ud
-
-markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
-
lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails ud id
= case lookupVarEnv (ud_env ud) id of
@@ -3203,52 +3210,38 @@ exactJoin (Just join_arity) args = args `lengthIs` join_arity
type IdWithOccInfo = Id
-tagLamBinders :: UsageDetails -- Of scope
- -> [Id] -- Binders
- -> (UsageDetails, -- Details with binders removed
- [IdWithOccInfo]) -- Tagged binders
+tagLamBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> [IdWithOccInfo] -- Tagged binders
tagLamBinders usage binders
- = usage' `seq` (usage', bndrs')
- where
- (usage', bndrs') = mapAccumR tagLamBinder usage binders
+ = map (tagLamBinder usage) binders
tagLamBinder :: UsageDetails -- Of scope
-> Id -- Binder
- -> (UsageDetails, -- Details with binder removed
- IdWithOccInfo) -- Tagged binders
+ -> IdWithOccInfo -- Tagged binders
-- Used for lambda and case binders
--- It copes with the fact that lambda bindings can have a
--- stable unfolding, used for join points
+-- No-op on TyVars
+-- A lambda binder never has an unfolding, so no need to look for that
tagLamBinder usage bndr
- = (usage2, bndr')
+ = setBinderOcc (markNonTail occ) bndr
+ -- markNonTail: don't try to make an argument into a join point
where
- occ = lookupDetails usage bndr
- bndr' = setBinderOcc (markNonTail occ) bndr
- -- Don't try to make an argument into a join point
- usage1 = usage `delDetails` bndr
- usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)
- -- This is effectively the RHS of a
- -- non-join-point binding, so it's okay to use
- -- addManyOccsSet, which assumes no tail calls
- | otherwise = usage1
+ occ = lookupDetails usage bndr
tagNonRecBinder :: TopLevelFlag -- At top level?
-> UsageDetails -- Of scope
-> CoreBndr -- Binder
- -> (UsageDetails, -- Details with binder removed
- IdWithOccInfo) -- Tagged binder
-
+ -> IdWithOccInfo -- Tagged binder
+-- No-op on TyVars
tagNonRecBinder lvl usage binder
- = let
- occ = lookupDetails usage binder
- will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)
- occ' | will_be_join = -- must already be marked AlwaysTailCalled
- assert (isAlwaysTailCalled occ) occ
- | otherwise = markNonTail occ
- binder' = setBinderOcc occ' binder
- usage' = usage `delDetails` binder
- in
- usage' `seq` (usage', binder')
+ = setBinderOcc occ' binder
+ where
+ occ = lookupDetails usage binder
+ will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)
+ occ' | will_be_join = -- must already be marked AlwaysTailCalled
+ assert (isAlwaysTailCalled occ) occ
+ | otherwise = markNonTail occ
+
tagRecBinders :: TopLevelFlag -- At top level?
-> UsageDetails -- Of body of let ONLY
@@ -3296,11 +3289,8 @@ tagRecBinders lvl body_uds details_s
-- 4. Tag each binder with its adjusted details
bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr
| bndr <- bndrs ]
-
- -- 5. Drop the binders from the adjusted details and return
- usage' = adj_uds `delDetailsList` bndrs
in
- (usage', bndrs')
+ (adj_uds, bndrs')
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc occ_info bndr
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf14e837557ea5b325e1e15b20ea37bbc2c6e745
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf14e837557ea5b325e1e15b20ea37bbc2c6e745
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/20221224/af72d3e2/attachment-0001.html>
More information about the ghc-commits
mailing list