\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, isLocalId,
- isExportedId, idArity, idSpecialisation,
+ isExportedId, idArity,
idType, idUnique, Id
)
-import BasicTypes ( OccInfo(..), isOneOcc )
+import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
import VarSet
import VarEnv
(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 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 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
-
analysed_pairs :: [Details1]
analysed_pairs = [ (bndr, rhs_usage, rhs')
| (bndr, rhs) <- pairs,
| 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
-- 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 | isLocalId 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.
is_one_shot b = isId b && isOneShotBndr b
occAnal env (Case scrut bndr ty alts)
- = case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts') ->
- case occAnal vanillaCtxt 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
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 env body of { (body_usage, body') ->
case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
(fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
where
fun_uniq = idUnique fun
-
- fun_uds | isLocalId 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
%************************************************************************
\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