%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
%* *
%************************************************************************
-The occurrence analyser analyses the way in which variables are used
-in their scope, and pins that information on the binder. It does {\em
-not} take any strategic decisions about what to do as a result (eg
-discard binding, inline binding etc). That's the job of the
-simplifier.
-
-The occurrence analyser {\em simply} records usage information. That is,
-it pins on each binder info on how that binder occurs in its scope.
-
-Any uses within the RHS of a let(rec) binding for a variable which is
-itself unused are ignored. For example:
-@
- let x = ...
- y = ...x...
- in
- x+1
-@
-Here, y is unused, so x will be marked as appearing just once.
-
-An exported Id gets tagged as ManyOcc.
-
-IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
-
-Lambdas
-~~~~~~~
-The occurrence analyser marks each binder in a lambda the same way.
-Thus:
- \ x y -> f y x
-will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
-Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
-but the simplifer very carefully takes care of this special case.
-(See the CoLam case in simplExpr.)
-
-Why? Because typically applications are saturated, in which case x is *not*
-dangerous-to-dup.
-
-Things to muse upon
-~~~~~~~~~~~~~~~~~~~
-
-There *is* a reason not to substitute for
-variables applied to types: it can undo the effect of floating
-Consider:
-\begin{verbatim}
- c = /\a -> e
- f = /\b -> let d = c b
- in \ x::b -> ...
-\end{verbatim}
-Here, inlining c would be a Bad Idea.
-
-At present I've set it up so that the "inside-lambda" flag sets set On for
-type-lambdas too, which effectively prevents such substitutions. I don't *think*
-it disables any interesting ones either.
+The occurrence analyser re-typechecks a core expression, returning a new
+core expression with (hopefully) improved usage information.
\begin{code}
#include "HsVersions.h"
module OccurAnal (
- occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
-
- -- and to make the interface self-sufficient...
- CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
- PlainCoreProgram(..), PlainCoreExpr(..),
- SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
+ occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
) where
-IMPORT_Trace
-import Outputable -- ToDo: rm; debugging
-import Pretty
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
-import PlainCore -- the stuff we read...
-import TaggedCore -- ... and produce Simplifiable*
-
-import AbsUniType
import BinderInfo
-import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
-import Digraph ( stronglyConnComp )
-import Id ( eqId, idWantsToBeINLINEd, isConstMethodId_maybe,
- isSpecPragmaId_maybe, SpecInfo )
-import IdEnv
-import Maybes
-import UniqSet
-import Util
+import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
+import CoreSyn
+import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) )
+import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
+ idType, idUnique, SYN_IE(Id),
+ emptyIdSet, unionIdSets, mkIdSet,
+ unitIdSet, elementOfIdSet,
+ addOneToIdSet, SYN_IE(IdSet),
+ nullIdEnv, unitIdEnv, combineIdEnvs,
+ delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
+ mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
+ GenId{-instance Eq-}
+ )
+import Name ( isExported, isLocallyDefined )
+import Type ( getFunTy_maybe, splitForAllTy )
+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"
\end{code}
%************************************************************************
\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
- (UniqSet Id) -- Candidates
+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 keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
+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 keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
+addNewCand (OccEnv ks kd kc ip ifun cands) id
+ = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)
isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
+isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands
-ignoreINLINEPragma :: OccEnv -> Bool
-ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
+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 && is_spec)
- where
- is_spec = maybeToBool (isSpecPragmaId_maybe binder)
+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
- = keep_conjurable && is_conjurable
- where
- is_conjurable = maybeToBool (isConstMethodId_maybe binder)
+keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
+ = False
+ {- keep_conjurable && isConstMethodId binder -}
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
:: UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineBinderInfo usage1 usage2
- --ESCC
+ = combineIdEnvs addBinderInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineAltsBinderInfo usage1 usage2
- --ESCC
+ = combineIdEnvs orBinderInfo usage1 usage2
addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
-addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
+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
+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]
+ [ (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
+ case us of { DeadCode -> cont; _ -> cont }
+
+-- (binder, usage_of usage binder)
-tagBinder :: UsageDetails -- Of scope
- -> Id -- Binders
- -> (UsageDetails, -- Details with binders removed
- (Id,BinderInfo)) -- Tagged binders
-
-tagBinder usage binder
- = (usage `delOneFromIdEnv` binder,
- (binder, usage_of usage binder)
- )
usage_of usage binder
- | isExported binder = ManyOcc 0 -- Exported things count as many
+ | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
| otherwise
- = case lookupIdEnv usage binder of
+ = case (lookupIdEnv usage binder) of
Nothing -> DeadCode
Just info -> info
isNeeded env usage binder
- = case usage_of usage binder of
+ = case (usage_of usage binder) of
DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
other -> True
\end{code}
\begin{code}
occurAnalyseBinds
- :: [PlainCoreBinding] -- input
- -> (GlobalSwitch -> Bool)
+ :: [CoreBinding] -- input
-> (SimplifierSwitch -> Bool)
-> [SimplifiableCoreBinding] -- output
-occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
- | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
- | otherwise = binds'
+occurAnalyseBinds binds simplifier_sw_chkr
+ | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
+ (vcat (map ppr_bind binds'))
+ binds'
+ | otherwise = binds'
where
- (_, binds') = do initial_env binds
+ (_, 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)
- emptyUniqSet
+ (\id in_scope -> isLocallyDefined id) -- Anything local is interesting
+ emptyIdSet -- Not actually used
- do env [] = (emptyDetails, [])
- do env (bind:binds)
+ doo env [] = (emptyDetails, [])
+ doo env (bind:binds)
= (final_usage, new_binds ++ the_rest)
where
new_env = env `addNewCands` (bindersOf bind)
- (binds_usage, the_rest) = do new_env binds
- (final_usage, new_binds) = --BSCC("occAnalBind1")
- occAnalBind env bind binds_usage
- --ESCC
+ (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 }")]
\end{code}
\begin{code}
-occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
- -> PlainCoreExpr
- -> (IdEnv BinderInfo, -- Occ info for interesting free vars
+occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
+ -> CoreExpr
+ -> (IdEnv BinderInfo, -- Occ info for interesting free vars
SimplifiableCoreExpr)
-occurAnalyseExpr candidates expr
+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 -}
- candidates
+ (\id locals -> interesting id || elementOfIdSet id locals)
+ emptyIdSet
-occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
+occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
occurAnalyseGlobalExpr expr
- = -- Top level expr, so no interesting free vars, and
+ = -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
- expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
+ snd (occurAnalyseExpr (\_ -> False) expr)
\end{code}
%************************************************************************
~~~~~~~~
\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 Details2 = ((Id, BinderInfo), SimplifiableCoreExpr)
+
+
occAnalBind :: OccEnv
- -> PlainCoreBinding
+ -> CoreBinding
-> UsageDetails -- Usage details of scope
-> (UsageDetails, -- Of the whole let(rec)
[SimplifiableCoreBinding])
-occAnalBind env (CoNonRec binder rhs) body_usage
+occAnalBind env (NonRec binder rhs) body_usage
| isNeeded env body_usage binder -- It's mentioned in body
= (final_body_usage `combineUsageDetails` rhs_usage,
- [CoNonRec tagged_binder rhs'])
+ [NonRec tagged_binder rhs'])
- | otherwise
+ | otherwise -- Not mentioned, so drop dead code
= (body_usage, [])
where
- (rhs_usage, rhs') = occAnalRhs env binder rhs
- (final_body_usage, tagged_binder) = tagBinder body_usage binder
+ binder' = nukeNoInlinePragma binder
+ (rhs_usage, rhs') = occAnalRhs env binder' rhs
+ (final_body_usage, tagged_binder) = tagBinder body_usage binder'
\end{code}
Dropping dead code for recursive bindings is done in a very simple way:
This seems to miss an obvious improvement.
@
- letrec f = ...g...
- g = ...f...
- in
+ letrec f = ...g...
+ g = ...f...
+ in
...g...
===>
\begin{code}
-occAnalBind env (CoRec pairs) body_usage
- = foldr do_final_bind (body_usage, []) sccs
+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
- (binders, rhss) = unzip pairs
- new_env = env `addNewCands` binders
-
- analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
- analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
-
- lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
- lookup id = assoc "occAnalBind:lookup" analysed_pairs id
+ binders = map fst pairs
+ new_env = env `addNewCands` binders
+ analysed_pairs :: [Details1]
+ analysed_pairs = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs]
- ---- stuff for dependency analysis of binds -------------------------------
+ sccs :: [SCC (Node Details1)]
+ sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
- edges :: [(Id,Id)] -- (a,b) means a mentions b
- edges = concat [ edges_from binder rhs_usage
- | (binder, (rhs_usage, _)) <- analysed_pairs]
- edges_from :: Id -> UsageDetails -> [(Id,Id)]
- edges_from id its_rhs_usage
- = [(id,mentioned) | mentioned <- binders,
- maybeToBool (lookupIdEnv its_rhs_usage mentioned)
- ]
-
- sccs :: [[Id]]
- sccs = case binders of
- [_] -> [binders] -- Singleton; no need to analyse
- other -> stronglyConnComp eqId edges binders
+ ---- 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
+ ]
+
+ -- (a -> b) means a mentions b
+ -- Given the usage details (a UFM that gives occ info for each free var of
+ -- the RHS) we can get the list of free vars -- or rather their Int keys --
+ -- by just extracting the keys from the finite map. Grimy, but fast.
+ -- Previously we had this:
+ -- [ bndr | bndr <- bndrs,
+ -- maybeToBool (lookupIdEnv rhs_usage bndr)]
+ -- which has n**2 cost, and this meant that edges_from alone
+ -- consumed 10% of total runtime!
+ edges_from :: UsageDetails -> [Int]
+ edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
+ keysUFM rhs_usage
---- stuff to "re-constitute" bindings from dependency-analysis info ------
- do_final_bind sCC@[binder] (body_usage, binds_so_far)
- | isNeeded env body_usage binder
- = (combined_usage, new_bind:binds_so_far)
-
- | otherwise -- Dead
- = (body_usage, binds_so_far)
+ -- 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
+ = (body_usage, binds_so_far) -- Dead code
where
- total_usage = combineUsageDetails body_usage rhs_usage
- (rhs_usage, rhs') = lookup binder
- (combined_usage, tagged_binder) = tagBinder total_usage binder
-
- new_bind
- | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
- | otherwise = CoNonRec tagged_binder rhs'
- where
- mentions_itself binder usage
- = maybeToBool (lookupIdEnv usage binder)
-
- do_final_bind sCC (body_usage, binds_so_far)
- | any (isNeeded env body_usage) sCC
- = (combined_usage, new_bind:binds_so_far)
-
- | otherwise -- Dead
- = (body_usage, binds_so_far)
+ total_usage = combineUsageDetails body_usage rhs_usage
+ (combined_usage, tagged_bndr) = tagBinder total_usage bndr
+ new_bind = NonRec tagged_bndr rhs'
+
+ -- 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
+ = (body_usage, binds_so_far) -- Dead code
where
- (rhs_usages, rhss') = unzip (map lookup sCC)
+ 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 sCC
+ (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)
+\end{code}
+
+@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
+strongly connected component (there's guaranteed to be a cycle). It returns the
+same pairs, but
+ a) in a better order,
+ b) with some of the Ids having a IMustNotBeINLINEd pragma
- new_bind = CoRec (tagged_binders `zip` rhss')
+The "no-inline" Ids are sufficient to break all cycles in the SCC. This means
+that the simplifier can guarantee not to loop provided it never records an inlining
+for these no-inline guys.
+
+Furthermore, the order of the binds is such that if we neglect dependencies
+on the no-inline Ids then the binds are topologically sorted. This means
+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.
+
+Here's a case that bit me:
+
+ letrec
+ a = b
+ b = \x. BIG
+ in
+ ...a...a...a....
+
+Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
+
+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
+ :: OccEnv
+ -> SCC (Node Details2)
+ -> [Details2]
+ -- Sorted into a plausible order. Enough of the Ids have
+ -- dontINLINE pragmas that there are no loops left.
+
+ -- Non-recursive case
+reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]
+
+ -- Common case of simple self-recursion
+reOrderRec env (CyclicSCC [bind])
+ = [((addNoInlinePragma bndr, occ_info), rhs)]
+ where
+ (((bndr,occ_info), rhs), _, _) = bind
+
+reOrderRec env (CyclicSCC 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)]
+
+ 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
+
+ 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
+
+ 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
+
+ -- 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):
+ -- 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.
+
+ one_occ (OneOcc fun_or_arg _ _ _ _) = isFun fun_or_arg
+ one_occ other_bind = False
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
we'll catch it next time round. At worst this costs an extra simplifier pass.
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.
+
\begin{code}
occAnalRhs :: OccEnv
- -> Id -- Binder
- -> PlainCoreExpr -- Rhs
+ -> Id -> CoreExpr -- Binder and rhs
-> (UsageDetails, SimplifiableCoreExpr)
+occAnalRhs env id (Var v)
+ | isCandidate env v
+ = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
+
+ | otherwise
+ = (emptyDetails, Var v)
+
occAnalRhs env id rhs
- | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
+ | inlineMe env id
= (mapIdEnv markMany rhs_usage, rhs')
| otherwise
~~~~~~~~~~~
\begin{code}
occAnal :: OccEnv
- -> PlainCoreExpr
- -> (UsageDetails, -- Gives info only about the "interesting" Ids
+ -> CoreExpr
+ -> (UsageDetails, -- Gives info only about the "interesting" Ids
SimplifiableCoreExpr)
-occAnal env (CoVar v)
+occAnal env (Var v)
| isCandidate env v
- = (unitIdEnv v (funOccurrence 0), CoVar v)
+ = (unitIdEnv v (funOccurrence 0), Var v)
| otherwise
- = (emptyDetails, CoVar v)
+ = (emptyDetails, Var v)
+
+occAnal env (Lit lit) = (emptyDetails, Lit lit)
+occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
+\end{code}
+
+We regard variables that occur as constructor arguments as "dangerousToDup":
+
+\begin{verbatim}
+module A where
+f x = let y = expensive x in
+ let z = (True,y) in
+ (case z of {(p,q)->q}, case z of {(p,q)->q})
+\end{verbatim}
+
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
-occAnal env (CoLit lit) = (emptyDetails, CoLit lit)
-occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
-occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
-occAnal env (CoSCC cc body)
- = (mapIdEnv markInsideSCC usage, CoSCC cc body')
+\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')
where
(usage, body') = occAnal env body
-occAnal env (CoApp fun arg)
- = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
- where
- (fun_usage, fun') = occAnal env fun
- arg_usage = occAnalAtom env arg
-
-occAnal env (CoTyApp fun ty)
- = (fun_usage, CoTyApp fun' ty)
+occAnal env (Coerce c ty body)
+ = (usage, Coerce c ty body')
where
- (fun_usage, fun') = occAnal env fun
+ (usage, body') = occAnal env body
-occAnal env (CoLam binders body)
- = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
+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
+
+-- 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)
where
- new_env = env `addNewCands` binders
- (body_usage, body') = occAnal new_env body
+ (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 (CoTyLam tyvar body)
- = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body')
- where
- (body_usage, body') = occAnal env body
-
-occAnal env (CoCase scrut alts)
- = (scrut_usage `combineUsageDetails` alts_usage,
- CoCase scrut' alts')
+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')
where
(scrut_usage, scrut') = occAnal env scrut
(alts_usage, alts') = occAnalAlts env alts
+-}
-occAnal env (CoLet bind body)
- = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh)
+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)
where
new_env = env `addNewCands` (bindersOf bind)
- (body_usage, body') = occAnal new_env body
- (final_usage, new_binds) = --BSCC("occAnalBind2")
- occAnalBind env bind body_usage
- --ESCC
+-- (body_usage, body') = occAnal new_env body
+-- (final_usage, new_binds) = occAnalBind env bind body_usage
\end{code}
Case alternatives
~~~~~~~~~~~~~~~~~
\begin{code}
-occAnalAlts env (CoAlgAlts alts deflt)
+occAnalAlts env (AlgAlts alts deflt)
= (foldr combineAltsUsageDetails deflt_usage alts_usage,
-- Note: combine*Alts*UsageDetails...
- CoAlgAlts alts' deflt')
+ AlgAlts alts' deflt')
where
(alts_usage, alts') = unzip (map do_alt alts)
(deflt_usage, deflt') = occAnalDeflt env deflt
(rhs_usage, rhs') = occAnal new_env rhs
(final_usage, tagged_args) = tagBinders rhs_usage args
-occAnalAlts env (CoPrimAlts alts deflt)
+occAnalAlts env (PrimAlts alts deflt)
= (foldr combineAltsUsageDetails deflt_usage alts_usage,
-- Note: combine*Alts*UsageDetails...
- CoPrimAlts alts' deflt')
+ PrimAlts alts' deflt')
where
(alts_usage, alts') = unzip (map do_alt alts)
(deflt_usage, deflt') = occAnalDeflt env deflt
where
(rhs_usage, rhs') = occAnal env rhs
-occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault)
+occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
-occAnalDeflt env (CoBindDefault binder rhs)
- = (final_usage, CoBindDefault tagged_binder rhs')
+occAnalDeflt env (BindDefault binder rhs)
+ = (final_usage, BindDefault tagged_binder rhs')
where
new_env = env `addNewCand` binder
(rhs_usage, rhs') = occAnal new_env rhs
Atoms
~~~~~
\begin{code}
-occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
+occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
-occAnalAtoms env atoms
+occAnalArgs env atoms
= foldr do_one_atom emptyDetails atoms
where
- do_one_atom (CoLitAtom lit) usage = usage
- do_one_atom (CoVarAtom v) usage
+ do_one_atom (VarArg v) usage
| isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
+ | otherwise = usage
+ do_one_atom other_arg usage = usage
-occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails
+occAnalArg :: OccEnv -> CoreArg -> UsageDetails
-occAnalAtom env (CoLitAtom lit) = emptyDetails
-occAnalAtom env (CoVarAtom v)
+occAnalArg env (VarArg v)
| isCandidate env v = unitDetails v (argOccurrence 0)
| otherwise = emptyDetails
+occAnalArg _ _ = emptyDetails
\end{code}
projects / ghc-hetmet.git / blobdiff