\begin{code}
module OccurAnal (
- occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
- markBinderInsideLambda, tagBinders,
- UsageDetails
+ occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule
) where
#include "HsVersions.h"
import BinderInfo
-import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
-import Const ( Con(..), Literal(..) )
-import Id ( isSpecPragmaId, isOneShotLambda,
- getInlinePragma, setInlinePragma,
+import Id ( isSpecPragmaId, isDataConId, isOneShotLambda, setOneShotLambda,
+ idOccInfo, setIdOccInfo,
isExportedId, modifyIdInfo, idInfo,
- getIdSpecialisation,
+ idSpecialisation,
idType, idUnique, Id
)
-import IdInfo ( InlinePragInfo(..), OccInfo(..), copyIdInfo )
+import IdInfo ( OccInfo(..), insideLam, copyIdInfo )
import VarSet
import VarEnv
-import ThinAir ( noRepStrIds, noRepIntegerIds )
import Name ( isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
import Digraph ( stronglyConnCompR, SCC(..) )
import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import UniqFM ( keysUFM )
-import Util ( zipWithEqual, mapAndUnzip, count )
+import Util ( zipWithEqual, mapAndUnzip )
import Outputable
\end{code}
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
snd (occurAnalyseExpr (\_ -> False) expr)
+
+occurAnalyseRule :: CoreRule -> CoreRule
+occurAnalyseRule rule@(BuiltinRule _) = rule
+occurAnalyseRule (Rule str tpl_vars tpl_args rhs)
+ -- Add occ info to tpl_vars, rhs
+ = Rule str tpl_vars' tpl_args rhs'
+ where
+ (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs
+ (_, tpl_vars') = tagBinders rhs_uds tpl_vars
\end{code}
occAnalBind env (Rec pairs) body_usage
= foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
where
- pp_item (_, bndr, _) = ppr bndr
-
binders = map fst pairs
rhs_env = env `addNewCands` binders
-- Common case of simple self-recursion
reOrderRec env (CyclicSCC [bind])
- = [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
+ = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
where
((tagged_bndr, rhs), _, _) = bind
-- do SCC analysis on the rest, and recursively sort them out
concat (map (reOrderRec env) (stronglyConnCompR unchosen))
++
- [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
+ [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
where
(chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
not (isExportedId bndr) = 3 -- Practically certain to be inlined
| inlineCandidate bndr rhs = 3 -- Likely to be inlined
| not_fun_ty (idType bndr) = 2 -- Data types help with cases
- | not (isEmptyCoreRules (getIdSpecialisation bndr)) = 1
+ | not (isEmptyCoreRules (idSpecialisation bndr)) = 1
-- Avoid things with specialisations; we'd like
-- to take advantage of them in the subsequent bindings
| otherwise = 0
inlineCandidate :: Id -> CoreExpr -> Bool
inlineCandidate id (Note InlineMe _) = True
- inlineCandidate id rhs = case getInlinePragma id of
- IMustBeINLINEd -> True
- ICanSafelyBeINLINEd _ _ -> True
- other -> False
+ inlineCandidate id rhs = case idOccInfo id of
+ OneOcc _ _ -> True
+ other -> False
-- Real example (the Enum Ordering instance from PrelBase):
-- rec f = \ x -> case d of (p,q,r) -> p x
Constructors are rather like lambdas in this way.
\begin{code}
- -- For NoRep literals we have to report an occurrence of
- -- the things which tidyCore will later add, so that when
- -- we are compiling the very module in which those thin-air Ids
- -- are defined we have them in scope!
-occAnal env expr@(Con (Literal lit) args)
- = ASSERT( null args )
- (mk_lit_uds lit, expr)
- where
- mk_lit_uds (NoRepStr _ _) = try noRepStrIds
- mk_lit_uds (NoRepInteger _ _) = try noRepIntegerIds
- mk_lit_uds lit = emptyDetails
-
- try vs = foldr add emptyDetails vs
- add v uds | isCandidate env v = extendVarEnv uds v funOccZero
- | otherwise = uds
-
-occAnal env (Con con args)
- = case occAnalArgs env args of { (arg_uds, args') ->
- let
- -- We mark the free vars of the argument of a constructor as "many"
- -- This means that nothing gets inlined into a constructor argument
- -- position, which is what we want. Typically those constructor
- -- arguments are just variables, or trivial expressions.
- final_arg_uds = case con of
- DataCon _ -> mapVarEnv markMany arg_uds
- other -> arg_uds
- in
- (final_arg_uds, Con con args')
- }
+occAnal env expr@(Lit lit) = (emptyDetails, expr)
\end{code}
\begin{code}
= case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') ->
let
(final_usage, tagged_binders) = tagBinders body_usage binders
+ -- URGH! Sept 99: we don't seem to be able to use binders' here, because
+ -- we get linear-typed things in the resulting program that we can't handle yet.
+ -- (e.g. PrelShow) TODO
+
really_final_usage = if linear then
final_usage
else
(really_final_usage,
mkLams tagged_binders body') }
where
- (binders, body) = collectBinders expr
- (linear, env_body) = oneShotGroup env (filter isId binders)
+ (binders, body) = collectBinders expr
+ (linear, env_body, _) = oneShotGroup env binders
occAnal env (Case scrut bndr alts)
= case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
case occAnal (zapCtxt env) scrut of { (scrut_usage, scrut') ->
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
- (alts_usage1, tagged_bndr) = tagBinder alts_usage bndr
+ alts_usage' = addCaseBndrUsage alts_usage
+ (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
total_usage = scrut_usage `combineUsageDetails` alts_usage1
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr 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.
+ -- We *don't* want to transform
+ -- case x of w { (p,q) -> f w }
+ -- into
+ -- case x of w { (p,q) -> f (p,q) }
+ addCaseBndrUsage usage = case lookupVarEnv usage bndr of
+ Nothing -> usage
+ Just occ -> extendVarEnv usage bndr (markMany occ)
+
occAnal env (Let bind body)
= case occAnal new_env body of { (body_usage, body') ->
case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
| fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
| fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
| fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
+
+ | isDataConId fun = case occAnalArgs env args of
+ (arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
+ -- We mark the free vars of the argument of a constructor as "many"
+ -- This means that nothing gets inlined into a constructor argument
+ -- position, which is what we want. Typically those constructor
+ -- arguments are just variables, or trivial expressions.
+
| otherwise = occAnalArgs env args
+
occAnalApp env (fun, args)
= case occAnal (zapCtxt env) fun of { (fun_uds, fun') ->
case occAnalArgs env args of { (args_uds, args') ->
setCtxt :: OccEnv -> CtxtTy -> OccEnv
setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt
-oneShotGroup :: OccEnv -> [Id] -> (Bool, OccEnv) -- True <=> this is a one-shot linear lambda group
- -- The [Id] are the binders
+oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr])
+ -- True <=> this is a one-shot linear lambda group
+ -- The [CoreBndr] are the binders.
+
+ -- 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 ifun cands ctxt) bndrs
- = (go bndrs ctxt, OccEnv ifun cands (drop (length bndrs) ctxt))
+ = case go ctxt bndrs [] of
+ (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv ifun cands new_ctxt, new_bndrs)
where
- -- Only return True if *all* the lambdas are linear
- go (bndr:bndrs) (lin:ctxt) = (lin || isOneShotLambda bndr) && go bndrs ctxt
- go [] ctxt = True
- go bndrs [] = all isOneShotLambda bndrs
+ is_one_shot b = isId b && isOneShotLambda b
+
+ go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs)
+
+ go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
+ | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
+ where
+ bndr' | lin_ctxt = setOneShotLambda bndr
+ | otherwise = bndr
+
+ go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
+
zapCtxt env@(OccEnv ifun cands []) = env
zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands []
tagBinders usage binders
= let
usage' = usage `delVarEnvList` binders
- uss = map (setBinderPrag usage) binders
+ uss = map (setBinderOcc usage) binders
in
usage' `seq` (usage', uss)
tagBinder usage binder
= let
usage' = usage `delVarEnv` binder
- binder' = setBinderPrag usage binder
+ binder' = setBinderOcc usage binder
in
usage' `seq` (usage', binder')
-setBinderPrag :: UsageDetails -> CoreBndr -> CoreBndr
-setBinderPrag usage bndr
- | isTyVar bndr
- = bndr
-
- | otherwise
- = case old_prag of
- NoInlinePragInfo -> new_bndr
- IAmDead -> new_bndr -- The next three are annotations
- ICanSafelyBeINLINEd _ _ -> new_bndr -- from the previous iteration of
- IAmALoopBreaker -> new_bndr -- the occurrence analyser
-
- other | its_now_dead -> new_bndr -- Overwrite the others iff it's now dead
- | otherwise -> bndr
-
+setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
+setBinderOcc usage bndr
+ | isTyVar bndr = bndr
+ | isExportedId bndr
+ = -- Don't use local usage info for visible-elsewhere things
+ -- BUT *do* erase any IAmALoopBreaker annotation, because we're
+ -- about to re-generate it and it shouldn't be "sticky"
+ case idOccInfo bndr of
+ NoOccInfo -> bndr
+ other -> setIdOccInfo bndr NoOccInfo
+
+ | otherwise = setIdOccInfo bndr occ_info
where
- old_prag = getInlinePragma bndr
- new_bndr = setInlinePragma bndr new_prag
-
- its_now_dead = case new_prag of
- IAmDead -> True
- other -> False
-
- new_prag = occInfoToInlinePrag occ_info
-
- occ_info
- | isExportedId bndr = noBinderInfo
- -- Don't use local usage info for visible-elsewhere things
- -- But NB that we do set NoInlinePragma for exported things
- -- thereby nuking any IAmALoopBreaker from a previous pass.
-
- | otherwise = case lookupVarEnv usage bndr of
- Nothing -> deadOccurrence
- Just info -> info
-
-markBinderInsideLambda :: CoreBndr -> CoreBndr
-markBinderInsideLambda bndr
- | isTyVar bndr
- = bndr
-
- | otherwise
- = case getInlinePragma bndr of
- ICanSafelyBeINLINEd not_in_lam nalts
- -> bndr `setInlinePragma` ICanSafelyBeINLINEd InsideLam nalts
- other -> bndr
+ occ_info = case lookupVarEnv usage bndr of
+ Nothing -> IAmDead
+ Just info -> binderInfoToOccInfo info
funOccZero = funOccurrence 0
\end{code}
projects / ghc-hetmet.git / blobdiff