\begin{code}
module OccurAnal (
occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
- markBinderInsideLambda
+ markBinderInsideLambda, tagBinders,
+ UsageDetails
) where
#include "HsVersions.h"
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUtils ( exprIsTrivial, idSpecVars )
+import CoreFVs ( idRuleVars )
+import CoreUtils ( exprIsTrivial )
import Const ( Con(..), Literal(..) )
-import Id ( idWantsToBeINLINEd, isSpecPragmaId,
+import Id ( isSpecPragmaId,
getInlinePragma, setInlinePragma,
- omitIfaceSigForId,
+ isExportedId, modifyIdInfo, idInfo,
getIdSpecialisation,
idType, idUnique, Id
)
-import IdInfo ( InlinePragInfo(..), OccInfo(..) )
-import SpecEnv ( isEmptySpecEnv )
+import IdInfo ( InlinePragInfo(..), OccInfo(..), copyIdInfo )
import VarSet
import VarEnv
-import PrelInfo ( noRepStrIds, noRepIntegerIds )
-import Name ( isExported, isLocallyDefined )
+import ThinAir ( noRepStrIds, noRepIntegerIds )
+import Name ( isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
import Digraph ( stronglyConnCompR, SCC(..) )
-import Unique ( u2i )
+import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import UniqFM ( keysUFM )
-import Util ( zipWithEqual, mapAndUnzip )
+import Util ( zipWithEqual, mapAndUnzip, count )
import Outputable
\end{code}
Here's the externally-callable interface:
\begin{code}
-occurAnalyseBinds
- :: (SimplifierSwitch -> Bool)
- -> [CoreBind]
- -> [CoreBind]
-
-occurAnalyseBinds simplifier_sw_chkr binds
- = binds'
- where
- (_, _, binds') = occAnalTop initial_env binds
-
- initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
- (\id -> isLocallyDefined id) -- Anything local is interesting
- emptyVarSet
-\end{code}
-
-
-\begin{code}
occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
-> CoreExpr
-> (IdEnv BinderInfo, -- Occ info for interesting free vars
occurAnalyseExpr interesting expr
= occAnal initial_env expr
where
- initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
- interesting
- emptyVarSet
+ initial_env = OccEnv interesting emptyVarSet []
occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
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 its tidier to do it here.
+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
because we might elminate a binding that's mentioned in the
unfolding for something.
-
\begin{code}
-occAnalTop :: OccEnv -- What's in scope
- -> [CoreBind]
- -> (IdEnv BinderInfo, -- Occurrence info
- IdEnv Id, -- Indirection elimination info
- [CoreBind]
- )
-
-occAnalTop env [] = (emptyDetails, emptyVarEnv, [])
-
--- 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
-
-occAnalTop env (bind : binds)
- = case bind of
- NonRec exported_id (Var local_id) | shortMeOut ind_env exported_id local_id
- -> -- Aha! An indirection; let's eliminate it!
- (scope_usage, ind_env', binds')
+occurAnalyseBinds :: [CoreBind] -> [CoreBind]
+
+occurAnalyseBinds binds
+ = binds'
+ where
+ (_, _, binds') = go initialTopEnv binds
+
+ go :: OccEnv -> [CoreBind]
+ -> (UsageDetails, -- Occurrence info
+ IdEnv Id, -- Indirection elimination info
+ [CoreBind])
+
+ 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
+ other -> -- Ho ho! The normal case
(final_usage, ind_env, new_binds ++ binds')
- where
- (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
- where
- new_env = env `addNewCands` (bindersOf bind)
- (scope_usage, ind_env, binds') = occAnalTop new_env binds
-
- -- Deal with any indirections
- zap_bind (NonRec bndr rhs)
- | bndr `elemVarEnv` ind_env = Rec (zap (bndr,rhs))
- -- The Rec isn't strictly necessary, but it's convenient
- zap_bind (Rec pairs)
- | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
+
+initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting
+ emptyVarSet
+ []
- zap_bind bind = bind
-
- zap pair@(bndr,rhs) = case lookupVarEnv ind_env bndr of
- Nothing -> [pair]
- Just exported_id -> [(bndr, Var exported_id),
- (exported_id, rhs)]
+-- 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@(bndr,rhs)
+ = case lookupVarEnv ind_env bndr of
+ Nothing -> [pair]
+ Just exported_id -> [(bndr, Var exported_id),
+ (exported_id_w_info, rhs)]
+ where
+ exported_id_w_info = modifyIdInfo (copyIdInfo (idInfo bndr)) exported_id
+ -- See notes with copyIdInfo about propagating IdInfo from
+ -- one to t'other
+
shortMeOut ind_env exported_id local_id
- = isExported exported_id && -- Only if this is exported
+ = isExportedId exported_id && -- Only if this is exported
isLocallyDefined local_id && -- Only if this one is defined in this
-- module, so that we *can* change its
-- binding to be the exported thing!
- not (isExported local_id) && -- Only if this one is not itself exported,
+ not (isExportedId local_id) && -- Only if this one is not itself exported,
-- since the transformation will nuke it
- not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is
- -- something like a constructor, whose
- -- definition is implicitly exported and
- -- which must not vanish.
- -- To illustrate the preceding check consider
- -- data T = MkT Int
- -- mkT = MkT
- -- f x = MkT (x+1)
- -- Here, we'll make a local, non-exported, defn for MkT, and without the
- -- above condition we'll transform it to:
- -- mkT = \x. MkT [x]
- -- f = \y. mkT (y+1)
- -- This is bad because mkT will get the IdDetails of MkT, and won't
- -- be exported. Also the code generator won't make a definition for
- -- the MkT constructor.
- -- Slightly gruesome, this.
-
-
not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
\end{code}
pp_item (_, bndr, _) = ppr bndr
binders = map fst pairs
- new_env = env `addNewCands` binders
+ rhs_env = env `addNewCands` binders
analysed_pairs :: [Details1]
analysed_pairs = [ (bndr, rhs_usage, rhs')
| (bndr, rhs) <- pairs,
- let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
+ let (rhs_usage, rhs') = occAnalRhs rhs_env bndr rhs
]
sccs :: [SCC (Node Details1)]
score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker
score ((bndr, rhs), _, _)
| exprIsTrivial rhs &&
- not (isExported bndr) = 3 -- Practically certain to be inlined
- | inlineCandidate bndr = 3 -- Likely to be inlined
+ 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 (isEmptySpecEnv (getIdSpecialisation bndr)) = 1
- -- Avoid things with a SpecEnv; we'd like
- -- to take advantage of the SpecEnv in the subsequent bindings
+ | not (isEmptyCoreRules (getIdSpecialisation bndr)) = 1
+ -- Avoid things with specialisations; we'd like
+ -- to take advantage of them in the subsequent bindings
| otherwise = 0
- inlineCandidate :: Id -> Bool
- inlineCandidate id
- = case getInlinePragma id of
- IWantToBeINLINEd -> True
- IMustBeINLINEd -> True
- ICanSafelyBeINLINEd _ _ -> True
- other -> False
+ inlineCandidate :: Id -> CoreExpr -> Bool
+ inlineCandidate id (Note InlineMe _) = True
+ inlineCandidate id rhs = case getInlinePragma id of
+ IMustBeINLINEd -> True
+ ICanSafelyBeINLINEd _ _ -> True
+ other -> False
-- Real example (the Enum Ordering instance from PrelBase):
-- rec f = \ x -> case d of (p,q,r) -> p x
[March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
[June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
-[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
-the "parent" keeps the specialised "children" alive. If the parent
-dies (because it isn't referenced any more), then the children will
-die too unless they are already referenced directly.
\begin{code}
occAnalRhs :: OccEnv
-> Id -> CoreExpr -- Binder and rhs
-> (UsageDetails, CoreExpr)
-{- DELETED SLPJ June 98: seems quite bogus to me
-occAnalRhs env id (Var v)
- | isCandidate env v
- = (unitVarEnv v (markMany (funOccurrence 0)), Var v)
-
- | otherwise
- = (emptyDetails, Var v)
--}
-
occAnalRhs env id rhs
- | idWantsToBeINLINEd id
- = (mapVarEnv markMany total_usage, rhs')
-
- | otherwise
- = (total_usage, rhs')
-
+ = (final_usage, rhs')
where
- (rhs_usage, rhs') = occAnal env rhs
- lazy_rhs_usage = mapVarEnv markLazy rhs_usage
- total_usage = foldVarSet add lazy_rhs_usage spec_ids
- add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
- -- (i.e manyOcc) because many copies
- -- of the specialised thing can appear
- spec_ids = idSpecVars id
-\end{code}
-
+ (rhs_usage, rhs') = occAnal (zapCtxt env) rhs
+
+ -- [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
+ -- the "parent" keeps the specialised "children" alive. If the parent
+ -- 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)
+ add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
+ -- (i.e manyOcc) because many copies
+ -- of the specialised thing can appear
\end{code}
Expressions
occAnal env (Type t) = (emptyDetails, Type t)
-occAnal env (Var v)
- | isCandidate env v = (unitVarEnv v funOccZero, Var v)
- | otherwise = (emptyDetails, Var v)
+occAnal env (Var v)
+ = (var_uds, Var v)
+ where
+ var_uds | isCandidate env v = unitVarEnv v funOccZero
+ | otherwise = emptyDetails
+
+ -- 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
+ -- 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":
| otherwise = uds
occAnal env (Con con args)
- = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') ->
+ = case occAnalArgs env args of { (arg_uds, args') ->
let
- arg_uds = foldr combineUsageDetails emptyDetails arg_uds_s
-
-- 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
- PrimOp _ -> mapVarEnv markLazy arg_uds
other -> arg_uds
in
(final_arg_uds, Con con args')
\end{code}
\begin{code}
+occAnal env (Note InlineMe body)
+ = case occAnal env body of { (usage, body') ->
+ (mapVarEnv markMany usage, Note InlineMe body')
+ }
+
occAnal env (Note note@(SCC cc) body)
= case occAnal env body of { (usage, body') ->
(mapVarEnv markInsideSCC usage, Note note body')
\end{code}
\begin{code}
-occAnal env (App fun arg)
- = case occAnal env fun of { (fun_usage, fun') ->
- case occAnal env arg of { (arg_usage, arg') ->
- (fun_usage `combineUsageDetails` mapVarEnv markLazy arg_usage, App fun' arg')
- }}
-
+occAnal env app@(App fun arg)
+ = occAnalApp env (collectArgs app)
+
-- Ignore type variables altogether
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- (b) type variables not in environment
-- Then, the simplifier is careful when partially applying lambdas.
occAnal env expr@(Lam _ _)
- = case occAnal (env `addNewCands` binders) body of { (body_usage, body') ->
+ = case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') ->
let
(final_usage, tagged_binders) = tagBinders body_usage binders
+ really_final_usage = if linear then
+ final_usage
+ else
+ mapVarEnv markInsideLam final_usage
in
- (mapVarEnv markInsideLam final_usage,
+ (really_final_usage,
mkLams tagged_binders body') }
where
- (binders, body) = collectBinders expr
-
+ (binders, body) = collectBinders expr
+ (linear, env_body) = getCtxt env (count isId binders)
occAnal env (Case scrut bndr alts)
= case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
- case occAnal env scrut of { (scrut_usage, scrut') ->
+ 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
(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 = zapCtxt env
+\end{code}
+
+Applications are dealt with specially because we want
+the "build hack" to work.
+
+\begin{code}
+-- Hack for build, fold, runST
+occAnalApp env (Var fun, args)
+ = case args_stuff of { (args_uds, args') ->
+ let
+ final_uds = fun_uds `combineUsageDetails` args_uds
+ in
+ (final_uds, mkApps (Var fun) args') }
+ where
+ fun_uniq = idUnique fun
+
+ fun_uds | isCandidate env fun = unitVarEnv fun funOccZero
+ | otherwise = emptyDetails
+
+ 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
+ | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
+ | 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') ->
+ let
+ final_uds = fun_uds `combineUsageDetails` args_uds
+ in
+ (final_uds, mkApps fun' args') }}
+
+appSpecial :: OccEnv -> Int -> CtxtTy -> [CoreExpr] -> (UsageDetails, [CoreExpr])
+appSpecial env n ctxt args
+ = go n args
+ where
+ go n [] = (emptyDetails, []) -- Too few args
+
+ go 1 (arg:args) -- The magic arg
+ = case occAnal (setCtxt env ctxt) arg of { (arg_uds, arg') ->
+ case occAnalArgs env args of { (args_uds, args') ->
+ (combineUsageDetails arg_uds args_uds, arg':args') }}
+
+ go n (arg:args)
+ = case occAnal env arg of { (arg_uds, arg') ->
+ case go (n-1) args of { (args_uds, args') ->
+ (combineUsageDetails arg_uds args_uds, arg':args') }}
\end{code}
+
Case alternatives
~~~~~~~~~~~~~~~~~
\begin{code}
%************************************************************************
\begin{code}
-data OccEnv =
- OccEnv
- Bool -- IgnoreINLINEPragma flag
- -- False <=> OK to use INLINEPragma information
- -- True <=> ignore INLINEPragma information
+-- We gather inforamtion for variables that are either
+-- (a) in scope or
+-- (b) interesting
- (Id -> Bool) -- Tells whether an Id occurrence is interesting,
- -- given the set of in-scope variables
+data OccEnv =
+ OccEnv (Id -> Bool) -- Tells whether an Id occurrence is interesting,
+ IdSet -- In-scope Ids
+ CtxtTy -- Tells about linearity
- IdSet -- In-scope Ids
+type CtxtTy = [Bool]
+ -- [] No info
+ --
+ -- True:ctxt Analysing a function-valued expression that will be
+ -- applied just once
+ --
+ -- False:ctxt Analysing a function-valued expression that may
+ -- be applied many times; but when it is,
+ -- the CtxtTy inside applies
+isCandidate :: OccEnv -> Id -> Bool
+isCandidate (OccEnv ifun cands _) id = id `elemVarSet` cands || ifun id
addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv ip ifun cands) ids
- = OccEnv ip ifun (cands `unionVarSet` mkVarSet ids)
+addNewCands (OccEnv ifun cands ctxt) ids
+ = OccEnv ifun (cands `unionVarSet` mkVarSet ids) ctxt
addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv ip ifun cands) id
- = OccEnv ip ifun (extendVarSet cands id)
+addNewCand (OccEnv ifun cands ctxt) id
+ = OccEnv ifun (extendVarSet cands id) ctxt
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ ifun cands) id = id `elemVarSet` cands || ifun id
+setCtxt :: OccEnv -> CtxtTy -> OccEnv
+setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt
+getCtxt :: OccEnv -> Int -> (Bool, OccEnv) -- True <=> this is a linear lambda
+ -- The Int is the number of lambdas
+getCtxt env@(OccEnv ifun cands []) n = (False, env)
+getCtxt (OccEnv ifun cands ctxt) n = (and (take n ctxt), OccEnv ifun cands (drop n ctxt))
+ -- Only return True if *all* the lambdas are linear
+
+zapCtxt env@(OccEnv ifun cands []) = env
+zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands []
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
unitDetails id info = (unitVarEnv id info :: UsageDetails)
usedIn :: Id -> UsageDetails -> Bool
-v `usedIn` details = isExported v
- || v `elemVarEnv` details
- || isSpecPragmaId v
+v `usedIn` details = isExportedId v || v `elemVarEnv` details
tagBinders :: UsageDetails -- Of scope
-> [Id] -- Binders
ICanSafelyBeINLINEd _ _ -> new_bndr -- from the previous iteration of
IAmALoopBreaker -> new_bndr -- the occurrence analyser
- IAmASpecPragmaId -> bndr -- Don't ever overwrite or drop these as dead
-
other | its_now_dead -> new_bndr -- Overwrite the others iff it's now dead
| otherwise -> bndr
new_prag = occInfoToInlinePrag occ_info
occ_info
- | isExported bndr = noBinderInfo
+ | 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.