%
-% (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
+ occurAnalysePgm, occurAnalyseExpr
) where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(IdLoop) -- paranoia
+#include "HsVersions.h"
-import BinderInfo
-import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
import CoreSyn
-import Digraph ( stronglyConnComp )
-import Id ( idWantsToBeINLINEd, isConstMethodId,
- externallyVisibleId,
- emptyIdSet, unionIdSets, mkIdSet,
- unitIdSet, elementOfIdSet,
- addOneToIdSet, SYN_IE(IdSet),
- nullIdEnv, unitIdEnv, combineIdEnvs,
- delOneFromIdEnv, delManyFromIdEnv,
- mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
- GenId{-instance Eq-}
+import CoreFVs ( idRuleVars )
+import CoreUtils ( exprIsTrivial, isDefaultAlt )
+import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
+ idOccInfo, setIdOccInfo, isLocalId,
+ isExportedId, idArity, idSpecialisation,
+ idType, idUnique, Id
)
-import Maybes ( maybeToBool )
-import Outputable ( Outputable(..){-instance * (,) -} )
-import PprCore
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-import Pretty ( ppAboves )
-import TyVar ( GenTyVar{-instance Eq-} )
-import Unique ( Unique{-instance Eq-} )
-import Util ( assoc, zipEqual, pprTrace, panic )
-
-isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
-\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
- IdSet -- Candidates
-
-addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv kd ks kc ip cands) ids
- = OccEnv kd ks kc ip (cands `unionIdSets` mkIdSet ids)
-
-addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv ks kd kc ip cands) id
- = OccEnv kd ks kc ip (addOneToIdSet cands id)
-
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfIdSet` cands
-
-ignoreINLINEPragma :: OccEnv -> Bool
-ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
-
-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
- = 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
- = (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
- = (usage `delOneFromIdEnv` binder,
- (binder, usage_of usage binder)
- )
-
-usage_of usage binder
- | externallyVisibleId 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
+import IdInfo ( isEmptySpecInfo )
+import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
+
+import VarSet
+import VarEnv
+
+import Type ( isFunTy, dropForAlls )
+import Maybes ( orElse )
+import Digraph ( stronglyConnCompR, SCC(..) )
+import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
+import Unique ( Unique )
+import UniqFM ( keysUFM )
+import Util ( zipWithEqual, mapAndUnzip )
+import Outputable
\end{code}
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:"
- (ppAboves (map (ppr PprDebug) binds'))
- binds'
- | otherwise = binds'
+occurAnalysePgm :: [CoreBind] -> [CoreBind]
+occurAnalysePgm binds
+ = snd (go initOccEnv binds)
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)
- emptyIdSet
-
- 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
+ go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
+ go env []
+ = (emptyDetails, [])
+ go env (bind:binds)
+ = (final_usage, bind' ++ binds')
+ where
+ (bs_usage, binds') = go env binds
+ (final_usage, bind') = occAnalBind env bind bs_usage
+
+occurAnalyseExpr :: CoreExpr -> CoreExpr
+ -- Do occurrence analysis, and discard occurence info returned
+occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
\end{code}
-\begin{code}
-occurAnalyseExpr :: IdSet -- Set of interesting free vars
- -> CoreExpr
- -> (IdEnv BinderInfo, -- Occ info for interesting free vars
- SimplifiableCoreExpr)
-
-occurAnalyseExpr candidates 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
-
-occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
-occurAnalyseGlobalExpr expr
- = -- Top level expr, so no interesting free vars, and
- -- discard occurence info returned
- snd (occurAnalyseExpr emptyIdSet expr)
-\end{code}
%************************************************************************
%* *
~~~~~~~~
\begin{code}
+type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached
+
+type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
+ -- which is gotten from the Id.
+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
- = (body_usage, [])
-
where
- (rhs_usage, rhs') = occAnalRhs env binder rhs
(final_body_usage, tagged_binder) = tagBinder body_usage binder
+ (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
\end{code}
Dropping dead code for recursive bindings is done in a very simple way:
\begin{code}
occAnalBind env (Rec pairs) body_usage
- = foldr do_final_bind (body_usage, []) sccs
+ = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
where
+ analysed_pairs :: [Details1]
+ analysed_pairs = [ (bndr, rhs_usage, rhs')
+ | (bndr, rhs) <- pairs,
+ let (rhs_usage, rhs') = occAnalRhs env bndr rhs
+ ]
- (binders, rhss) = unzip pairs
- new_env = env `addNewCands` binders
+ sccs :: [SCC (Node Details1)]
+ sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
- 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
+ ---- stuff for dependency analysis of binds -------------------------------
+ edges :: [Node Details1]
+ edges = _scc_ "occAnalBind.assoc"
+ [ (details, idUnique id, edges_from rhs_usage)
+ | details@(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 (lookupVarEnv rhs_usage bndr)]
+ -- which has n**2 cost, and this meant that edges_from alone
+ -- consumed 10% of total runtime!
+ edges_from :: UsageDetails -> [Unique]
+ edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
+ keysUFM rhs_usage
+ ---- stuff to "re-constitute" bindings from dependency-analysis info ------
- ---- stuff for dependency analysis of binds -------------------------------
+ -- Non-recursive SCC
+ 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
+ new_bind = NonRec tagged_bndr rhs'
+
+ -- Recursive SCC
+ do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
+ | 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
+ 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}
- edges :: [(Id,Id)] -- (a,b) means a mentions b
- edges = concat [ edges_from binder rhs_usage
- | (binder, (rhs_usage, _)) <- analysed_pairs]
+@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
- edges_from :: Id -> UsageDetails -> [(Id,Id)]
- edges_from id its_rhs_usage
- = [(id,mentioned) | mentioned <- binders,
- maybeToBool (lookupIdEnv its_rhs_usage mentioned)
- ]
+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.
- sccs :: [[Id]]
- sccs = case binders of
- [_] -> [binders] -- Singleton; no need to analyse
- other -> stronglyConnComp (==) edges binders
+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.
- ---- stuff to "re-constitute" bindings from dependency-analysis info ------
+==============
+[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.]
- do_final_bind sCC@[binder] (body_usage, binds_so_far)
- | isNeeded env body_usage binder
- = (combined_usage, new_bind:binds_so_far)
+Here's a case that bit me:
- | otherwise -- Dead
- = (body_usage, binds_so_far)
- 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 = Rec [(tagged_binder,rhs')]
- | otherwise = NonRec 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)
- where
- (rhs_usages, rhss') = unzip (map lookup sCC)
- total_usage = foldr combineUsageDetails body_usage rhs_usages
- (combined_usage, tagged_binders) = tagBinders total_usage sCC
+ 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!
- new_bind = Rec (zipEqual "occAnalBind" tagged_binders rhss')
+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 (bind, _, _)) = [bind]
+
+ -- Common case of simple self-recursion
+reOrderRec env (CyclicSCC [bind])
+ = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+ where
+ ((tagged_bndr, rhs), _, _) = bind
+
+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))
+ ++
+ [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+
+ where
+ (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
+ (tagged_bndr, rhs) = chosen_pair
+
+ -- 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
+
+ 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
+
+ | 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 = 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 (isEmptySpecInfo (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
+ inlineCandidate id (Note InlineMe _) = True
+ inlineCandidate id rhs = isOneOcc (idOccInfo id)
+
+ -- 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".
+
+ not_fun_ty ty = not (isFunTy (dropForAlls ty))
\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.
+[June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
+
+
\begin{code}
occAnalRhs :: OccEnv
- -> Id -- Binder
- -> CoreExpr -- Rhs
- -> (UsageDetails, SimplifiableCoreExpr)
+ -> Id -> CoreExpr -- Binder and rhs
+ -- For non-recs the binder is alrady tagged
+ -- with occurrence info
+ -> (UsageDetails, CoreExpr)
occAnalRhs env id rhs
- | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
- = (mapIdEnv markMany rhs_usage, rhs')
-
- | otherwise
- = (rhs_usage, rhs')
-
+ = (final_usage, rhs')
+ where
+ (rhs_usage, rhs') = occAnal ctxt rhs
+ ctxt | certainly_inline id = env
+ | otherwise = rhsCtxt
+ -- Note that we generally use an rhsCtxt. This tells the occ anal n
+ -- that it's looking at an RHS, which has an effect in occAnalApp
+ --
+ -- But there's a problem. Consider
+ -- x1 = a0 : []
+ -- x2 = a1 : x1
+ -- x3 = a2 : x2
+ -- g = f x3
+ -- First time round, it looks as if x1 and x2 occur as an arg of a
+ -- let-bound constructor ==> give them a many-occurrence.
+ -- But then x3 is inlined (unconditionally as it happens) and
+ -- next time round, x2 will be, and the next time round x1 will be
+ -- Result: multiple simplifier iterations. Sigh.
+ -- Crude solution: use rhsCtxt for things that occur just once...
+
+ certainly_inline id = case idOccInfo id of
+ OneOcc in_lam one_br _ -> not in_lam && one_br
+ other -> False
+
+ -- [March 98] A new wrinkle is that if the binder has specialisations inside
+ -- it then we count the specialised Ids as "extra rhs's". That way
+ -- the "parent" keeps the specialised "children" alive. If the parent
+ -- dies (because it isn't referenced any more), then the children will
+ -- die too unless they are already referenced directly.
+
+ final_usage = addRuleUsage rhs_usage id
+
+addRuleUsage :: UsageDetails -> Id -> UsageDetails
+-- Add the usage from RULES in Id to the usage
+addRuleUsage usage id
+ = foldVarSet add usage (idRuleVars id)
where
- (rhs_usage, rhs') = occAnal env rhs
+ 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}
Expressions
occAnal :: OccEnv
-> CoreExpr
-> (UsageDetails, -- Gives info only about the "interesting" Ids
- SimplifiableCoreExpr)
+ CoreExpr)
+
+occAnal env (Type t) = (emptyDetails, Type t)
+occAnal env (Var v) = (mkOneOcc env v False, Var v)
+ -- At one stage, I gathered the idRuleVars for v here too,
+ -- which in a way is the right thing to do.
+ -- Btu that went wrong right after specialisation, when
+ -- the *occurrences* of the overloaded function didn't have any
+ -- rules in them, so the *specialised* versions looked as if they
+ -- weren't used at all.
+\end{code}
-occAnal env (Var v)
- | isCandidate env v
- = (unitIdEnv v (funOccurrence 0), Var v)
+We regard variables that occur as constructor arguments as "dangerousToDup":
- | otherwise
- = (emptyDetails, Var v)
+\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}
-occAnal env (Lit lit) = (emptyDetails, Lit lit)
-occAnal env (Con con args) = (occAnalArgs env args, Con con args)
-occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
-occAnal env (SCC cc body)
- = (mapIdEnv markInsideSCC usage, SCC cc body')
- where
- (usage, body') = occAnal env body
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
-occAnal env (Coerce c ty body)
- = (usage, Coerce c ty body')
- where
- (usage, body') = occAnal env body
+\begin{code}
+occAnal env expr@(Lit lit) = (emptyDetails, expr)
+\end{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
+\begin{code}
+occAnal env (Note InlineMe body)
+ = case occAnal env body of { (usage, body') ->
+ (mapVarEnv markMany usage, Note InlineMe body')
+ }
+
+occAnal env (Note note@(SCC cc) body)
+ = case occAnal env body of { (usage, body') ->
+ (mapVarEnv markInsideSCC usage, Note note body')
+ }
+
+occAnal env (Note note body)
+ = case occAnal env body of { (usage, body') ->
+ (usage, Note note body')
+ }
+\end{code}
-occAnal env (Lam (ValBinder binder) body)
- = (mapIdEnv markDangerousToDup final_usage,
- Lam (ValBinder tagged_binder) body')
+\begin{code}
+occAnal env app@(App fun arg)
+ = occAnalApp env (collectArgs app) False
+
+-- 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 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_body body of { (body_usage, body') ->
+ let
+ (final_usage, tagged_binders) = tagBinders body_usage binders
+ -- URGH! Sept 99: we don't seem to be able to use binders' here, because
+ -- we get linear-typed things in the resulting program that we can't handle yet.
+ -- (e.g. PrelShow) TODO
+
+ really_final_usage = if linear then
+ final_usage
+ else
+ mapVarEnv markInsideLam final_usage
+ in
+ (really_final_usage,
+ mkLams tagged_binders body') }
where
- (body_usage, body') = occAnal (env `addNewCand` binder) body
- (final_usage, tagged_binder) = tagBinder body_usage binder
-
--- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
-occAnal env (Lam (TyBinder tyvar) body)
- = (mapIdEnv markDangerousToDup body_usage,
- Lam (TyBinder tyvar) body')
+ env_body = vanillaCtxt -- Body is (no longer) an RhsContext
+ (binders, body) = collectBinders expr
+ binders' = oneShotGroup env binders
+ linear = all is_one_shot binders'
+ is_one_shot b = isId b && isOneShotBndr b
+
+occAnal env (Case scrut bndr ty alts)
+ = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
+ case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts') ->
+ let
+ alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
+ alts_usage' = addCaseBndrUsage alts_usage
+ (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 ty alts') }}
where
- (body_usage, body') = occAnal env body
+ -- The case binder gets a usage of either "many" or "dead", never "one".
+ -- Reason: we like to inline single occurrences, to eliminate a binding,
+ -- but inlining a case binder *doesn't* eliminate a binding.
+ -- We *don't* want to transform
+ -- case x of w { (p,q) -> f w }
+ -- into
+ -- case x of w { (p,q) -> f (p,q) }
+ addCaseBndrUsage usage = case lookupVarEnv usage bndr of
+ Nothing -> usage
+ Just occ -> extendVarEnv usage bndr (markMany occ)
+
+ occ_anal_scrut (Var v) (alt1 : other_alts)
+ | not (null other_alts) || not (isDefaultAlt alt1)
+ = (mkOneOcc env v True, Var v)
+ occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut
+ -- No need for rhsCtxt
-occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
+occAnal env (Let bind body)
+ = case occAnal env body of { (body_usage, body') ->
+ case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
+ (final_usage, mkLets new_binds body') }}
-occAnal env (Case scrut alts)
- = (scrut_usage `combineUsageDetails` alts_usage,
- Case scrut' alts')
+occAnalArgs env args
+ = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
+ (foldr combineUsageDetails emptyDetails arg_uds_s, args')}
where
- (scrut_usage, scrut') = occAnal env scrut
- (alts_usage, alts') = occAnalAlts env alts
+ arg_env = vanillaCtxt
+\end{code}
-occAnal env (Let bind body)
- = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
+Applications are dealt with specially because we want
+the "build hack" to work.
+
+\begin{code}
+-- Hack for build, fold, runST
+occAnalApp env (Var fun, args) is_rhs
+ = case args_stuff of { (args_uds, args') ->
+ let
+ -- We mark the free vars of the argument of a constructor or PAP
+ -- as "many", if it is the RHS of a let(rec).
+ -- 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.
+ --
+ -- This is the *whole point* of the isRhsEnv predicate
+ final_args_uds
+ | isRhsEnv env,
+ isDataConWorkId fun || valArgCount args < idArity fun
+ = mapVarEnv markMany args_uds
+ | otherwise = args_uds
+ in
+ (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
+ where
+ fun_uniq = idUnique fun
+ fun_uds = mkOneOcc env fun (valArgCount args > 0)
+ args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
+ | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
+ | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
+ | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
+ -- (foldr k z xs) may call k many times, but it never
+ -- shares a partial application of k; hence [False,True]
+ -- This means we can optimise
+ -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
+ -- by floating in the v
+
+ | otherwise = occAnalArgs env args
+
+
+occAnalApp env (fun, args) is_rhs
+ = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
+ -- The addAppCtxt is a bit cunning. One iteration of the simplifier
+ -- often leaves behind beta redexs like
+ -- (\x y -> e) a1 a2
+ -- Here we would like to mark x,y as one-shot, and treat the whole
+ -- thing much like a let. We do this by pushing some True items
+ -- onto the context stack.
+
+ case occAnalArgs env args of { (args_uds, args') ->
+ let
+ final_uds = fun_uds `combineUsageDetails` args_uds
+ in
+ (final_uds, mkApps fun' args') }}
+
+appSpecial :: OccEnv
+ -> Int -> CtxtTy -- Argument number, and context to use for it
+ -> [CoreExpr]
+ -> (UsageDetails, [CoreExpr])
+appSpecial env n ctxt args
+ = go n args
where
- new_env = env `addNewCands` (bindersOf bind)
- (body_usage, body') = occAnal new_env body
- (final_usage, new_binds) = occAnalBind env bind body_usage
+ arg_env = vanillaCtxt
+
+ go n [] = (emptyDetails, []) -- Too few args
+
+ go 1 (arg:args) -- The magic arg
+ = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
+ case occAnalArgs env args of { (args_uds, args') ->
+ (combineUsageDetails arg_uds args_uds, arg':args') }}
+
+ go n (arg:args)
+ = case occAnal arg_env arg of { (arg_uds, arg') ->
+ case go (n-1) args of { (args_uds, args') ->
+ (combineUsageDetails arg_uds args_uds, arg':args') }}
\end{code}
+
Case alternatives
~~~~~~~~~~~~~~~~~
+If the case binder occurs at all, the other binders effectively do too.
+For example
+ case e of x { (a,b) -> rhs }
+is rather like
+ let x = (a,b) in rhs
+If e turns out to be (e1,e2) we indeed get something like
+ let a = e1; b = e2; x = (a,b) in rhs
+
\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 case_bndr (con, bndrs, rhs)
+ = case occAnal env rhs of { (rhs_usage, rhs') ->
+ let
+ (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
+ final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
+ | otherwise = tagged_bndrs
+ -- Leave the binders untagged if the case
+ -- binder occurs at all; see note above
+ in
+ (final_usage, (con, final_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')
+
+%************************************************************************
+%* *
+\subsection[OccurAnal-types]{OccEnv}
+%* *
+%************************************************************************
+
+\begin{code}
+data OccEnv
+ = OccEnv OccEncl -- Enclosing context information
+ CtxtTy -- Tells about linearity
+
+-- OccEncl is used to control whether to inline into constructor arguments
+-- For example:
+-- x = (p,q) -- Don't inline p or q
+-- y = /\a -> (p a, q a) -- Still don't inline p or q
+-- z = f (p,q) -- Do inline p,q; it may make a rule fire
+-- So OccEncl tells enought about the context to know what to do when
+-- we encounter a contructor application or PAP.
+
+data OccEncl
+ = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
+ -- Don't inline into constructor args here
+ | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
+ -- Do inline into constructor args here
+
+type CtxtTy = [Bool]
+ -- [] No info
+ --
+ -- True:ctxt Analysing a function-valued expression that will be
+ -- applied just once
+ --
+ -- False:ctxt Analysing a function-valued expression that may
+ -- be applied many times; but when it is,
+ -- the CtxtTy inside applies
+
+initOccEnv :: OccEnv
+initOccEnv = OccEnv OccRhs []
+
+vanillaCtxt = OccEnv OccVanilla []
+rhsCtxt = OccEnv OccRhs []
+
+isRhsEnv (OccEnv OccRhs _) = True
+isRhsEnv (OccEnv OccVanilla _) = False
+
+setCtxt :: OccEnv -> CtxtTy -> OccEnv
+setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
+
+oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
+ -- The result binders have one-shot-ness set that they might not have had originally.
+ -- This happens in (build (\cn -> e)). Here the occurrence analyser
+ -- linearity context knows that c,n are one-shot, and it records that fact in
+ -- the binder. This is useful to guide subsequent float-in/float-out tranformations
+
+oneShotGroup (OccEnv encl ctxt) bndrs
+ = go ctxt bndrs []
where
- (alts_usage, alts') = unzip (map do_alt alts)
- (deflt_usage, deflt') = occAnalDeflt env deflt
+ go ctxt [] rev_bndrs = reverse rev_bndrs
- do_alt (lit, rhs)
- = (rhs_usage, (lit, rhs'))
- where
- (rhs_usage, rhs') = occAnal env rhs
+ go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
+ | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
+ where
+ bndr' | lin_ctxt = setOneShotLambda bndr
+ | otherwise = bndr
-occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
+ go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
-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
+addAppCtxt (OccEnv encl ctxt) args
+ = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
\end{code}
+%************************************************************************
+%* *
+\subsection[OccurAnal-types]{OccEnv}
+%* *
+%************************************************************************
-Atoms
-~~~~~
\begin{code}
-occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
+type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
+
+combineUsageDetails, combineAltsUsageDetails
+ :: UsageDetails -> UsageDetails -> UsageDetails
+
+combineUsageDetails usage1 usage2
+ = plusVarEnv_C addOccInfo usage1 usage2
+
+combineAltsUsageDetails usage1 usage2
+ = plusVarEnv_C orOccInfo usage1 usage2
+
+addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
+addOneOcc usage id info
+ = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
+ -- ToDo: make this more efficient
+
+emptyDetails = (emptyVarEnv :: UsageDetails)
-occAnalArgs env atoms
- = foldr do_one_atom emptyDetails atoms
+usedIn :: Id -> UsageDetails -> Bool
+v `usedIn` details = isExportedId v || v `elemVarEnv` details
+
+tagBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ [IdWithOccInfo]) -- Tagged binders
+
+tagBinders usage binders
+ = let
+ usage' = usage `delVarEnvList` binders
+ uss = map (setBinderOcc 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' = setBinderOcc usage binder
+ in
+ usage' `seq` (usage', binder')
+
+setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
+setBinderOcc usage bndr
+ | isTyVar bndr = bndr
+ | 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
where
- do_one_atom (VarArg v) usage
- | isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
- do_one_atom other_arg usage = usage
+ occ_info = lookupVarEnv usage bndr `orElse` IAmDead
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Operations over OccInfo}
+%* *
+%************************************************************************
+
+\begin{code}
+mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
+mkOneOcc env id int_cxt
+ | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
+ | otherwise = emptyDetails
+
+markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
+
+markMany IAmDead = IAmDead
+markMany other = NoOccInfo
+
+markInsideSCC occ = markMany occ
+
+markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
+markInsideLam occ = occ
+
+addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
+
+addOccInfo IAmDead info2 = info2
+addOccInfo info1 IAmDead = info1
+addOccInfo info1 info2 = NoOccInfo
+-- (orOccInfo orig new) is used
+-- when combining occurrence info from branches of a case
-occAnalArg :: OccEnv -> CoreArg -> UsageDetails
+orOccInfo IAmDead info2 = info2
+orOccInfo info1 IAmDead = info1
+orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
+ (OneOcc in_lam2 one_branch2 int_cxt2)
+ = OneOcc (in_lam1 || in_lam2)
+ False -- False, because it occurs in both branches
+ (int_cxt1 && int_cxt2)
-occAnalArg env (VarArg v)
- | isCandidate env v = unitDetails v (argOccurrence 0)
- | otherwise = emptyDetails
-occAnalArg _ _ = emptyDetails
+orOccInfo info1 info2 = NoOccInfo
\end{code}