%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
core expression with (hopefully) improved usage information.
\begin{code}
-#include "HsVersions.h"
-
module OccurAnal (
- occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
+ occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
+ markBinderInsideLambda
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(List(partition))
+#include "HsVersions.h"
import BinderInfo
-import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
+import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) )
-import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
- idType, idUnique, SYN_IE(Id),
- isConstMethodId,
- emptyIdSet, unionIdSets, mkIdSet,
- unitIdSet, elementOfIdSet,
- addOneToIdSet, SYN_IE(IdSet),
- nullIdEnv, unitIdEnv, combineIdEnvs,
- delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
- mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
- GenId{-instance Eq-}
+import CoreUtils ( exprIsTrivial, idSpecVars )
+import Const ( Con(..), Literal(..) )
+import Id ( idWantsToBeINLINEd, isSpecPragmaId,
+ getInlinePragma, setInlinePragma,
+ omitIfaceSigForId,
+ getIdSpecialisation,
+ idType, idUnique, Id
)
+import IdInfo ( InlinePragInfo(..), OccInfo(..) )
+import SpecEnv ( isEmptySpecEnv )
+
+import VarSet
+import VarEnv
+
+import PrelInfo ( noRepStrIds, noRepIntegerIds )
import Name ( isExported, isLocallyDefined )
-import Type ( getFunTy_maybe, splitForAllTy )
+import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
-import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} )
-import PprCore
-import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-import Pretty ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
-import TyVar ( GenTyVar{-instance Eq-} )
-import Unique ( Unique{-instance Eq-}, u2i )
-import UniqFM ( keysUFM )
-import Util ( assoc, zipEqual, zipWithEqual, Ord3(..)
- , pprTrace, panic
-#ifdef DEBUG
- , assertPanic
-#endif
- )
-
-isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
+import Digraph ( stronglyConnCompR, SCC(..) )
+import Unique ( u2i )
+import UniqFM ( keysUFM )
+import Util ( zipWithEqual, mapAndUnzip )
+import Outputable
\end{code}
%************************************************************************
%* *
-\subsection[OccurAnal-types]{Data types}
+\subsection[OccurAnal-main]{Counting occurrences: main function}
%* *
%************************************************************************
-\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)
+Here's the externally-callable interface:
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands
+\begin{code}
+occurAnalyseBinds
+ :: (SimplifierSwitch -> Bool)
+ -> [CoreBind]
+ -> [CoreBind]
-inlineMe :: OccEnv -> Id -> Bool
-inlineMe env id
- = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
- not ignore_inline_prag &&
- -}
- idWantsToBeINLINEd id
+occurAnalyseBinds simplifier_sw_chkr binds
+ = binds'
+ where
+ (_, _, binds') = occAnalTop initial_env binds
-keepUnusedBinding :: OccEnv -> Id -> Bool
-keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
- = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
+ initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
+ (\id -> isLocallyDefined id) -- Anything local is interesting
+ emptyVarSet
+\end{code}
-keepBecauseConjurable :: OccEnv -> Id -> Bool
-keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
- = keep_conjurable && isConstMethodId binder
-type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
+\begin{code}
+occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
+ -> CoreExpr
+ -> (IdEnv BinderInfo, -- Occ info for interesting free vars
+ CoreExpr)
-combineUsageDetails, combineAltsUsageDetails
- :: UsageDetails -> UsageDetails -> UsageDetails
+occurAnalyseExpr interesting expr
+ = occAnal initial_env expr
+ where
+ initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
+ interesting
+ emptyVarSet
-combineUsageDetails usage1 usage2
- = combineIdEnvs addBinderInfo usage1 usage2
+occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
+occurAnalyseGlobalExpr expr
+ = -- Top level expr, so no interesting free vars, and
+ -- discard occurence info returned
+ snd (occurAnalyseExpr (\_ -> False) expr)
+\end{code}
-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
+%************************************************************************
+%* *
+\subsection{Top level stuff}
+%* *
+%************************************************************************
-emptyDetails = (nullIdEnv :: UsageDetails)
+In @occAnalTop@ we do indirection-shorting. That is, if we have this:
-unitDetails id info = (unitIdEnv id info :: UsageDetails)
+ loc = <expression>
+ ...
+ exp = loc
-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
+where exp is exported, and loc is not, then we replace it with this:
-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
- case us of { DeadCode -> cont; _ -> cont }
+ loc = exp
+ exp = <expression>
+ ...
--- (binder, usage_of usage binder)
+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.
-usage_of usage binder
- | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
- | otherwise
- = case (lookupIdEnv usage binder) of
- Nothing -> DeadCode
- Just info -> info
-
-isNeeded env usage binder
- = case (usage_of usage binder) of
- DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
- other -> True
-\end{code}
+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}
-%************************************************************************
-%* *
-\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
-%************************************************************************
+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.
-Here's the externally-callable interface:
\begin{code}
-occurAnalyseBinds
- :: [CoreBinding] -- input
- -> (SimplifierSwitch -> Bool)
- -> [SimplifiableCoreBinding] -- output
-
-occurAnalyseBinds binds simplifier_sw_chkr
- | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
- (vcat (map ppr_bind binds'))
- binds'
- | otherwise = binds'
+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')
+ where
+ ind_env' = extendVarEnv ind_env local_id exported_id
+
+ 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
- (_, binds') = doo initial_env binds
-
- initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
- (simplifier_sw_chkr KeepSpecPragmaIds)
- (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
- (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 PprDebug bind
-
-ppr_bind bind@(Rec binds)
- = vcat [ptext SLIT("Rec {"),
- nest 2 (ppr PprDebug bind),
- ptext SLIT("end Rec }")]
+ 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))
+
+ 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)]
+
+shortMeOut ind_env exported_id 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 (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
\end{code}
-\begin{code}
-occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
- -> CoreExpr
- -> (IdEnv BinderInfo, -- Occ info for interesting free vars
- SimplifiableCoreExpr)
-
-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 -}
- (\id locals -> interesting id || elementOfIdSet id locals)
- emptyIdSet
-
-occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
-occurAnalyseGlobalExpr expr
- = -- Top level expr, so no interesting free vars, and
- -- discard occurence info returned
- snd (occurAnalyseExpr (\_ -> False) expr)
-\end{code}
%************************************************************************
%* *
~~~~~~~~
\begin{code}
+type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached
+
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 Details2 = ((Id, BinderInfo), SimplifiableCoreExpr)
+type Details1 = (Id, UsageDetails, CoreExpr)
+type Details2 = (IdWithOccInfo, CoreExpr)
occAnalBind :: OccEnv
- -> CoreBinding
+ -> CoreBind
-> UsageDetails -- Usage details of scope
-> (UsageDetails, -- Of the whole let(rec)
- [SimplifiableCoreBinding])
+ [CoreBind])
occAnalBind env (NonRec binder rhs) body_usage
- | isNeeded env body_usage binder -- It's mentioned in body
+ | not (binder `usedIn` body_usage) -- It's not mentioned
+ = (body_usage, [])
+
+ | otherwise -- It's mentioned in the body
= (final_body_usage `combineUsageDetails` rhs_usage,
[NonRec tagged_binder rhs'])
- | otherwise -- Not mentioned, so drop dead code
- = (body_usage, [])
-
where
- binder' = nukeNoInlinePragma binder
- (rhs_usage, rhs') = occAnalRhs env binder' rhs
- (final_body_usage, tagged_binder) = tagBinder body_usage binder'
+ (final_body_usage, tagged_binder) = tagBinder body_usage binder
+ (rhs_usage, rhs') = occAnalRhs env binder rhs
\end{code}
Dropping dead code for recursive bindings is done in a very simple way:
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 PprDebug bndr
+ 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 = [ (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
-- by just extracting the keys from the finite map. Grimy, but fast.
-- Previously we had this:
-- [ bndr | bndr <- bndrs,
- -- maybeToBool (lookupIdEnv rhs_usage bndr)]
+ -- maybeToBool (lookupVarEnv rhs_usage bndr)]
-- which has n**2 cost, and this meant that edges_from alone
-- consumed 10% of total runtime!
edges_from :: UsageDetails -> [Int]
---- 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)
- | isNeeded env body_usage bndr
- = (combined_usage, new_bind : binds_so_far)
- | otherwise
+ do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
+ | not (bndr `usedIn` body_usage)
= (body_usage, binds_so_far) -- Dead code
+ | otherwise
+ = (combined_usage, new_bind : binds_so_far)
where
total_usage = combineUsageDetails body_usage rhs_usage
(combined_usage, tagged_bndr) = tagBinder total_usage bndr
-- Recursive SCC
do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
- | any (isNeeded env body_usage) bndrs
- = (combined_usage, final_bind:binds_so_far)
- | otherwise
+ | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
= (body_usage, binds_so_far) -- Dead code
+ | otherwise
+ = (combined_usage, final_bind:binds_so_far)
where
- pairs = [pair | (pair, _, _) <- cycle]
- bndrs = [bndr | (bndr, _) <- pairs]
- rhs_usages = [rhs_usage | (_, (rhs_usage, _)) <- pairs]
- 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)
+ 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_bndrs) = tagBinders total_usage bndrs
+ final_bind = Rec (reOrderRec env new_cycle)
+
+ new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_bndrs cycle)
+ mk_new_bind tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys)
\end{code}
@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
that the simplifier will generally do a good job if it works from top bottom,
recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
+==============
+[June 98: I don't understand the following paragraphs, and I've
+ changed the a=b case again so that it isn't a special case any more.]
+
Here's a case that bit me:
letrec
...a...a...a....
Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
-(The first binding was a var-rhs; the second was a one-occ.) So the simplifier looped.
+
My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
Perhaps something cleverer would suffice.
+===============
+
+You might think that you can prevent non-termination simply by making
+sure that we simplify a recursive binding's RHS in an environment that
+simply clones the recursive Id. But no. Consider
+
+ letrec f = \x -> let z = f x' in ...
+
+ in
+ let n = f y
+ in
+ case n of { ... }
+
+We bind n to its *simplified* RHS, we then *re-simplify* it when
+we inline n. Then we may well inline f; and then the same thing
+happens with z!
+
+I don't think it's possible to prevent non-termination by environment
+manipulation in this way. Apart from anything else, successive
+iterations of the simplifier may unroll recursive loops in cases like
+that above. The idea of beaking every recursive loop with an
+IMustNotBeINLINEd pragma is much much better.
+
\begin{code}
reOrderRec
-- 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)]
+ = [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
where
- (((bndr,occ_info), rhs), _, _) = bind
+ ((tagged_bndr, rhs), _, _) = bind
-reOrderRec env (CyclicSCC binds)
+reOrderRec env (CyclicSCC (bind : binds))
= -- Choose a loop breaker, mark it no-inline,
-- do SCC analysis on the rest, and recursively sort them out
concat (map (reOrderRec env) (stronglyConnCompR unchosen))
++
- [((addNoInlinePragma bndr, occ_info), rhs)]
+ [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)]
where
- (chosen_pair, unchosen) = choose_loop_breaker binds
- ((bndr,occ_info), rhs) = chosen_pair
-
- -- Choosing the loop breaker; heursitic
- choose_loop_breaker (bind@(pair, _, _) : rest)
- | not (null rest) &&
- bad_choice pair
- = (chosen, bind : unchosen) -- Don't pick it
- | otherwise -- Pick it
- = (pair,rest)
- where
- (chosen, unchosen) = choose_loop_breaker rest
+ (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
+ (tagged_bndr, rhs) = chosen_pair
- bad_choice ((bndr, occ_info), rhs)
- = var_rhs rhs -- Dont pick var RHS
- || inlineMe env bndr -- Dont pick INLINE thing
- || one_occ occ_info -- Dont pick single-occ thing
- || not_fun_ty (idType bndr) -- Dont pick data-ty thing
+ -- This loop looks for the bind with the lowest score
+ -- to pick as the loop breaker. The rest accumulate in
+ choose_loop_breaker (details,_,_) loop_sc acc []
+ = (details, acc) -- Done
- not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
- where
- (_, rho_ty) = splitForAllTy ty
-
- -- A variable RHS
- var_rhs (Var v) = True
- var_rhs other_rhs = False
+ choose_loop_breaker loop_bind loop_sc acc (bind : binds)
+ | sc < loop_sc -- Lower score so pick this new one
+ = choose_loop_breaker bind sc (loop_bind : acc) binds
- -- One textual occurrence, whether inside lambda or whatever
- -- We stick to just FunOccs because if we're not going to be able
- -- to inline the thing on this round it might be better to pick
- -- this one as the loop breaker. Real example (the Enum Ordering instance
- -- from PrelBase):
+ | otherwise -- No lower so don't pick it
+ = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
+ where
+ sc = score bind
+
+ 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_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
+ | otherwise = 0
+
+ inlineCandidate :: Id -> Bool
+ inlineCandidate id
+ = case getInlinePragma id of
+ IWantToBeINLINEd -> True
+ 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
-- g = \ x -> case d of (p,q,r) -> q x
-- d = (v, f, g)
-- Here, f and g occur just once; but we can't inline them into d.
-- On the other hand we *could* simplify those case expressions if
-- we didn't stupidly choose d as the loop breaker.
+ -- But we won't because constructor args are marked "Many".
- one_occ (OneOcc fun_or_arg _ _ _ _) = isFun fun_or_arg
- one_occ other_bind = False
+ not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
+ where
+ (_, rho_ty) = splitForAllTys ty
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
ToDo: try using the occurrence info for the inline'd binder.
[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, SimplifiableCoreExpr)
+ -> (UsageDetails, CoreExpr)
+{- DELETED SLPJ June 98: seems quite bogus to me
occAnalRhs env id (Var v)
| isCandidate env v
- = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
+ = (unitVarEnv v (markMany (funOccurrence 0)), Var v)
| otherwise
= (emptyDetails, Var v)
+-}
occAnalRhs env id rhs
- | inlineMe env id
- = (mapIdEnv markMany rhs_usage, rhs')
+ | idWantsToBeINLINEd id
+ = (mapVarEnv markMany total_usage, rhs')
| otherwise
- = (rhs_usage, rhs')
+ = (total_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}
+
\end{code}
Expressions
occAnal :: OccEnv
-> CoreExpr
-> (UsageDetails, -- Gives info only about the "interesting" Ids
- SimplifiableCoreExpr)
-
-occAnal env (Var v)
- | isCandidate env v
- = (unitIdEnv v (funOccurrence 0), Var v)
+ CoreExpr)
- | otherwise
- = (emptyDetails, Var v)
+occAnal env (Type t) = (emptyDetails, Type t)
-occAnal env (Lit lit) = (emptyDetails, Lit lit)
-occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
+occAnal env (Var v)
+ | isCandidate env v = (unitVarEnv v funOccZero, Var v)
+ | otherwise = (emptyDetails, Var v)
\end{code}
We regard variables that occur as constructor arguments as "dangerousToDup":
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 (SCC cc body)
- = (mapIdEnv markInsideSCC usage, SCC cc body')
+ -- 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
- (usage, body') = occAnal env body
+ 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 mapAndUnzip (occAnal env) args of { (arg_uds_s, 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}
-occAnal env (Coerce c ty body)
- = (usage, Coerce c ty body')
- where
- (usage, body') = occAnal env body
+\begin{code}
+occAnal env (Note note@(SCC cc) body)
+ = case occAnal env body of { (usage, body') ->
+ (mapVarEnv markInsideSCC usage, Note note body')
+ }
+
+occAnal env (Note note body)
+ = case occAnal env body of { (usage, body') ->
+ (usage, Note note body')
+ }
+\end{code}
+\begin{code}
occAnal env (App fun arg)
- = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
- where
- (fun_usage, fun') = occAnal env fun
- arg_usage = occAnalArg env 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')
+ }}
+
+-- Ignore type variables altogether
+-- (a) occurrences inside type lambdas only not marked as InsideLam
+-- (b) type variables not in environment
+
+occAnal env expr@(Lam x body) | isTyVar x
+ = case occAnal env body of { (body_usage, body') ->
+ (body_usage, Lam x body')
+ }
-- For value lambdas we do a special hack. Consider
-- (\x. \y. ...x...)
-- If we did nothing, x is used inside the \y, so would be marked
-- as dangerous to dup. But in the common case where the abstraction
-- is applied to two arguments this is over-pessimistic.
--- So instead we don't take account of the \y when dealing with x's usage;
--- instead, the simplifier is careful when partially applying lambdas
-
-occAnal env expr@(Lam (ValBinder binder) body)
- = (mapIdEnv markDangerousToDup final_usage,
- foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
+-- So instead, we just mark each binder with its occurrence
+-- info in the *body* of the multiple lambda.
+-- Then, the simplifier is careful when partially applying lambdas.
+
+occAnal env expr@(Lam _ _)
+ = case occAnal (env `addNewCands` binders) body of { (body_usage, body') ->
+ let
+ (final_usage, tagged_binders) = tagBinders body_usage binders
+ in
+ (mapVarEnv markInsideLam final_usage,
+ mkLams tagged_binders body') }
where
- (binders,body) = collectValBinders expr
- (body_usage, body') = occAnal (env `addNewCands` binders) body
- (final_usage, tagged_binders) = tagBinders body_usage binders
-
--- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
-occAnal env (Lam (TyBinder tyvar) body)
- = case occAnal env body of { (body_usage, body') ->
- (mapIdEnv markDangerousToDup body_usage,
- Lam (TyBinder tyvar) body') }
--- where
--- (body_usage, body') = occAnal env body
-
-occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
-
-occAnal env (Case scrut alts)
- = case occAnalAlts env alts of { (alts_usage, alts') ->
- case occAnal env scrut of { (scrut_usage, scrut') ->
- let
- det = scrut_usage `combineUsageDetails` alts_usage
- in
- if isNullIdEnv det then
- (det, Case scrut' alts')
- else
- (det, Case scrut' alts') }}
-{-
- (scrut_usage `combineUsageDetails` alts_usage,
- Case scrut' alts')
+ (binders, body) = collectBinders expr
+
+
+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') ->
+ let
+ alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
+ (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
- (scrut_usage, scrut') = occAnal env scrut
- (alts_usage, alts') = occAnalAlts env alts
--}
+ alt_env = env `addNewCand` bndr
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) ->
- (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
+ (final_usage, mkLets new_binds body') }}
where
- new_env = env `addNewCands` (bindersOf bind)
--- (body_usage, body') = occAnal new_env body
--- (final_usage, new_binds) = occAnalBind env bind body_usage
+ new_env = env `addNewCands` (bindersOf bind)
\end{code}
Case alternatives
~~~~~~~~~~~~~~~~~
\begin{code}
-occAnalAlts env (AlgAlts alts deflt)
- = (foldr combineAltsUsageDetails deflt_usage alts_usage,
- -- Note: combine*Alts*UsageDetails...
- AlgAlts alts' deflt')
- where
- (alts_usage, alts') = unzip (map do_alt alts)
- (deflt_usage, deflt') = occAnalDeflt env deflt
+occAnalAlt env (con, bndrs, rhs)
+ = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') ->
+ let
+ (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
+ in
+ (final_usage, (con, tagged_bndrs, rhs')) }
+\end{code}
- do_alt (con, args, rhs)
- = (final_usage, (con, tagged_args, rhs'))
- where
- new_env = env `addNewCands` args
- (rhs_usage, rhs') = occAnal new_env rhs
- (final_usage, tagged_args) = tagBinders rhs_usage args
-
-occAnalAlts env (PrimAlts alts deflt)
- = (foldr combineAltsUsageDetails deflt_usage alts_usage,
- -- Note: combine*Alts*UsageDetails...
- PrimAlts alts' deflt')
- where
- (alts_usage, alts') = unzip (map do_alt alts)
- (deflt_usage, deflt') = occAnalDeflt env deflt
- do_alt (lit, rhs)
- = (rhs_usage, (lit, rhs'))
- where
- (rhs_usage, rhs') = occAnal env rhs
+%************************************************************************
+%* *
+\subsection[OccurAnal-types]{Data types}
+%* *
+%************************************************************************
+
+\begin{code}
+data OccEnv =
+ OccEnv
+ Bool -- IgnoreINLINEPragma flag
+ -- False <=> OK to use INLINEPragma information
+ -- True <=> ignore INLINEPragma information
-occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
+ (Id -> Bool) -- Tells whether an Id occurrence is interesting,
+ -- given the set of in-scope variables
-occAnalDeflt env (BindDefault binder rhs)
- = (final_usage, BindDefault tagged_binder rhs')
- where
- new_env = env `addNewCand` binder
- (rhs_usage, rhs') = occAnal new_env rhs
- (final_usage, tagged_binder) = tagBinder rhs_usage binder
-\end{code}
+ IdSet -- In-scope Ids
-Atoms
-~~~~~
-\begin{code}
-occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
+addNewCands :: OccEnv -> [Id] -> OccEnv
+addNewCands (OccEnv ip ifun cands) ids
+ = OccEnv ip ifun (cands `unionVarSet` mkVarSet ids)
+
+addNewCand :: OccEnv -> Id -> OccEnv
+addNewCand (OccEnv ip ifun cands) id
+ = OccEnv ip ifun (extendVarSet cands id)
+
+isCandidate :: OccEnv -> Id -> Bool
+isCandidate (OccEnv _ ifun cands) id = id `elemVarSet` cands || ifun id
+
+
+type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
+
+combineUsageDetails, combineAltsUsageDetails
+ :: UsageDetails -> UsageDetails -> UsageDetails
+
+combineUsageDetails usage1 usage2
+ = plusVarEnv_C addBinderInfo usage1 usage2
+
+combineAltsUsageDetails usage1 usage2
+ = plusVarEnv_C orBinderInfo usage1 usage2
+
+addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
+addOneOcc usage id info
+ = plusVarEnv_C addBinderInfo 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 = isExported v
+ || v `elemVarEnv` details
+ || isSpecPragmaId v
+
+tagBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ [IdWithOccInfo]) -- Tagged binders
+
+tagBinders usage binders
+ = let
+ usage' = usage `delVarEnvList` binders
+ uss = map (setBinderPrag usage) binders
+ in
+ usage' `seq` (usage', uss)
+
+tagBinder :: UsageDetails -- Of scope
+ -> Id -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ IdWithOccInfo) -- Tagged binders
+
+tagBinder usage binder
+ = let
+ usage' = usage `delVarEnv` binder
+ binder' = setBinderPrag 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
+
+ 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
-occAnalArgs env atoms
- = foldr do_one_atom emptyDetails atoms
where
- do_one_atom (VarArg v) usage
- | isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
- do_one_atom other_arg usage = usage
+ 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
+ | isExported 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.
-occAnalArg :: OccEnv -> CoreArg -> UsageDetails
+ | 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
-occAnalArg env (VarArg v)
- | isCandidate env v = unitDetails v (argOccurrence 0)
- | otherwise = emptyDetails
-occAnalArg _ _ = emptyDetails
+funOccZero = funOccurrence 0
\end{code}