% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
-%* *
+%* *
\section[OccurAnal]{Occurrence analysis pass}
-%* *
+%* *
%************************************************************************
The occurrence analyser re-typechecks a core expression, returning a new
\begin{code}
module OccurAnal (
- occurAnalysePgm, occurAnalyseExpr
+ occurAnalysePgm, occurAnalyseExpr
) where
#include "HsVersions.h"
import CoreSyn
-import CoreFVs ( idRuleVars )
-import CoreUtils ( exprIsTrivial, isDefaultAlt )
-import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
- idOccInfo, setIdOccInfo, isLocalId,
- isExportedId, idArity, idHasRules,
- idType, idUnique, Id
- )
-import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
+import CoreFVs
+import CoreUtils ( exprIsTrivial, isDefaultAlt )
+import Id
+import IdInfo
+import BasicTypes
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, lookupUFM_Directly )
-import Util ( zipWithEqual, mapAndUnzip )
+import Maybes ( orElse )
+import Digraph ( stronglyConnCompR, SCC(..) )
+import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
+import Unique ( Unique )
+import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
+import Util ( mapAndUnzip )
import Outputable
+
+import Data.List
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
+%* *
%************************************************************************
Here's the externally-callable interface:
= snd (go initOccEnv binds)
where
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
+ go _ []
+ = (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
+ -- Do occurrence analysis, and discard occurence info returned
occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
+%* *
%************************************************************************
Bindings
~~~~~~~~
\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
- -> CoreBind
- -> UsageDetails -- Usage details of scope
- -> (UsageDetails, -- Of the whole let(rec)
- [CoreBind])
+ -> CoreBind
+ -> UsageDetails -- Usage details of scope
+ -> (UsageDetails, -- Of the whole let(rec)
+ [CoreBind])
occAnalBind env (NonRec binder rhs) body_usage
- | not (binder `usedIn` body_usage) -- It's not mentioned
+ | not (binder `usedIn` body_usage) -- It's not mentioned
= (body_usage, [])
- | otherwise -- It's mentioned in the body
- = (final_body_usage `combineUsageDetails` rhs_usage,
+ | otherwise -- It's mentioned in the body
+ = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
[NonRec tagged_binder rhs'])
-
where
- (final_body_usage, tagged_binder) = tagBinder body_usage binder
- (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
+ (body_usage', tagged_binder) = tagBinder body_usage binder
+ (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
\end{code}
+Note [Dead code]
+~~~~~~~~~~~~~~~~
Dropping dead code for recursive bindings is done in a very simple way:
- the entire set of bindings is dropped if none of its binders are
- mentioned in its body; otherwise none are.
+ the entire set of bindings is dropped if none of its binders are
+ mentioned in its body; otherwise none are.
This seems to miss an obvious improvement.
-@
- letrec f = ...g...
- g = ...f...
- in
- ...g...
+ letrec f = ...g...
+ g = ...f...
+ in
+ ...g...
===>
+ letrec f = ...g...
+ g = ...(...g...)...
+ in
+ ...g...
+
+Now 'f' is unused! But it's OK! Dependency analysis will sort this
+out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
+dropped. It isn't easy to do a perfect job in one blow. Consider
+
+ letrec f = ...g...
+ g = ...h...
+ h = ...k...
+ k = ...m...
+ m = ...m...
+ in
+ ...m...
+
+
+Note [Loop breaking and RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Loop breaking is surprisingly subtle. First read the section 4 of
+"Secrets of the GHC inliner". This describes our basic plan.
+
+However things are made quite a bit more complicated by RULES. Remember
+
+ * Note [Rules are extra RHSs]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ A RULE for 'f' is like an extra RHS for 'f'. 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).
+
+ To that end, we build a Rec group for each cyclic strongly
+ connected component,
+ *treating f's rules as extra RHSs for 'f'*.
+
+ When we make the Rec groups we include variables free in *either*
+ LHS *or* RHS of the rule. The former might seems silly, but see
+ Note [Rule dependency info].
+
+ So in Example [eftInt], eftInt and eftIntFB will be put in the
+ same Rec, even though their 'main' RHSs are both non-recursive.
+
+ * Note [Rules are visible in their own rec group]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ We want the rules for 'f' to be visible in f's right-hand side.
+ And we'd like them to be visible in other functions in f's Rec
+ group. E.g. in Example [Specialisation rules] we want f' rule
+ to be visible in both f's RHS, and fs's RHS.
+
+ This means that we must simplify the RULEs first, before looking
+ at any of the definitions. This is done by Simplify.simplRecBind,
+ when it calls addLetIdInfo.
+
+ * Note [Choosing loop breakers]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ We avoid infinite inlinings by choosing loop breakers, and
+ ensuring that a loop breaker cuts each loop. But what is a
+ "loop"? In particular, a RULES is like an equation for 'f' that
+ is *always* inlined if it are applicable. We do *not* disable
+ rules for loop-breakers. It's up to whoever makes the rules to
+ make sure that the rules themselves alwasys terminate. See Note
+ [Rules for recursive functions] in Simplify.lhs
+
+ Hence, if
+ f's RHS mentions g, and
+ g has a RULE that mentions h, and
+ h has a RULE that mentions f
+
+ then we *must* choose f to be a loop breaker. In general, take the
+ free variables of f's RHS, and augment it with all the variables
+ reachable by RULES from those starting points. That is the whole
+ reason for computing rule_fv_env in occAnalBind. (Of course we
+ only consider free vars that are also binders in this Rec group.)
+
+ Note that when we compute this rule_fv_env, we only consider variables
+ free in the *RHS* of the rule, in contrast to the way we build the
+ Rec group in the first place (Note [Rule dependency info])
+
+ Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
+ chosen as a loop breaker, because their RHSs don't mention each other.
+ And indeed both can be inlined safely.
+
+ Note that the edges of the graph we use for computing loop breakers
+ are not the same as the edges we use for computing the Rec blocks.
+ That's why we compute
+ rec_edges for the Rec block analysis
+ loop_breaker_edges for the loop breaker analysis
+
+
+ * Note [Weak loop breakers]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~
+ There is a last nasty wrinkle. Suppose we have
+
+ Rec { f = f_rhs
+ RULE f [] = g
+
+ h = h_rhs
+ g = h
+ ...more...
+ }
+
+ Remmber that we simplify the RULES before any RHS (see Note
+ [Rules are visible in their own rec group] above).
+
+ So we must *not* postInlineUnconditionally 'g', even though
+ its RHS turns out to be trivial. (I'm assuming that 'g' is
+ not choosen as a loop breaker.)
+
+ We "solve" this by making g a "weak" or "rules-only" loop breaker,
+ with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
+ has IAmLoopBreaker False. So
+
+ Inline postInlineUnconditinoally
+ IAmLoopBreaker False no no
+ IAmLoopBreaker True yes no
+ other yes yes
+
+ The **sole** reason for this kind of loop breaker is so that
+ postInlineUnconditionally does not fire. Ugh.
+
+ * Note [Rule dependency info]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ The VarSet in a SpecInfo is used for dependency analysis in the
+ occurrence analyser. We must track free vars in *both* lhs and rhs. Why both?
+ Consider
+ x = y
+ RULE f x = 4
+ Then if we substitute y for x, we'd better do so in the
+ rule's LHS too, so we'd better ensure the dependency is respected
+
- letrec f = ...g...
- g = ...(...g...)...
- in
- ...g...
-@
+Example [eftInt]
+~~~~~~~~~~~~~~~
+Example (from GHC.Enum):
-Now @f@ is unused. But dependency analysis will sort this out into a
-@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
-It isn't easy to do a perfect job in one blow. Consider
+ eftInt :: Int# -> Int# -> [Int]
+ eftInt x y = ...(non-recursive)...
+
+ {-# INLINE [0] eftIntFB #-}
+ eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
+ eftIntFB c n x y = ...(non-recursive)...
+
+ {-# RULES
+ "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
+ "eftIntList" [1] eftIntFB (:) [] = eftInt
+ #-}
-@
- letrec f = ...g...
- g = ...h...
- h = ...k...
- k = ...m...
- m = ...m...
- in
- ...m...
-@
+Example [Specialisation rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this group, which is typical of what SpecConstr builds:
+
+ fs a = ....f (C a)....
+ f x = ....f (C a)....
+ {-# RULE f (C a) = fs a #-}
+
+So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
+
+But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
+ - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
+ - fs is inlined (say it's small)
+ - now there's another opportunity to apply the RULE
+
+This showed up when compiling Control.Concurrent.Chan.getChanContents.
\begin{code}
occAnalBind env (Rec pairs) body_usage
- = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
+ = foldr occAnalRec (body_usage, []) sccs
+ -- For a recursive group, we
+ -- * occ-analyse all the RHSs
+ -- * compute strongly-connected components
+ -- * feed those components to occAnalRec
where
- analysed_pairs :: [Details1]
- analysed_pairs = [ (bndr, rhs_usage, rhs')
- | (bndr, rhs) <- pairs,
- let (rhs_usage, rhs') = occAnalRhs 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"
- [ (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 ------
-
- -- 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)
+ -------------Dependency analysis ------------------------------
+ bndr_set = mkVarSet (map fst pairs)
+
+ sccs :: [SCC (Node Details)]
+ sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges
+
+ rec_edges :: [Node Details]
+ rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
+
+ make_node (bndr, rhs)
+ = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
+ where
+ (rhs_usage, rhs') = occAnalRhs env bndr rhs
+ rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
+ out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
+ -- (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!
+
+-----------------------------
+occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
+ -> (UsageDetails, [CoreBind])
+
+ -- The NonRec case is just like a Let (NonRec ...) above
+occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
+ | not (bndr `usedIn` body_usage)
+ = (body_usage, binds)
+
+ | otherwise -- It's mentioned in the body
+ = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs]
+ NonRec tagged_bndr rhs : binds)
+ where
+ (body_usage', tagged_bndr) = tagBinder body_usage bndr
+
+
+ -- The Rec case is the interesting one
+ -- See Note [Loop breaking]
+occAnalRec (CyclicSCC nodes) (body_usage, binds)
+ | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
+ = (body_usage, binds) -- Dead code
+
+ | otherwise -- At this point we always build a single Rec
+ = (final_usage, Rec pairs : binds)
+
+ where
+ bndrs = [b | (ND b _ _ _, _, _) <- nodes]
+ bndr_set = mkVarSet bndrs
+
+ ----------------------------
+ -- Tag the binders with their occurrence info
+ total_usage = foldl add_usage body_usage nodes
+ add_usage body_usage (ND bndr _ rhs_usage _, _, _)
+ = body_usage +++ addRuleUsage rhs_usage bndr
+ (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
+
+ tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
+ -- (a) Tag the binders in the details with occ info
+ -- (b) Mark the binder with "weak loop-breaker" OccInfo
+ -- saying "no preInlineUnconditionally" if it is used
+ -- in any rule (lhs or rhs) of the recursive group
+ -- See Note [Weak loop breakers]
+ tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
+ = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
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 (doReorder edges)
-
- -- Hopefully 'bndrs' is a relatively small group now
- -- Now get ready for the loop-breaking phase, this time ignoring RulesOnly references
- -- We've done dead-code elimination already, so no worries about un-referenced binders
- edges :: [Node Details2]
- edges = zipWithEqual "reorder" mk_edge tagged_bndrs details
- keys = map idUnique bndrs
- mk_edge tagged_bndr (_, rhs_usage, rhs')
- = ((tagged_bndr, rhs'), idUnique tagged_bndr, used)
- where
- used = [key | key <- keys, used_outside_rule rhs_usage key ]
-
- used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of
- Nothing -> False
- Just RulesOnly -> False -- Ignore rules
- other -> True
+ bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
+ | otherwise = bndr1
+ bndr1 = setBinderOcc usage bndr
+ all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
+ emptyVarSet bndrs
+
+ ----------------------------
+ -- Now reconstruct the cycle
+ pairs | no_rules = reOrderCycle tagged_nodes
+ | otherwise = concatMap reOrderRec (stronglyConnCompR loop_breaker_edges)
+
+ -- See Note [Choosing loop breakers] for looop_breaker_edges
+ loop_breaker_edges = map mk_node tagged_nodes
+ mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
+ where
+ new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
+
+ ------------------------------------
+ rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
+ -- Domain is *subset* of bound vars (others have no rule fvs)
+ rule_fv_env = rule_loop init_rule_fvs
+
+ no_rules = null init_rule_fvs
+ init_rule_fvs = [(b, rule_fvs)
+ | b <- bndrs
+ , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
+ , not (isEmptyVarSet rule_fvs)]
+
+ rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
+ rule_loop fv_list
+ | no_change = env
+ | otherwise = rule_loop new_fv_list
+ where
+ env = mkVarEnv init_rule_fvs
+ (no_change, new_fv_list) = mapAccumL bump True fv_list
+ bump no_change (b,fvs)
+ | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
+ | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
+ where
+ new_fvs = extendFvs env emptyVarSet fvs
+
+idRuleRhsVars :: Id -> VarSet
+-- Just the variables free on the *rhs* of a rule
+-- See Note [Choosing loop breakers]
+idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
+
+extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
+-- (extendFVs env fvs s) returns (fvs `union` env(s))
+extendFvs env fvs id_set
+ = foldUFM_Directly add fvs id_set
+ where
+ add uniq _ fvs
+ = case lookupVarEnv_Directly env uniq of
+ Just fvs' -> fvs' `unionVarSet` fvs
+ Nothing -> fvs
\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
+same pairs, but
+ a) in a better order,
+ b) with some of the Ids having a IAmALoopBreaker pragma
-The "no-inline" Ids are sufficient to break all cycles in the SCC. This means
+The "loop-breaker" 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.
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.]
+[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 = b
- b = \x. BIG
- in
- ...a...a...a....
+ 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.
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 ...
+\begin{code}
+type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
+ -- which is gotten from the Id.
+data Details = ND Id -- Binder
+ CoreExpr -- RHS
+ UsageDetails -- Full usage from RHS (*not* including rules)
+ IdSet -- Other binders from this Rec group mentioned on RHS
+ -- (derivable from UsageDetails but cached here)
+
+reOrderRec :: SCC (Node Details)
+ -> [(Id,CoreExpr)]
+-- Sorted into a plausible order. Enough of the Ids have
+-- IAmALoopBreaker pragmas that there are no loops left.
+reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)]
+reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
+
+reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
+reOrderCycle []
+ = panic "reOrderCycle"
+reOrderCycle [bind] -- Common case of simple self-recursion
+ = [(makeLoopBreaker False bndr, rhs)]
+ where
+ (ND bndr rhs _ _, _, _) = bind
+
+reOrderCycle (bind : binds)
+ = -- Choose a loop breaker, mark it no-inline,
+ -- do SCC analysis on the rest, and recursively sort them out
+ concatMap reOrderRec (stronglyConnCompR unchosen) ++
+ [(makeLoopBreaker False bndr, rhs)]
+
+ where
+ (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
+ ND bndr rhs _ _ = chosen_bind
- in
- let n = f y
- in
- case n of { ... }
+ -- 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
-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!
+ 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
-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.
+ | otherwise -- No lower so don't pick it
+ = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
+ where
+ sc = score bind
+ score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
+ score (ND bndr rhs _ _, _, _)
+ | workerExists (idWorkerInfo bndr) = 10
+ -- Note [Worker inline loop]
-\begin{code}
-doReorder :: [Node Details2] -> [Details2]
--- Sorted into a plausible order. Enough of the Ids have
--- dontINLINE pragmas that there are no loops left.
-doReorder nodes = concatMap reOrderRec (stronglyConnCompR nodes)
+ | 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
-reOrderRec :: SCC (Node Details2) -> [Details2]
+ | is_con_app rhs = 2 -- Data types help with cases
+ -- Note [conapp]
- -- Non-recursive case
-reOrderRec (AcyclicSCC (bind, _, _)) = [bind]
+-- If an Id is marked "never inline" then it makes a great loop breaker
+-- The only reason for not checking that here is that it is rare
+-- and I've never seen a situation where it makes a difference,
+-- so it probably isn't worth the time to test on every binder
+-- | isNeverActive (idInlinePragma bndr) = -10
- -- Common case of simple self-recursion
-reOrderRec (CyclicSCC [])
- = panic "reOrderRec"
+ | inlineCandidate bndr rhs = 1 -- Likely to be inlined
+ -- Note [Inline candidates]
-reOrderRec (CyclicSCC [bind])
- = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
- where
- ((tagged_bndr, rhs), _, _) = bind
+ | otherwise = 0
-reOrderRec (CyclicSCC (bind : binds))
- = -- Choose a loop breaker, mark it no-inline,
- -- do SCC analysis on the rest, and recursively sort them out
- doReorder unchosen ++
- [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+ inlineCandidate :: Id -> CoreExpr -> Bool
+ inlineCandidate _ (Note InlineMe _) = True
+ inlineCandidate id _ = isOneOcc (idOccInfo id)
+
+ -- Note [conapp]
+ --
+ -- It's really really important to inline dictionaries. Real
+ -- example (the Enum Ordering instance from GHC.Base):
+ --
+ -- 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".
+ -- Inlining dictionaries is really essential to unravelling
+ -- the loops in static numeric dictionaries, see GHC.Float.
+
+ -- Cheap and cheerful; the simplifer moves casts out of the way
+ -- The lambda case is important to spot x = /\a. C (f a)
+ -- which comes up when C is a dictionary constructor and
+ -- f is a default method.
+ -- Example: the instance for Show (ST s a) in GHC.ST
+ --
+ -- However we *also* treat (\x. C p q) as a con-app-like thing,
+ -- Note [Closure conversion]
+ is_con_app (Var v) = isDataConWorkId v
+ is_con_app (App f _) = is_con_app f
+ is_con_app (Lam _ e) = is_con_app e
+ is_con_app (Note _ e) = is_con_app e
+ is_con_app _ = False
+
+makeLoopBreaker :: Bool -> Id -> Id
+-- Set the loop-breaker flag
+-- See Note [Weak loop breakers]
+makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
+\end{code}
- where
- (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
- (tagged_bndr, rhs) = chosen_pair
+Note [Worker inline loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Never choose a wrapper as the loop breaker! Because
+wrappers get auto-generated inlinings when importing, and
+that can lead to an infinite inlining loop. For example:
+ rec {
+ $wfoo x = ....foo x....
- -- 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
+ {-loop brk-} foo x = ...$wfoo x...
+ }
- 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
+The interface file sees the unfolding for $wfoo, and sees that foo is
+strict (and hence it gets an auto-generated wrapper). Result: an
+infinite inlining in the importing scope. So be a bit careful if you
+change this. A good example is Tree.repTree in
+nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
+breaker then compiling Game.hs goes into an infinite loop (this
+happened when we gave is_con_app a lower score than inline candidates).
- | 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
-
- | idHasRules bndr = 1
- -- Avoid things with specialisations; we'd like
- -- to take advantage of them in the subsequent bindings
-
- | otherwise = 0
+Note [Closure conversion]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
+The immediate motivation came from the result of a closure-conversion transformation
+which generated code like this:
+
+ data Clo a b = forall c. Clo (c -> a -> b) c
+
+ ($:) :: Clo a b -> a -> b
+ Clo f env $: x = f env x
+
+ rec { plus = Clo plus1 ()
+
+ ; plus1 _ n = Clo plus2 n
+
+ ; plus2 Zero n = n
+ ; plus2 (Succ m) n = Succ (plus $: m $: n) }
+
+If we inline 'plus' and 'plus1', everything unravels nicely. But if
+we choose 'plus1' as the loop breaker (which is entirely possible
+otherwise), the loop does not unravel nicely.
- 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
by an INLINE pragma. For these we record that anything which occurs
\begin{code}
occAnalRhs :: OccEnv
- -> Id -> CoreExpr -- Binder and rhs
- -- For non-recs the binder is alrady tagged
- -- with occurrence info
- -> (UsageDetails, CoreExpr)
+ -> Id -> CoreExpr -- Binder and rhs
+ -- For non-recs the binder is alrady tagged
+ -- with occurrence info
+ -> (UsageDetails, CoreExpr)
occAnalRhs env id rhs
- = (final_usage, rhs')
+ = occAnal ctxt 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...
+ | 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
+ OneOcc in_lam one_br _ -> not in_lam && one_br
+ _ -> False
+\end{code}
- -- [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
+\begin{code}
addRuleUsage :: UsageDetails -> Id -> UsageDetails
-- Add the usage from RULES in Id to the usage
addRuleUsage usage id
= foldVarSet add usage (idRuleVars id)
where
- add v u = addOneOcc u v RulesOnly -- Give a non-committal binder info
- -- (i.e manyOcc) because many copies
- -- of the specialised thing can appear
+ 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
~~~~~~~~~~~
\begin{code}
occAnal :: OccEnv
- -> CoreExpr
- -> (UsageDetails, -- Gives info only about the "interesting" Ids
- CoreExpr)
+ -> CoreExpr
+ -> (UsageDetails, -- Gives info only about the "interesting" Ids
+ CoreExpr)
-occAnal env (Type t) = (emptyDetails, Type t)
+occAnal _ (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
+ -- But 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.
\begin{verbatim}
module A where
-f x = let y = expensive x in
- let z = (True,y) in
+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}
Constructors are rather like lambdas in this way.
\begin{code}
-occAnal env expr@(Lit lit) = (emptyDetails, expr)
+occAnal _ expr@(Lit _) = (emptyDetails, expr)
\end{code}
\begin{code}
occAnal env (Note InlineMe body)
- = case occAnal env body of { (usage, body') ->
+ = case occAnal env body of { (usage, body') ->
(mapVarEnv markMany usage, Note InlineMe body')
}
-occAnal env (Note note@(SCC cc) body)
+occAnal env (Note note@(SCC _) body)
= case occAnal env body of { (usage, body') ->
(mapVarEnv markInsideSCC usage, Note note body')
}
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
- (usage, Cast expr' co)
+ (markRhsUds env True usage, Cast expr' co)
+ -- If we see let x = y `cast` co
+ -- then mark y as 'Many' so that we don't
+ -- immediately inline y again.
}
\end{code}
\begin{code}
-occAnal env app@(App fun arg)
- = occAnalApp env (collectArgs app) False
+occAnal env app@(App _ _)
+ = occAnalApp env (collectArgs app)
-- 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
+occAnal env (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...)
+-- (\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.
= 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
+ -- 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
- env_body = vanillaCtxt -- Body is (no longer) an RhsContext
+ env_body = vanillaCtxt -- Body is (no longer) an RhsContext
(binders, body) = collectBinders expr
- binders' = oneShotGroup env binders
- linear = all is_one_shot binders'
+ 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 alt_env bndr) alts of { (alts_usage_s, alts') ->
+ = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
+ case mapAndUnzip (occAnalAlt alt_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
+ alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
+ alts_usage' = addCaseBndrUsage alts_usage
+ (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
+ total_usage = scrut_usage +++ alts_usage1
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
- -- 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) }
+ -- 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)
+ Nothing -> usage
+ Just occ -> extendVarEnv usage bndr (markMany occ)
alt_env = setVanillaCtxt env
- -- Consider x = case v of { True -> (p,q); ... }
- -- Then it's fine to inline p and q
+ -- Consider x = case v of { True -> (p,q); ... }
+ -- Then it's fine to inline p and q
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
+ | 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 (Let bind body)
- = case occAnal env body of { (body_usage, 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') }}
-occAnalArgs env args
- = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
- (foldr combineUsageDetails emptyDetails arg_uds_s, args')}
+occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
+occAnalArgs _env args
+ = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
+ (foldr (+++) emptyDetails arg_uds_s, args')}
where
arg_env = vanillaCtxt
\end{code}
the "build hack" to work.
\begin{code}
-occAnalApp env (Var fun, args) is_rhs
+occAnalApp :: OccEnv
+ -> (Expr CoreBndr, [Arg CoreBndr])
+ -> (UsageDetails, Expr CoreBndr)
+occAnalApp env (Var fun, args)
= 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
+ final_args_uds = markRhsUds env is_pap args_uds
in
- (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
+ (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
where
fun_uniq = idUnique fun
fun_uds = mkOneOcc env fun (valArgCount args > 0)
-
- -- Hack for build, fold, runST
- 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') ->
+ is_pap = isDataConWorkId fun || valArgCount args < idArity fun
+
+ -- Hack for build, fold, runST
+ 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)
+ = 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
+ final_uds = fun_uds +++ args_uds
in
(final_uds, mkApps fun' args') }}
-
-appSpecial :: OccEnv
- -> Int -> CtxtTy -- Argument number, and context to use for it
- -> [CoreExpr]
- -> (UsageDetails, [CoreExpr])
+
+
+markRhsUds :: OccEnv -- Check if this is a RhsEnv
+ -> Bool -- and this is true
+ -> UsageDetails -- The do markMany on this
+ -> UsageDetails
+-- 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
+markRhsUds env is_pap arg_uds
+ | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
+ | otherwise = arg_uds
+
+
+appSpecial :: OccEnv
+ -> Int -> CtxtTy -- Argument number, and context to use for it
+ -> [CoreExpr]
+ -> (UsageDetails, [CoreExpr])
appSpecial env n ctxt args
= go n args
where
arg_env = vanillaCtxt
- go n [] = (emptyDetails, []) -- Too few args
+ go _ [] = (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') ->
+ (arg_uds +++ args_uds, arg':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') }}
+ = case occAnal arg_env arg of { (arg_uds, arg') ->
+ case go (n-1) args of { (args_uds, args') ->
+ (arg_uds +++ args_uds, arg':args') }}
\end{code}
-
+
Case alternatives
~~~~~~~~~~~~~~~~~
-If the case binder occurs at all, the other binders effectively do too.
+If the case binder occurs at all, the other binders effectively do too.
For example
- case e of x { (a,b) -> rhs }
+ case e of x { (a,b) -> rhs }
is rather like
- let x = (a,b) in rhs
+ 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
+ let a = e1; b = e2; x = (a,b) in rhs
Note [Aug 06]: I don't think this is necessary any more, and it helpe
- to know when binders are unused. See esp the call to
- isDeadBinder in Simplify.mkDupableAlt
+ to know when binders are unused. See esp the call to
+ isDeadBinder in Simplify.mkDupableAlt
\begin{code}
-occAnalAlt env case_bndr (con, bndrs, rhs)
+occAnalAlt :: OccEnv
+ -> CoreBndr
+ -> CoreAlt
+ -> (UsageDetails, Alt IdWithOccInfo)
+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 = tagged_bndrs -- See Note [Aug06] above
+ final_bndrs = tagged_bndrs -- See Note [Aug06] above
{-
- 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
+ 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')) }
%************************************************************************
-%* *
+%* *
\subsection[OccurAnal-types]{OccEnv}
-%* *
+%* *
%************************************************************************
\begin{code}
data OccEnv
- = OccEnv OccEncl -- Enclosing context information
- CtxtTy -- Tells about linearity
+ = 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
+-- 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
+ = 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
+ -- [] 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
vanillaCtxt = OccEnv OccVanilla []
+
+rhsCtxt :: OccEnv
rhsCtxt = OccEnv OccRhs []
+isRhsEnv :: OccEnv -> Bool
isRhsEnv (OccEnv OccRhs _) = True
isRhsEnv (OccEnv OccVanilla _) = False
setVanillaCtxt :: OccEnv -> OccEnv
setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
-setVanillaCtxt other_env = other_env
+setVanillaCtxt other_env = other_env
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
+ -- 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
+oneShotGroup (OccEnv _encl ctxt) bndrs
= go ctxt bndrs []
where
- go ctxt [] rev_bndrs = reverse rev_bndrs
+ go _ [] rev_bndrs = reverse rev_bndrs
go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
- | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
- where
- bndr' | lin_ctxt = setOneShotLambda bndr
- | otherwise = bndr
+ | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
+ where
+ bndr' | lin_ctxt = setOneShotLambda bndr
+ | otherwise = bndr
go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
-addAppCtxt (OccEnv encl ctxt) args
+addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
+addAppCtxt (OccEnv encl ctxt) args
= OccEnv encl (replicate (valArgCount args) True ++ ctxt)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[OccurAnal-types]{OccEnv}
-%* *
+%* *
%************************************************************************
\begin{code}
-type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
+type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
-combineUsageDetails, combineAltsUsageDetails
- :: UsageDetails -> UsageDetails -> UsageDetails
+(+++), combineAltsUsageDetails
+ :: UsageDetails -> UsageDetails -> UsageDetails
-combineUsageDetails usage1 usage2
+(+++) usage1 usage2
= plusVarEnv_C addOccInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
addOneOcc usage id info
= plusVarEnv_C addOccInfo usage (unitVarEnv id info)
- -- ToDo: make this more efficient
+ -- ToDo: make this more efficient
+emptyDetails :: UsageDetails
emptyDetails = (emptyVarEnv :: UsageDetails)
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
+type IdWithOccInfo = Id
+
+tagBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ [IdWithOccInfo]) -- Tagged binders
tagBinders usage binders
= let
in
usage' `seq` (usage', uss)
-tagBinder :: UsageDetails -- Of scope
- -> Id -- Binders
- -> (UsageDetails, -- Details with binders removed
- IdWithOccInfo) -- Tagged binders
+tagBinder :: UsageDetails -- Of scope
+ -> Id -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ IdWithOccInfo) -- Tagged binders
tagBinder usage binder
= let
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"
-
+ NoOccInfo -> bndr
+ _ -> 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
occ_info = lookupVarEnv usage bndr `orElse` IAmDead
%************************************************************************
-%* *
+%* *
\subsection{Operations over OccInfo}
-%* *
+%* *
%************************************************************************
\begin{code}
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
-mkOneOcc env id int_cxt
+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
+markMany _ = NoOccInfo
markInsideSCC occ = markMany occ
markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
-markInsideLam occ = occ
+markInsideLam occ = occ
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
addOccInfo IAmDead info2 = info2
addOccInfo info1 IAmDead = info1
-addOccInfo RulesOnly RulesOnly = RulesOnly
-addOccInfo info1 info2 = NoOccInfo
+addOccInfo _ _ = NoOccInfo
-- (orOccInfo orig new) is used
-- when combining occurrence info from branches of a case
orOccInfo IAmDead info2 = info2
orOccInfo info1 IAmDead = info1
-orOccInfo RulesOnly RulesOnly = RulesOnly
-orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
- (OneOcc in_lam2 one_branch2 int_cxt2)
+orOccInfo (OneOcc in_lam1 _ int_cxt1)
+ (OneOcc in_lam2 _ int_cxt2)
= OneOcc (in_lam1 || in_lam2)
- False -- False, because it occurs in both branches
- (int_cxt1 && int_cxt2)
-orOccInfo info1 info2 = NoOccInfo
+ False -- False, because it occurs in both branches
+ (int_cxt1 && int_cxt2)
+orOccInfo _ _ = NoOccInfo
\end{code}