\begin{code}
module OccurAnal (
- occurAnalysePgm, 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,
+ idOccInfo, setIdOccInfo, isLocalId,
isExportedId, idArity, idSpecialisation,
idType, idUnique, Id
)
-import BasicTypes ( OccInfo(..), isOneOcc )
+import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
+import IdInfo ( isEmptySpecInfo )
import VarSet
import VarEnv
\begin{code}
occurAnalysePgm :: [CoreBind] -> [CoreBind]
occurAnalysePgm binds
- = snd (go (initOccEnv emptyVarSet) binds)
+ = snd (go initOccEnv binds)
where
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go env []
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
- 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'
- where
- (rhs_uds, rhs') = occAnal (initOccEnv (mkVarSet tpl_vars)) rhs
- (_, tpl_vars') = tagBinders rhs_uds tpl_vars
+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
+ | not (isEmptySpecInfo (idSpecialisation bndr)) = 1
-- Avoid things with specialisations; we'd like
-- to take advantage of them in the subsequent bindings
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
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
-
-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 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