import BinderInfo
import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
import CoreSyn
-import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) )
+import CoreUtils ( idSpecVars )
+import Digraph ( stronglyConnCompR, SCC(..) )
import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
+ omitIfaceSigForId, isSpecPragmaId, getIdSpecialisation,
idType, idUnique, Id,
emptyIdSet, unionIdSets, mkIdSet,
- unitIdSet, elementOfIdSet,
+ elementOfIdSet,
addOneToIdSet, IdSet,
- nullIdEnv, unitIdEnv, combineIdEnvs,
+
+ IdEnv, nullIdEnv, unitIdEnv, combineIdEnvs,
delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
- mapIdEnv, lookupIdEnv, IdEnv,
- GenId{-instance Eq-}
+ mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv
)
+import SpecEnv ( isEmptySpecEnv )
import Name ( isExported, isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
import PprCore
-import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-import TyVar ( GenTyVar{-instance Eq-} )
-import Unique ( Unique{-instance Eq-}, u2i )
+import Unique ( u2i )
import UniqFM ( keysUFM )
-import Util ( assoc, zipEqual, zipWithEqual )
+import Util ( zipWithEqual )
import Outputable
-import List ( partition )
-
-isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[OccurAnal-types]{Data types}
-%* *
-%************************************************************************
-
-\begin{code}
-data OccEnv =
- OccEnv
- Bool -- Keep-unused-bindings flag
- -- False <=> OK to chuck away binding
- -- and ignore occurrences within it
- Bool -- Keep-spec-pragma-ids flag
- -- False <=> OK to chuck away spec pragma bindings
- -- and ignore occurrences within it
- Bool -- Keep-conjurable flag
- -- False <=> OK to throw away *dead*
- -- "conjurable" Ids; at the moment, that
- -- *only* means constant methods, which
- -- are top-level. A use of a "conjurable"
- -- Id may appear out of thin air -- e.g.,
- -- specialiser conjuring up refs to const methods.
- Bool -- IgnoreINLINEPragma flag
- -- False <=> OK to use INLINEPragma information
- -- True <=> ignore INLINEPragma information
-
- (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
- -- given the set of in-scope variables
-
- IdSet -- In-scope Ids
-
-
-addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv kd ks kc ip ifun cands) ids
- = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids)
-
-addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv ks kd kc ip ifun cands) id
- = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)
-
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands
-
-inlineMe :: OccEnv -> Id -> Bool
-inlineMe env id
- = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
- not ignore_inline_prag &&
- -}
- idWantsToBeINLINEd id
-
-keepUnusedBinding :: OccEnv -> Id -> Bool
-keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
- = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
-
-keepBecauseConjurable :: OccEnv -> Id -> Bool
-keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
- = False
- {- keep_conjurable && isConstMethodId binder -}
-
-type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
-
-combineUsageDetails, combineAltsUsageDetails
- :: UsageDetails -> UsageDetails -> UsageDetails
-
-combineUsageDetails usage1 usage2
- = combineIdEnvs addBinderInfo usage1 usage2
-
-combineAltsUsageDetails usage1 usage2
- = combineIdEnvs orBinderInfo usage1 usage2
-
-addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
-addOneOcc usage id info
- = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
- -- ToDo: make this more efficient
-
-emptyDetails = (nullIdEnv :: UsageDetails)
-
-unitDetails id info = (unitIdEnv id info :: UsageDetails)
-
-tagBinders :: UsageDetails -- Of scope
- -> [Id] -- Binders
- -> (UsageDetails, -- Details with binders removed
- [(Id,BinderInfo)]) -- Tagged binders
-
-tagBinders usage binders =
- let
- usage' = usage `delManyFromIdEnv` binders
- uss = [ (binder, usage_of usage binder) | binder <- binders ]
- in
- if isNullIdEnv usage' then
- (usage', uss)
- else
- (usage', uss)
-{-
- = (usage `delManyFromIdEnv` binders,
- [ (binder, usage_of usage binder) | binder <- binders ]
- )
--}
-tagBinder :: UsageDetails -- Of scope
- -> Id -- Binders
- -> (UsageDetails, -- Details with binders removed
- (Id,BinderInfo)) -- Tagged binders
-
-tagBinder usage binder =
- let
- usage' = usage `delOneFromIdEnv` binder
- us = usage_of usage binder
- cont =
- if isNullIdEnv usage' then -- Bogus test to force evaluation.
- (usage', (binder, us))
- else
- (usage', (binder, us))
- in
- if isDeadOcc us then -- Ditto
- cont
- else
- cont
-
-
-usage_of usage binder
- | isExported binder = noBinderInfo -- Visible-elsewhere things count as many
- | otherwise
- = case (lookupIdEnv usage binder) of
- Nothing -> deadOccurrence
- Just info -> info
-
-isNeeded env usage binder
- = if isDeadOcc (usage_of usage binder) then
- keepUnusedBinding env binder -- Maybe keep it anyway
- else
- True
\end{code}
occurAnalyseBinds binds simplifier_sw_chkr
| opt_D_dump_occur_anal = pprTrace "OccurAnal:"
- (vcat (map ppr_bind binds'))
- binds'
- | otherwise = binds'
+ (pprGenericBindings new_binds)
+ new_binds
+ | otherwise = new_binds
where
- (_, binds') = doo initial_env binds
+ new_binds = concat binds'
+ (_, _, binds') = occAnalTop initial_env binds
- initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
- (simplifier_sw_chkr KeepSpecPragmaIds)
- (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
- (simplifier_sw_chkr IgnoreINLINEPragma)
+ initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
(\id in_scope -> isLocallyDefined id) -- Anything local is interesting
emptyIdSet -- Not actually used
-
- doo env [] = (emptyDetails, [])
- doo env (bind:binds)
- = (final_usage, new_binds ++ the_rest)
- where
- new_env = env `addNewCands` (bindersOf bind)
- (binds_usage, the_rest) = doo new_env binds
- (final_usage, new_binds) = occAnalBind env bind binds_usage
-
- -- This really ought to be done properly by PprCore, but
- -- it isn't. pprCoreBinding only works on Id binders, and
- -- the general case is complicated by the fact that it has to work
- -- for interface files too. Sigh
-
-ppr_bind bind@(NonRec binder expr)
- = ppr bind
-
-ppr_bind bind@(Rec binds)
- = vcat [ptext SLIT("Rec {"),
- nest 2 (ppr bind),
- ptext SLIT("end Rec }")]
\end{code}
+
\begin{code}
occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
-> CoreExpr
occurAnalyseExpr interesting expr
= occAnal initial_env expr
where
- initial_env = OccEnv False {- Drop unused bindings -}
- False {- Drop SpecPragmaId bindings -}
- True {- Keep conjurable Ids -}
- False {- Do not ignore INLINE Pragma -}
+ initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
(\id locals -> interesting id || elementOfIdSet id locals)
emptyIdSet
snd (occurAnalyseExpr (\_ -> False) expr)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Top level stuff}
+%* *
+%************************************************************************
+
+In @occAnalTop@ we do indirection-shorting. That is, if we have this:
+
+ loc = <expression>
+ ...
+ exp = loc
+
+where exp is exported, and loc is not, then we replace it with this:
+
+ loc = exp
+ exp = <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 its 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:
+\begin{verbatim}
+ x_local = ....
+ x_exported1 = x_local
+ x_exported2 = x_local
+==>
+ x_exported1 = ....
+
+ x_exported2 = x_exported1
+\end{verbatim}
+
+We rely on prior eta reduction to simplify things like
+\begin{verbatim}
+ x_exported = /\ tyvars -> x_local tyvars
+==>
+ x_exported = x_local
+\end{verbatim}
+Hence,there's a possibility of leaving unchanged something like this:
+\begin{verbatim}
+ x_local = ....
+ x_exported1 = x_local Int
+\end{verbatim}
+By the time we've thrown away the types in STG land this
+could be eliminated. But I don't think it's very common
+and it's dangerous to do this fiddling in STG land
+because we might elminate a binding that's mentioned in the
+unfolding for something.
+
+
+\begin{code}
+occAnalTop :: OccEnv -- What's in scope
+ -> [CoreBinding]
+ -> (IdEnv BinderInfo, -- Occurrence info
+ IdEnv Id, -- Indirection elimination info
+ [[SimplifiableCoreBinding]]
+ )
+occAnalTop env [] = (emptyDetails, nullIdEnv, [])
+occAnalTop env (bind : binds)
+ = case bind of
+ NonRec exported_id (Var local_id)
+ | isExported 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,
+ -- 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 (maybeToBool (lookupIdEnv ind_env local_id))
+ -- Only if not already substituted for
+ -> -- Aha! An indirection; let's eliminate it!
+ (scope_usage, ind_env', binds')
+ where
+ ind_env' = addOneToIdEnv ind_env local_id exported_id
+
+ other
+ -> -- 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 `elemIdEnv` ind_env = Rec (zap (bndr,rhs))
+ -- The Rec isn't strictly necessary, but it's convenient
+ zap_bind (Rec pairs)
+ | or [id `elemIdEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
+
+ zap_bind bind = bind
+
+ zap pair@(bndr,rhs) = case lookupIdEnv ind_env bndr of
+ Nothing -> [pair]
+ Just exported_id -> [(bndr, Var exported_id),
+ (exported_id, rhs)]
+
+\end{code}
+
+
%************************************************************************
%* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
\begin{code}
type Node details = (details, Int, [Int]) -- The Ints are gotten from the Unique,
-- which is gotten from the Id.
-type Details1 = (Id, (UsageDetails, SimplifiableCoreExpr))
+type Details1 = (Id, UsageDetails, SimplifiableCoreExpr)
type Details2 = ((Id, BinderInfo), SimplifiableCoreExpr)
occAnalBind env (Rec pairs) body_usage
= foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
where
- pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))]
- pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item]
pp_item (_, bndr, _) = ppr bndr
binders = map fst pairs
new_env = env `addNewCands` binders
analysed_pairs :: [Details1]
- analysed_pairs = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs]
+ analysed_pairs = [ (nukeNoInlinePragma bndr, rhs_usage, rhs')
+ | (bndr, rhs) <- pairs,
+ let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
+ ]
sccs :: [SCC (Node Details1)]
sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
---- stuff for dependency analysis of binds -------------------------------
edges :: [Node Details1]
edges = _scc_ "occAnalBind.assoc"
- [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage)
- | pair@(id, (rhs_usage, rhs)) <- analysed_pairs
+ [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage)
+ | details@(id, rhs_usage, rhs) <- analysed_pairs
]
-- (a -> b) means a mentions b
---- stuff to "re-constitute" bindings from dependency-analysis info ------
-- Non-recursive SCC
- do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far)
+ do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
| isNeeded env body_usage bndr
= (combined_usage, new_bind : binds_so_far)
| otherwise
| otherwise
= (body_usage, binds_so_far) -- Dead code
where
- pairs = [pair | (pair, _, _) <- cycle]
- bndrs = [bndr | (bndr, _) <- pairs]
- rhs_usages = [rhs_usage | (_, (rhs_usage, _)) <- pairs]
+ details = [details | (details, _, _) <- cycle]
+ bndrs = [bndr | (bndr, _, _) <- details]
+ rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details]
total_usage = foldr combineUsageDetails body_usage rhs_usages
(combined_usage, tagged_binders) = tagBinders total_usage bndrs
final_bind = Rec (reOrderRec env new_cycle)
new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
- mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys)
+ mk_new_bind (bndr, occ_info) ((_, _, rhs'), key, keys) = (((bndr, occ_info), rhs'), key, keys)
\end{code}
@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
-- dontINLINE pragmas that there are no loops left.
-- Non-recursive case
-reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]
+reOrderRec env (AcyclicSCC (bind, _, _)) = [bind]
-- Common case of simple self-recursion
reOrderRec env (CyclicSCC [bind])
= [((addNoInlinePragma bndr, occ_info), rhs)]
where
- (((bndr,occ_info), rhs), _, _) = bind
+ (((bndr, occ_info), rhs), _, _) = bind
reOrderRec env (CyclicSCC binds)
= -- Choose a loop breaker, mark it no-inline,
((bndr,occ_info), rhs) = chosen_pair
-- Choosing the loop breaker; heursitic
- choose_loop_breaker (bind@(pair, _, _) : rest)
+ choose_loop_breaker (bind@(details, _, _) : rest)
| not (null rest) &&
- bad_choice pair
+ bad_choice details
= (chosen, bind : unchosen) -- Don't pick it
| otherwise -- Pick it
- = (pair,rest)
+ = (details,rest)
where
(chosen, unchosen) = choose_loop_breaker rest
|| inlineMe env bndr -- Dont pick INLINE thing
|| isOneFunOcc occ_info -- Dont pick single-occ thing
|| not_fun_ty (idType bndr) -- Dont pick data-ty thing
+ || not (isEmptySpecEnv (getIdSpecialisation bndr))
+ -- Avoid things with a SpecEnv; we'd like
+ -- to take advantage of the SpecEnv in the subsuequent bindings
-- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
-- We stick to just FunOccs because if we're not going to be able
[March 97] We do the same for atomic RHSs. Reason: 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
occAnalRhs env id rhs
| inlineMe env id
- = (mapIdEnv markMany rhs_usage, rhs')
+ = (mapIdEnv markMany total_usage, rhs')
| otherwise
- = (rhs_usage, rhs')
+ = (total_usage, rhs')
where
(rhs_usage, rhs') = occAnal env rhs
+ total_usage = foldr add rhs_usage (idSpecVars 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
Constructors are rather like lambdas in this way.
\begin{code}
-occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
- Con con args)
+occAnal env (Con con args)
+ = (mapIdEnv markDangerousToDup (occAnalArgs env args),
+ Con con args)
-occAnal env (SCC cc body)
- = (mapIdEnv markInsideSCC usage, SCC cc body')
+occAnal env (Note note@(SCC cc) body)
+ = (mapIdEnv markInsideSCC usage, Note note body')
where
(usage, body') = occAnal env body
-occAnal env (Coerce c ty body)
- = (usage, Coerce c ty body')
+occAnal env (Note note body)
+ = (usage, Note note body')
where
(usage, body') = occAnal env body
| otherwise = emptyDetails
occAnalArg _ _ = emptyDetails
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[OccurAnal-types]{Data types}
+%* *
+%************************************************************************
+
+\begin{code}
+data OccEnv =
+ OccEnv
+ Bool -- IgnoreINLINEPragma flag
+ -- False <=> OK to use INLINEPragma information
+ -- True <=> ignore INLINEPragma information
+
+ (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
+ -- given the set of in-scope variables
+
+ IdSet -- In-scope Ids
+
+
+addNewCands :: OccEnv -> [Id] -> OccEnv
+addNewCands (OccEnv ip ifun cands) ids
+ = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids)
+
+addNewCand :: OccEnv -> Id -> OccEnv
+addNewCand (OccEnv ip ifun cands) id
+ = OccEnv ip ifun (addOneToIdSet cands id)
+
+isCandidate :: OccEnv -> Id -> Bool
+isCandidate (OccEnv _ ifun cands) id = ifun id cands
+
+inlineMe :: OccEnv -> Id -> Bool
+inlineMe env id
+ = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
+ not ignore_inline_prag &&
+ -}
+ idWantsToBeINLINEd id
+
+
+type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
+
+combineUsageDetails, combineAltsUsageDetails
+ :: UsageDetails -> UsageDetails -> UsageDetails
+
+combineUsageDetails usage1 usage2
+ = combineIdEnvs addBinderInfo usage1 usage2
+
+combineAltsUsageDetails usage1 usage2
+ = combineIdEnvs orBinderInfo usage1 usage2
+
+addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
+addOneOcc usage id info
+ = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
+ -- ToDo: make this more efficient
+
+emptyDetails = (nullIdEnv :: UsageDetails)
+
+unitDetails id info = (unitIdEnv id info :: UsageDetails)
+
+tagBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ [(Id,BinderInfo)]) -- Tagged binders
+
+tagBinders usage binders =
+ let
+ usage' = usage `delManyFromIdEnv` binders
+ uss = [ (binder, usage_of usage binder) | binder <- binders ]
+ in
+ if isNullIdEnv usage' then
+ (usage', uss)
+ else
+ (usage', uss)
+{-
+ = (usage `delManyFromIdEnv` binders,
+ [ (binder, usage_of usage binder) | binder <- binders ]
+ )
+-}
+tagBinder :: UsageDetails -- Of scope
+ -> Id -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ (Id,BinderInfo)) -- Tagged binders
+
+tagBinder usage binder =
+ let
+ usage' = usage `delOneFromIdEnv` binder
+ us = usage_of usage binder
+ cont =
+ if isNullIdEnv usage' then -- Bogus test to force evaluation.
+ (usage', (binder, us))
+ else
+ (usage', (binder, us))
+ in
+ if isDeadOcc us then -- Ditto
+ cont
+ else
+ cont
+
+
+usage_of usage binder
+ | isExported binder || isSpecPragmaId binder
+ = noBinderInfo -- Visible-elsewhere things count as many
+ | otherwise
+ = case (lookupIdEnv usage binder) of
+ Nothing -> deadOccurrence
+ Just info -> info
+
+isNeeded env usage binder = not (isDeadOcc (usage_of usage binder))
+\end{code}
+
+
projects / ghc-hetmet.git / blobdiff