core expression with (hopefully) improved usage information.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module OccurAnal (
occurAnalysePgm, occurAnalyseExpr
) where
#include "HsVersions.h"
import CoreSyn
-import CoreFVs ( idRuleVars )
+import CoreFVs
import CoreUtils ( exprIsTrivial, isDefaultAlt )
-import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
- idOccInfo, setIdOccInfo, isLocalId,
- isExportedId, idArity, idHasRules,
- idType, idUnique, Id
- )
+import Id
+import IdInfo
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 UniqFM ( keysUFM, intersectsUFM, intersectUFM_C, foldUFM_Directly )
+import Util ( mapAndUnzip )
import Outputable
+
+import Data.List
\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
-> CoreBind
-> UsageDetails -- Usage details of scope
= (body_usage, [])
| otherwise -- It's mentioned in the body
- = (final_body_usage `combineUsageDetails` rhs_usage,
+ = (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.
This seems to miss an obvious improvement.
-@
+
letrec f = ...g...
g = ...f...
in
...g...
-
===>
-
letrec f = ...g...
g = ...(...g...)...
in
...g...
-@
-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
+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...
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
+
+
+Example [eftInt]
+~~~~~~~~~~~~~~~
+Example (from GHC.Enum):
+
+ 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
+ #-}
+
+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
+ | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
+ = (body_usage, []) -- Dead code
+ | otherwise
+ = (final_usage, map ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) sccs)
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
-
+ bndrs = map fst pairs
+ bndr_set = mkVarSet bndrs
+
+ ---------------------------------------
+ -- See Note [Loop breaking]
+ ---------------------------------------
+
+ -------------Dependency analysis ------------------------------
+ occ_anald :: [(Id, (UsageDetails, CoreExpr))]
+ -- The UsageDetails here are strictly those arising from the RHS
+ -- *not* from any rules in the Id
+ occ_anald = [(bndr, occAnalRhs env bndr rhs) | (bndr,rhs) <- pairs]
+
+ total_usage = foldl add_usage body_usage occ_anald
+ add_usage body_usage (bndr, (rhs_usage, _))
+ = body_usage +++ addRuleUsage rhs_usage bndr
+
+ (final_usage, tagged_bndrs) = tagBinders total_usage bndrs
+ final_bndrs | isEmptyVarSet all_rule_fvs = tagged_bndrs
+ | otherwise = map tag_rule_var tagged_bndrs
+
+ tag_rule_var bndr | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr
+ | otherwise = bndr
+ all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) emptyVarSet bndrs
+ -- Mark the binder with OccInfo saying "no preInlineUnconditionally" if
+ -- it is used in any rule (lhs or rhs) of the recursive group
---- 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
- ]
+ sccs :: [SCC (Node Details)]
+ sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges
+
+ rec_edges :: [Node Details] -- The binders are tagged with correct occ-info
+ rec_edges = {-# SCC "occAnalBind.assoc" #-} zipWith make_node final_bndrs occ_anald
+ make_node tagged_bndr (_bndr, (rhs_usage, rhs))
+ = ((tagged_bndr, rhs, rhs_fvs), idUnique tagged_bndr, out_edges)
+ where
+ rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
+ out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars tagged_bndr)
+
-- (a -> b) means a mentions b
-- Given the usage details (a UFM that gives occ info for each free var of
-- 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)
- 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)
+
+ ---- Stuff to "re-constitute" bindings from dependency-analysis info ------
+ do_final_bind (AcyclicSCC ((bndr, rhs, _), _, _)) = NonRec bndr rhs
+ do_final_bind (CyclicSCC cycle)
+ | no_rules = Rec (reOrderCycle cycle)
+ | otherwise = Rec (concatMap reOrderRec (stronglyConnCompR loop_breaker_edges))
+ where -- See Note [Choosing loop breakers] for looop_breker_edges
+ loop_breaker_edges = map mk_node cycle
+ mk_node (details@(bndr, rhs, 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
+ 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.
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 (bind, _, _)) = [bind]
-
- -- Common case of simple self-recursion
-reOrderRec env (CyclicSCC [bind])
- = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)]
+type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
+ -- which is gotten from the Id.
+type Details = (Id, -- Binder
+ CoreExpr, -- RHS
+ IdSet) -- RHS free vars (*not* include rules)
+
+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 ((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
- ((tagged_bndr, rhs), _, _) = bind
+ ((bndr, rhs, _), _, _) = bind
-reOrderRec env (CyclicSCC (bind : binds))
+reOrderCycle (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)]
+ concatMap reOrderRec (stronglyConnCompR unchosen) ++
+ [(makeLoopBreaker False bndr, rhs)]
where
- (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
- (tagged_bndr, rhs) = chosen_pair
+ (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
+ (bndr, rhs, _) = chosen_bind
-- This loop looks for the bind with the lowest score
-- to pick as the loop breaker. The rest accumulate in
where
sc = score bind
- score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker
- score ((bndr, rhs), _, _)
+ score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
+ score ((bndr, rhs, _), _, _)
+ | workerExists (idWorkerInfo bndr) = 10
+ -- Note [Worker inline loop]
+
| 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
-- 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
+ | is_con_app rhs = 2 -- Data types help with cases
+ -- Note [conapp]
- | 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
+ | inlineCandidate bndr rhs = 1 -- Likely to be inlined
+ -- Note [Inline candidates]
| otherwise = 0
inlineCandidate id (Note InlineMe _) = True
inlineCandidate id rhs = isOneOcc (idOccInfo id)
- -- Real example (the Enum Ordering instance from PrelBase):
+ -- 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)
-- 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))
+ -- 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 b e) = is_con_app e
+ is_con_app (Note _ e) = is_con_app e
+ is_con_app other = False
+
+makeLoopBreaker :: Bool -> Id -> Id
+-- Set the loop-breaker flag
+-- See Note [Weak loop breakers]
+makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
\end{code}
+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....
+
+ {-loop brk-} foo x = ...$wfoo x...
+ }
+
+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).
+
+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.
+
+
@occAnalRhs@ deals with the question of bindings where the Id is marked
by an INLINE pragma. For these we record that anything which occurs
in its RHS occurs many times. This pessimistically assumes that ths
-> (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
certainly_inline id = case idOccInfo id of
OneOcc in_lam one_br _ -> not in_lam && one_br
other -> 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
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}
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
+ total_usage = scrut_usage +++ alts_usage1
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
occAnalArgs env args
= case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
- (foldr combineUsageDetails emptyDetails arg_uds_s, args')}
+ (foldr (+++) emptyDetails arg_uds_s, args')}
where
arg_env = vanillaCtxt
\end{code}
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
+ 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)
+ is_pap = isDataConWorkId fun || valArgCount args < idArity fun
-- Hack for build, fold, runST
args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
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') }}
+
+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]
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') }}
+ (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') }}
+ (arg_uds +++ args_uds, arg':args') }}
\end{code}
\begin{code}
type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
-combineUsageDetails, combineAltsUsageDetails
+(+++), combineAltsUsageDetails
:: UsageDetails -> UsageDetails -> UsageDetails
-combineUsageDetails usage1 usage2
+(+++) usage1 usage2
= plusVarEnv_C addOccInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
usedIn :: Id -> UsageDetails -> Bool
v `usedIn` details = isExportedId v || v `elemVarEnv` details
+type IdWithOccInfo = Id
+
tagBinders :: UsageDetails -- Of scope
-> [Id] -- Binders
-> (UsageDetails, -- Details with binders removed
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
-addOccInfo IAmDead info2 = info2
-addOccInfo info1 IAmDead = info1
-addOccInfo info1 info2 = NoOccInfo
+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
= OneOcc (in_lam1 || in_lam2)
False -- False, because it occurs in both branches
(int_cxt1 && int_cxt2)
-
orOccInfo info1 info2 = NoOccInfo
\end{code}
projects / ghc-hetmet.git / blobdiff