\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 Literal ( Literal(..) )
-import Id ( isSpecPragmaId, isDataConId, isOneShotLambda, setOneShotLambda,
+import Id ( isDataConId, isOneShotLambda, setOneShotLambda,
idOccInfo, setIdOccInfo,
isExportedId, modifyIdInfo, idInfo,
- idSpecialisation,
+ idSpecialisation, isLocalId,
idType, idUnique, Id
)
-import IdInfo ( OccInfo(..), insideLam, copyIdInfo )
+import IdInfo ( OccInfo(..), shortableIdInfo, copyIdInfo )
import VarSet
import VarEnv
-import Name ( isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, orElse )
import Digraph ( stronglyConnCompR, SCC(..) )
-import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
+import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
+import Unique ( u2i )
import UniqFM ( keysUFM )
-import Util ( zipWithEqual, mapAndUnzip, count )
+import Util ( zipWithEqual, mapAndUnzip )
+import FastTypes
import Outputable
\end{code}
\begin{code}
occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
-> CoreExpr
- -> (IdEnv BinderInfo, -- Occ info for interesting free vars
+ -> (IdEnv OccInfo, -- Occ info for interesting free vars
CoreExpr)
occurAnalyseExpr interesting expr
= -- 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 isLocalId rhs
+ (_, tpl_vars') = tagBinders rhs_uds tpl_vars
\end{code}
In @occAnalTop@ we do indirection-shorting. That is, if we have this:
- loc = <expression>
+ x_local = <expression>
...
- exp = loc
+ x_exported = loc
where exp is exported, and loc is not, then we replace it with this:
- loc = exp
- exp = <expression>
+ x_local = x_exported
+ x_exported = <expression>
...
-Without this we never get rid of the exp = loc 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.
-
+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:
go :: OccEnv -> [CoreBind]
-> (UsageDetails, -- Occurrence info
IdEnv Id, -- Indirection elimination info
- [CoreBind])
+ -- 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, [])
ind_env' = extendVarEnv ind_env local_id exported_id
other -> -- Ho ho! The normal case
- (final_usage, ind_env, new_binds ++ binds')
+ (final_usage, ind_env, new_binds ++ binds')
-initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting
+initialTopEnv = OccEnv isLocalId -- Anything local is interesting
emptyVarSet
[]
zapBind ind_env bind = bind
-zap ind_env pair@(bndr,rhs)
- = case lookupVarEnv ind_env bndr of
+zap ind_env pair@(local_id,rhs)
+ = case lookupVarEnv ind_env local_id 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
+ 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
- = 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 (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
+-- 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
+ if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable'
+ -- (see the defn of IdInfo.shortableIdInfo
+ then True
+ else pprTrace "shortMeOut:" (ppr exported_id) False
+ else
+ False
\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
---- stuff for dependency analysis of binds -------------------------------
edges :: [Node Details1]
edges = _scc_ "occAnalBind.assoc"
- [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage)
+ [ (details, iBox (u2i (idUnique id)), edges_from rhs_usage)
| details@(id, rhs_usage, rhs) <- analysed_pairs
]
score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker
score ((bndr, rhs), _, _)
- | exprIsTrivial rhs &&
- 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
+ | exprIsTrivial rhs = 4 -- Practically certain to be inlined
+ -- Used to have also: && not (isExportedId bndr)
+ -- But I found this sometimes cost an extra iteration when we have
+ -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
+ -- where df is the exported dictionary. Then df makes a really
+ -- bad choice for loop breaker
+
+ | not_fun_ty (idType bndr) = 3 -- Data types help with cases
+ -- This used to have a lower score than inlineCandidate, but
+ -- it's *really* helpful if dictionaries get inlined fast,
+ -- so I'm experimenting with giving higher priority to data-typed things
+
+ | 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
+
| otherwise = 0
inlineCandidate :: Id -> CoreExpr -> Bool
-- 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
+ 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}
occAnal env (Var v)
= (var_uds, Var v)
where
- var_uds | isCandidate env v = unitVarEnv v funOccZero
+ var_uds | isCandidate env v = unitVarEnv v oneOcc
| otherwise = emptyDetails
-- At one stage, I gathered the idRuleVars for v here too,
(really_final_usage,
mkLams tagged_binders body') }
where
- (binders, body) = collectBinders expr
- (linear, env_body, binders') = oneShotGroup env 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') ->
where
fun_uniq = idUnique fun
- fun_uds | isCandidate env fun = unitVarEnv fun funOccZero
+ fun_uds | isCandidate env fun = unitVarEnv fun oneOcc
| otherwise = emptyDetails
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
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
+type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
combineUsageDetails, combineAltsUsageDetails
:: UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetails usage1 usage2
- = plusVarEnv_C addBinderInfo usage1 usage2
+ = plusVarEnv_C addOccInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
- = plusVarEnv_C orBinderInfo usage1 usage2
+ = plusVarEnv_C orOccInfo usage1 usage2
-addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
+addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
addOneOcc usage id info
- = plusVarEnv_C addBinderInfo usage (unitVarEnv id info)
+ = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
-- ToDo: make this more efficient
emptyDetails = (emptyVarEnv :: UsageDetails)
-unitDetails id info = (unitVarEnv id info :: UsageDetails)
-
usedIn :: Id -> UsageDetails -> Bool
v `usedIn` details = isExportedId v || v `elemVarEnv` details
in
usage' `seq` (usage', binder')
-
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
+ | isExportedId bndr = case idOccInfo bndr of
+ NoOccInfo -> bndr
+ other -> setIdOccInfo bndr NoOccInfo
+ -- 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"
- | otherwise = setIdOccInfo bndr occ_info
+ | otherwise = setIdOccInfo bndr occ_info
where
- occ_info = case lookupVarEnv usage bndr of
- Nothing -> IAmDead
- Just info -> binderInfoToOccInfo info
+ occ_info = lookupVarEnv usage bndr `orElse` IAmDead
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Operations over OccInfo}
+%* *
+%************************************************************************
+
+\begin{code}
+oneOcc :: OccInfo
+oneOcc = OneOcc False True
+
+markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
+
+markMany IAmDead = IAmDead
+markMany other = NoOccInfo
+
+markInsideSCC occ = markMany occ
+
+markInsideLam (OneOcc _ one_br) = OneOcc True one_br
+markInsideLam occ = occ
+
+addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
+
+addOccInfo IAmDead info2 = info2
+addOccInfo info1 IAmDead = info1
+addOccInfo info1 info2 = NoOccInfo
-markBinderInsideLambda :: CoreBndr -> CoreBndr
-markBinderInsideLambda bndr
- | isTyVar bndr
- = bndr
+-- (orOccInfo orig new) is used
+-- when combining occurrence info from branches of a case
- | otherwise
- = case idOccInfo bndr of
- OneOcc _ once -> bndr `setIdOccInfo` OneOcc insideLam once
- other -> bndr
+orOccInfo IAmDead info2 = info2
+orOccInfo info1 IAmDead = info1
+orOccInfo (OneOcc in_lam1 one_branch1)
+ (OneOcc in_lam2 one_branch2)
+ = OneOcc (in_lam1 || in_lam2)
+ False -- False, because it occurs in both branches
-funOccZero = funOccurrence 0
+orOccInfo info1 info2 = NoOccInfo
\end{code}
projects / ghc-hetmet.git / blobdiff