\begin{code}
module OccurAnal (
- occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule
+ occurAnalysePgm, occurAnalyseExpr
) where
#include "HsVersions.h"
import CoreSyn
import CoreFVs ( idRuleVars )
-import CoreUtils ( exprIsTrivial )
+import CoreUtils ( exprIsTrivial, isDefaultAlt )
import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
- idOccInfo, setIdOccInfo,
- isExportedId, modifyIdInfo, idInfo, idArity,
- idSpecialisation, isLocalId,
+ idOccInfo, setIdOccInfo, isLocalId,
+ isExportedId, idArity,
idType, idUnique, Id
)
-import IdInfo ( copyIdInfo )
-import BasicTypes ( OccInfo(..), isOneOcc )
+import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
import VarSet
import VarEnv
Here's the externally-callable interface:
\begin{code}
-occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
-occurAnalyseGlobalExpr expr
- = -- Top level expr, so no interesting free vars, and
- -- discard occurence info returned
- snd (occAnal (initOccEnv emptyVarSet) expr)
-
-occurAnalyseRule :: CoreRule -> CoreRule
-occurAnalyseRule rule@(BuiltinRule _ _) = rule
-occurAnalyseRule (Rule str act tpl_vars tpl_args rhs)
- -- Add occ info to tpl_vars, rhs
- = Rule str act tpl_vars' tpl_args rhs'
+occurAnalysePgm :: [CoreBind] -> [CoreBind]
+occurAnalysePgm binds
+ = snd (go initOccEnv binds)
where
- (rhs_uds, rhs') = occAnal (initOccEnv (mkVarSet tpl_vars)) rhs
- (_, tpl_vars') = tagBinders rhs_uds tpl_vars
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Top level stuff}
-%* *
-%************************************************************************
-
-In @occAnalTop@ we do indirection-shorting. That is, if we have this:
-
- x_local = <expression>
- ...
- x_exported = loc
-
-where exp is exported, and loc is not, then we replace it with this:
-
- x_local = x_exported
- x_exported = <expression>
- ...
-
-Without this we never get rid of the x_exported = x_local thing. This
-save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
-makes strictness information propagate better. This used to happen in
-the final phase, but it's tidier to do it here.
-
-If more than one exported thing is equal to a local thing (i.e., the
-local thing really is shared), then we do one only:
-\begin{verbatim}
- x_local = ....
- x_exported1 = x_local
- x_exported2 = x_local
-==>
- x_exported1 = ....
-
- x_exported2 = x_exported1
-\end{verbatim}
-
-We rely on prior eta reduction to simplify things like
-\begin{verbatim}
- x_exported = /\ tyvars -> x_local tyvars
-==>
- x_exported = x_local
-\end{verbatim}
-Hence,there's a possibility of leaving unchanged something like this:
-\begin{verbatim}
- x_local = ....
- x_exported1 = x_local Int
-\end{verbatim}
-By the time we've thrown away the types in STG land this
-could be eliminated. But I don't think it's very common
-and it's dangerous to do this fiddling in STG land
-because we might elminate a binding that's mentioned in the
-unfolding for something.
-
-\begin{code}
-occurAnalyseBinds :: [CoreBind] -> [CoreBind]
+ go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
+ go env []
+ = (emptyDetails, [])
+ go env (bind:binds)
+ = (final_usage, bind' ++ binds')
+ where
+ (bs_usage, binds') = go env binds
+ (final_usage, bind') = occAnalBind env bind bs_usage
-occurAnalyseBinds binds
- = binds'
- where
- (_, _, binds') = go (initOccEnv emptyVarSet) binds
-
- go :: OccEnv -> [CoreBind]
- -> (UsageDetails, -- Occurrence info
- IdEnv Id, -- Indirection elimination info
- -- Maps local-id -> exported-id, but it embodies
- -- bindings of the form exported-id = local-id in
- -- the argument to go
- [CoreBind]) -- Occ-analysed bindings, less the exported-id=local-id ones
-
- go env [] = (emptyDetails, emptyVarEnv, [])
-
- go env (bind : binds)
- = let
- new_env = env `addNewCands` (bindersOf bind)
- (scope_usage, ind_env, binds') = go new_env binds
- (final_usage, new_binds) = occAnalBind env (zapBind ind_env bind) scope_usage
- -- NB: I zap before occur-analysing, so
- -- I don't need to worry about getting the
- -- occ info on the new bindings right.
- in
- case bind of
- NonRec exported_id (Var local_id)
- | shortMeOut ind_env exported_id local_id
- -- Special case for eliminating indirections
- -- Note: it's a shortcoming that this only works for
- -- non-recursive bindings. Elminating indirections
- -- makes perfect sense for recursive bindings too, but
- -- it's more complicated to implement, so I haven't done so
- -> (scope_usage, ind_env', binds')
- where
- ind_env' = extendVarEnv ind_env local_id exported_id
-
- other -> -- Ho ho! The normal case
- (final_usage, ind_env, new_binds ++ binds')
-
-
--- Deal with any indirections
-zapBind ind_env (NonRec bndr rhs)
- | bndr `elemVarEnv` ind_env = Rec (zap ind_env (bndr,rhs))
- -- The Rec isn't strictly necessary, but it's convenient
-zapBind ind_env (Rec pairs)
- | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map (zap ind_env) pairs))
-
-zapBind ind_env bind = bind
-
-zap ind_env pair@(local_id,rhs)
- = case lookupVarEnv ind_env local_id of
- Nothing -> [pair]
- Just exported_id -> [(local_id, Var exported_id),
- (exported_id', rhs)]
- where
- exported_id' = modifyIdInfo (copyIdInfo (idInfo local_id)) exported_id
-
-shortMeOut ind_env exported_id local_id
--- The if-then-else stuff is just so I can get a pprTrace to see
--- how often I don't get shorting out becuase of IdInfo stuff
- = if isExportedId exported_id && -- Only if this is exported
-
- isLocalId local_id && -- Only if this one is defined in this
- -- module, so that we *can* change its
- -- binding to be the exported thing!
-
- not (isExportedId local_id) && -- Only if this one is not itself exported,
- -- since the transformation will nuke it
-
- not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
- then
- True
-
-{- No longer needed
- if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable'
- -- (see the defn of IdInfo.shortableIdInfo)
- then True
- else
-#ifdef DEBUG
- pprTrace "shortMeOut:" (ppr exported_id)
-#endif
- False
--}
- else
- False
+occurAnalyseExpr :: CoreExpr -> CoreExpr
+ -- Do occurrence analysis, and discard occurence info returned
+occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
\end{code}
occAnalBind env (Rec pairs) body_usage
= 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,
- let (rhs_usage, rhs') = occAnalRhs rhs_env bndr rhs
+ let (rhs_usage, rhs') = occAnalRhs env bndr rhs
]
sccs :: [SCC (Node Details1)]
| inlineCandidate bndr rhs = 2 -- Likely to be inlined
- | not (isEmptyCoreRules (idSpecialisation bndr)) = 1
- -- Avoid things with specialisations; we'd like
- -- to take advantage of them in the subsequent bindings
+-- NOT NEEDED ANY MORE [Feb06]
+-- We make all rules available in all bindings, by substituting
+-- the IdInfo before looking at any RHSs. I'm just leaving this
+-- snippet in as a commment so we can find it again if necessary.
+--
+-- | not (isEmptySpecInfo (idSpecialisation bndr)) = 1
+-- -- Avoid things with specialisations; we'd like
+-- -- to take advantage of them in the subsequent bindings
| otherwise = 0
where
(rhs_usage, rhs') = occAnal ctxt rhs
ctxt | certainly_inline id = env
- | otherwise = rhsCtxt env
+ | otherwise = rhsCtxt
-- 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
--
-- Crude solution: use rhsCtxt for things that occur just once...
certainly_inline id = case idOccInfo id of
- OneOcc in_lam one_br -> not in_lam && one_br
- other -> False
+ OneOcc in_lam one_br _ -> not in_lam && one_br
+ other -> False
-- [March 98] A new wrinkle is that if the binder has specialisations inside
-- it then we count the specialised Ids as "extra rhs's". That way
-- dies (because it isn't referenced any more), then the children will
-- die too unless they are already referenced directly.
- final_usage = foldVarSet add rhs_usage (idRuleVars id)
+ final_usage = addRuleUsage rhs_usage id
+
+addRuleUsage :: UsageDetails -> Id -> UsageDetails
+-- Add the usage from RULES in Id to the usage
+addRuleUsage usage id
+ = foldVarSet add usage (idRuleVars id)
+ where
add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info
-- (i.e manyOcc) because many copies
-- of the specialised thing can appear
-
\end{code}
Expressions
CoreExpr)
occAnal env (Type t) = (emptyDetails, Type t)
-
-occAnal env (Var v)
- = (var_uds, Var v)
- where
- var_uds | isCandidate env v = unitVarEnv v oneOcc
- | otherwise = emptyDetails
-
+occAnal env (Var v) = (mkOneOcc env v False, Var v)
-- At one stage, I gathered the idRuleVars for v here too,
-- which in a way is the right thing to do.
- -- But that went wrong right after specialisation, when
+ -- Btu that went wrong right after specialisation, when
-- 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":
(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)
- = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
- case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
- -- No need for rhsCtxt
+ = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
+ case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts') ->
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
alts_usage' = addCaseBndrUsage alts_usage
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.
Nothing -> usage
Just occ -> extendVarEnv usage bndr (markMany occ)
+ occ_anal_scrut (Var v) (alt1 : other_alts)
+ | not (null other_alts) || not (isDefaultAlt alt1)
+ = (mkOneOcc env v True, Var v)
+ occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut
+ -- No need for rhsCtxt
+
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') }}
- 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
- arg_env = vanillaCtxt env
+ arg_env = vanillaCtxt
\end{code}
Applications are dealt with specially because we want
(fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
where
fun_uniq = idUnique fun
-
- fun_uds | isCandidate env fun = unitVarEnv fun oneOcc
- | otherwise = emptyDetails
-
+ fun_uds = mkOneOcc env fun (valArgCount args > 0)
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
| fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
| fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
appSpecial env n ctxt args
= go n args
where
- arg_env = vanillaCtxt env
+ arg_env = vanillaCtxt
go n [] = (emptyDetails, []) -- Too few args
\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
\begin{code}
data OccEnv
- = 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
-- 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
+initOccEnv :: OccEnv
+initOccEnv = OccEnv OccRhs []
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv cands encl _) id = id `elemVarSet` cands
+vanillaCtxt = OccEnv OccVanilla []
+rhsCtxt = OccEnv OccRhs []
-addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv cands encl ctxt) ids
- = OccEnv (extendVarSetList cands ids) encl ctxt
-
-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 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
-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 []
where
- 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 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}
%************************************************************************
%************************************************************************
\begin{code}
-oneOcc :: OccInfo
-oneOcc = OneOcc False True
+mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
+mkOneOcc env id int_cxt
+ | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
+ | otherwise = emptyDetails
markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
markInsideSCC occ = markMany occ
-markInsideLam (OneOcc _ one_br) = OneOcc True one_br
-markInsideLam occ = occ
+markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
+markInsideLam occ = occ
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
orOccInfo IAmDead info2 = info2
orOccInfo info1 IAmDead = info1
-orOccInfo (OneOcc in_lam1 one_branch1)
- (OneOcc in_lam2 one_branch2)
+orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
+ (OneOcc in_lam2 one_branch2 int_cxt2)
= OneOcc (in_lam1 || in_lam2)
False -- False, because it occurs in both branches
+ (int_cxt1 && int_cxt2)
orOccInfo info1 info2 = NoOccInfo
\end{code}
projects / ghc-hetmet.git / blobdiff