Instead of gathering a set of 'candidates' in the occurrence
analyser, use the isLocalId predicate to identify things
for which occurrence information is required. By defn
isLocalId is true of Ids (whether top level or not) defined
in this module, and that is exactly what we want.
The 'candidates set' predated the LocalId invariant, I think.
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
- idOccInfo, setIdOccInfo,
+ idOccInfo, setIdOccInfo, isLocalId,
isExportedId, idArity, idSpecialisation,
idType, idUnique, Id
)
isExportedId, idArity, idSpecialisation,
idType, idUnique, Id
)
\begin{code}
occurAnalysePgm :: [CoreBind] -> [CoreBind]
occurAnalysePgm binds
\begin{code}
occurAnalysePgm :: [CoreBind] -> [CoreBind]
occurAnalysePgm binds
- = snd (go (initOccEnv emptyVarSet) binds)
+ = snd (go initOccEnv binds)
where
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go env []
where
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go env []
go env (bind:binds)
= (final_usage, bind' ++ binds')
where
go env (bind:binds)
= (final_usage, bind' ++ binds')
where
- new_env = env `addNewCands` (bindersOf bind)
- (bs_usage, binds') = go new_env binds
+ (bs_usage, binds') = go env binds
(final_usage, bind') = occAnalBind env bind bs_usage
occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
(final_usage, bind') = occAnalBind env bind bs_usage
occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
- snd (occAnal (initOccEnv emptyVarSet) expr)
+ snd (occAnal initOccEnv expr)
occurAnalyseRule :: CoreRule -> CoreRule
occurAnalyseRule rule@(BuiltinRule _ _) = rule
occurAnalyseRule :: CoreRule -> CoreRule
occurAnalyseRule rule@(BuiltinRule _ _) = rule
-- Add occ info to tpl_vars, rhs
= Rule str act tpl_vars' tpl_args rhs'
where
-- Add occ info to tpl_vars, rhs
= Rule str act tpl_vars' tpl_args rhs'
where
- (rhs_uds, rhs') = occAnal (initOccEnv (mkVarSet tpl_vars)) rhs
+ (rhs_uds, rhs') = occAnal initOccEnv rhs
(_, tpl_vars') = tagBinders rhs_uds tpl_vars
\end{code}
(_, tpl_vars') = tagBinders rhs_uds tpl_vars
\end{code}
= foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
where
binders = map fst pairs
= foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
where
binders = map fst pairs
- rhs_env = env `addNewCands` binders
analysed_pairs :: [Details1]
analysed_pairs = [ (bndr, rhs_usage, rhs')
| (bndr, rhs) <- pairs,
analysed_pairs :: [Details1]
analysed_pairs = [ (bndr, rhs_usage, rhs')
| (bndr, rhs) <- pairs,
- let (rhs_usage, rhs') = occAnalRhs rhs_env bndr rhs
+ let (rhs_usage, rhs') = occAnalRhs env bndr rhs
]
sccs :: [SCC (Node Details1)]
]
sccs :: [SCC (Node Details1)]
where
(rhs_usage, rhs') = occAnal ctxt rhs
ctxt | certainly_inline id = env
where
(rhs_usage, rhs') = occAnal ctxt rhs
ctxt | certainly_inline id = env
- | otherwise = rhsCtxt env
-- Note that we generally use an rhsCtxt. This tells the occ anal n
-- that it's looking at an RHS, which has an effect in occAnalApp
--
-- Note that we generally use an rhsCtxt. This tells the occ anal n
-- that it's looking at an RHS, which has an effect in occAnalApp
--
occAnal env (Var v)
= (var_uds, Var v)
where
occAnal env (Var v)
= (var_uds, Var v)
where
- var_uds | isCandidate env v = unitVarEnv v oneOcc
- | otherwise = emptyDetails
+ var_uds | isLocalId v = unitVarEnv v oneOcc
+ | otherwise = emptyDetails
-- At one stage, I gathered the idRuleVars for v here too,
-- which in a way is the right thing to do.
-- At one stage, I gathered the idRuleVars for v here too,
-- which in a way is the right thing to do.
-- the *occurrences* of the overloaded function didn't have any
-- rules in them, so the *specialised* versions looked as if they
-- weren't used at all.
-- the *occurrences* of the overloaded function didn't have any
-- rules in them, so the *specialised* versions looked as if they
-- weren't used at all.
\end{code}
We regard variables that occur as constructor arguments as "dangerousToDup":
\end{code}
We regard variables that occur as constructor arguments as "dangerousToDup":
(really_final_usage,
mkLams tagged_binders body') }
where
(really_final_usage,
mkLams tagged_binders body') }
where
- (binders, body) = collectBinders expr
- (linear, env1, _) = oneShotGroup env binders
- env2 = env1 `addNewCands` binders -- Add in-scope binders
- env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
+ env_body = vanillaCtxt -- Body is (no longer) an RhsContext
+ (binders, body) = collectBinders expr
+ binders' = oneShotGroup env binders
+ linear = all is_one_shot binders'
+ is_one_shot b = isId b && isOneShotBndr b
occAnal env (Case scrut bndr ty alts)
occAnal env (Case scrut bndr ty alts)
- = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
- case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
+ = case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts') ->
+ case occAnal vanillaCtxt scrut of { (scrut_usage, scrut') ->
-- No need for rhsCtxt
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
-- No need for rhsCtxt
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
- alt_env = env `addNewCand` bndr
-
-- The case binder gets a usage of either "many" or "dead", never "one".
-- Reason: we like to inline single occurrences, to eliminate a binding,
-- but inlining a case binder *doesn't* eliminate a binding.
-- The case binder gets a usage of either "many" or "dead", never "one".
-- Reason: we like to inline single occurrences, to eliminate a binding,
-- but inlining a case binder *doesn't* eliminate a binding.
Just occ -> extendVarEnv usage bndr (markMany occ)
occAnal env (Let bind body)
Just occ -> extendVarEnv usage bndr (markMany occ)
occAnal env (Let bind body)
- = case occAnal new_env body of { (body_usage, body') ->
+ = case occAnal env body of { (body_usage, body') ->
case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
(final_usage, mkLets new_binds body') }}
case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
(final_usage, mkLets new_binds body') }}
- where
- new_env = env `addNewCands` (bindersOf bind)
occAnalArgs env args
= case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
(foldr combineUsageDetails emptyDetails arg_uds_s, args')}
where
occAnalArgs env args
= case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
(foldr combineUsageDetails emptyDetails arg_uds_s, args')}
where
- arg_env = vanillaCtxt env
\end{code}
Applications are dealt with specially because we want
\end{code}
Applications are dealt with specially because we want
where
fun_uniq = idUnique fun
where
fun_uniq = idUnique fun
- fun_uds | isCandidate env fun = unitVarEnv fun oneOcc
- | otherwise = emptyDetails
+ fun_uds | isLocalId fun = unitVarEnv fun oneOcc
+ | otherwise = emptyDetails
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
| fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
| fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
appSpecial env n ctxt args
= go n args
where
appSpecial env n ctxt args
= go n args
where
- arg_env = vanillaCtxt env
go n [] = (emptyDetails, []) -- Too few args
go n [] = (emptyDetails, []) -- Too few args
\begin{code}
occAnalAlt env case_bndr (con, bndrs, rhs)
\begin{code}
occAnalAlt env case_bndr (con, bndrs, rhs)
- = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') ->
+ = case occAnal env rhs of { (rhs_usage, rhs') ->
let
(final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
let
(final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
- = OccEnv IdSet -- In-scope Ids; we gather info about these only
- OccEncl -- Enclosing context information
+ = OccEnv OccEncl -- Enclosing context information
CtxtTy -- Tells about linearity
-- OccEncl is used to control whether to inline into constructor arguments
CtxtTy -- Tells about linearity
-- OccEncl is used to control whether to inline into constructor arguments
-- be applied many times; but when it is,
-- the CtxtTy inside applies
-- be applied many times; but when it is,
-- the CtxtTy inside applies
-initOccEnv :: VarSet -> OccEnv
-initOccEnv vars = OccEnv vars OccRhs []
-
-isRhsEnv (OccEnv _ OccRhs _) = True
-isRhsEnv (OccEnv _ OccVanilla _) = False
-
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv cands encl _) id = id `elemVarSet` cands
+initOccEnv :: OccEnv
+initOccEnv = OccEnv OccRhs []
-addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv cands encl ctxt) ids
- = OccEnv (extendVarSetList cands ids) encl ctxt
+vanillaCtxt = OccEnv OccVanilla []
+rhsCtxt = OccEnv OccRhs []
-addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv cands encl ctxt) id
- = OccEnv (extendVarSet cands id) encl ctxt
+isRhsEnv (OccEnv OccRhs _) = True
+isRhsEnv (OccEnv OccVanilla _) = False
setCtxt :: OccEnv -> CtxtTy -> OccEnv
setCtxt :: OccEnv -> CtxtTy -> OccEnv
-setCtxt (OccEnv cands encl _) ctxt = OccEnv cands encl ctxt
-
-oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr])
- -- True <=> this is a one-shot linear lambda group
- -- The [CoreBndr] are the binders.
+setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
+oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
-- The result binders have one-shot-ness set that they might not have had originally.
-- This happens in (build (\cn -> e)). Here the occurrence analyser
-- linearity context knows that c,n are one-shot, and it records that fact in
-- the binder. This is useful to guide subsequent float-in/float-out tranformations
-- The result binders have one-shot-ness set that they might not have had originally.
-- This happens in (build (\cn -> e)). Here the occurrence analyser
-- linearity context knows that c,n are one-shot, and it records that fact in
-- the binder. This is useful to guide subsequent float-in/float-out tranformations
-oneShotGroup (OccEnv cands encl ctxt) bndrs
- = case go ctxt bndrs [] of
- (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs)
+oneShotGroup (OccEnv encl ctxt) bndrs
+ = go ctxt bndrs []
- is_one_shot b = isId b && isOneShotBndr b
-
- go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs)
+ go ctxt [] rev_bndrs = reverse rev_bndrs
go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
| isId bndr = go ctxt bndrs (bndr':rev_bndrs)
go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
| isId bndr = go ctxt bndrs (bndr':rev_bndrs)
go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
-
-vanillaCtxt (OccEnv cands _ _) = OccEnv cands OccVanilla []
-rhsCtxt (OccEnv cands _ _) = OccEnv cands OccRhs []
-
-addAppCtxt (OccEnv cands encl ctxt) args
- = OccEnv cands encl (replicate (valArgCount args) True ++ ctxt)
+addAppCtxt (OccEnv encl ctxt) args
+ = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
\end{code}
%************************************************************************
\end{code}
%************************************************************************