/ghc-7.0.4/compiler/simplCore/OccurAnal.lhs
Haskell | 1693 lines | 1155 code | 295 blank | 243 comment | 76 complexity | f398f09772414abaf938f8e8e123fb96 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause
Large files files are truncated, but you can click here to view the full file
- %
- % (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
- core expression with (hopefully) improved usage information.
- \begin{code}
- module OccurAnal (
- occurAnalysePgm, occurAnalyseExpr
- ) where
- #include "HsVersions.h"
- import CoreSyn
- import CoreFVs
- import Type ( tyVarsOfType )
- import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
- import Coercion ( CoercionI(..), mkSymCoI )
- import Id
- import NameEnv
- import NameSet
- import Name ( Name, localiseName )
- import BasicTypes
- import VarSet
- import VarEnv
- import Var ( varUnique )
- import Maybes ( orElse )
- import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
- import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
- import Unique
- import UniqFM
- import Util ( mapAndUnzip, filterOut )
- import Bag
- import Outputable
- import FastString
- import Data.List
- \end{code}
- %************************************************************************
- %* *
- \subsection[OccurAnal-main]{Counting occurrences: main function}
- %* *
- %************************************************************************
- Here's the externally-callable interface:
- \begin{code}
- occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
- -> [CoreBind] -> [CoreBind]
- occurAnalysePgm active_rule imp_rules binds
- = snd (go (initOccEnv active_rule imp_rules) binds)
- where
- initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)
- -- The RULES keep things alive!
- go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
- go _ []
- = (initial_uds, [])
- go env (bind:binds)
- = (final_usage, bind' ++ binds')
- where
- (bs_usage, binds') = go env binds
- (final_usage, bind') = occAnalBind env env bind bs_usage
- occurAnalyseExpr :: CoreExpr -> CoreExpr
- -- Do occurrence analysis, and discard occurence info returned
- occurAnalyseExpr expr
- = snd (occAnal (initOccEnv all_active_rules []) expr)
- where
- -- To be conservative, we say that all inlines and rules are active
- all_active_rules = Just (\_ -> True)
- \end{code}
- %************************************************************************
- %* *
- \subsection[OccurAnal-main]{Counting occurrences: main function}
- %* *
- %************************************************************************
- Bindings
- ~~~~~~~~
- \begin{code}
- occAnalBind :: OccEnv -- The incoming OccEnv
- -> OccEnv -- Same, but trimmed by (binderOf bind)
- -> CoreBind
- -> UsageDetails -- Usage details of scope
- -> (UsageDetails, -- Of the whole let(rec)
- [CoreBind])
- occAnalBind env _ (NonRec binder rhs) body_usage
- | isTyCoVar binder -- A type let; we don't gather usage info
- = (body_usage, [NonRec binder rhs])
- | not (binder `usedIn` body_usage) -- It's not mentioned
- = (body_usage, [])
- | otherwise -- It's mentioned in the body
- = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs'])
- where
- (body_usage', tagged_binder) = tagBinder body_usage binder
- (rhs_usage1, rhs') = occAnalRhs env (idOccInfo tagged_binder) rhs
- rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder)
- rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder)
- -- See Note [Rules are extra RHSs] and Note [Rule dependency info]
- \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 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'*.
- More concretely, the SCC analysis runs on a graph with an edge
- from f -> g iff g is mentioned in
- (a) f's rhs
- (b) f's RULES
- These are rec_edges.
- Under (b) 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 RULE is like an equation for 'f' that
- is *always* inlined if it is applicable. We do *not* disable
- rules for loop-breakers. It's up to whoever makes the rules to
- make sure that the rules themselves always terminate. See Note
- [Rules for recursive functions] in Simplify.lhs
- Hence, if
- f's RHS (or its INLINE template if it has one) 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.)
- See also Note [Finding rule RHS free vars]
- 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 if 'g' has RHS that mentions 'w', we should add w to
- g's loop-breaker edges. More concretely there is an edge from f -> g
- iff
- (a) g is mentioned in f's RHS
- (b) h is mentioned in f's RHS, and
- g appears in the RHS of a RULE of h
- or a transitive sequence of rules starting with h
- 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 [Finding rule RHS free vars]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Consider this real example from Data Parallel Haskell
- tagZero :: Array Int -> Array Tag
- {-# INLINE [1] tagZeroes #-}
- tagZero xs = pmap (\x -> fromBool (x==0)) xs
- {-# RULES "tagZero" [~1] forall xs n.
- pmap fromBool <blah blah> = tagZero xs #-}
- So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.
- However, tagZero can only be inlined in phase 1 and later, while
- the RULE is only active *before* phase 1. So there's no problem.
- To make this work, we look for the RHS free vars only for
- *active* rules. That's the reason for the is_active argument
- to idRhsRuleVars, and the occ_rule_act field of the OccEnv.
-
- * 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...
- }
- Remember 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.) Why not? Because then we
- drop the binding for 'g', which leaves it out of scope in the
- RULE!
- 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 postInlineUnconditionally
- 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.
- Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
- 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
- * Note [Inline rules]
- ~~~~~~~~~~~~~~~~~~~
- None of the above stuff about RULES applies to Inline Rules,
- stored in a CoreUnfolding. The unfolding, if any, is simplified
- at the same time as the regular RHS of the function, so it should
- be treated *exactly* like an extra RHS.
- There is a danger that we'll be sub-optimal if we see this
- f = ...f...
- [INLINE f = ..no f...]
- where f is recursive, but the INLINE is not. This can just about
- happen with a sufficiently odd set of rules; eg
- foo :: Int -> Int
- {-# INLINE [1] foo #-}
- foo x = x+1
- bar :: Int -> Int
- {-# INLINE [1] bar #-}
- bar x = foo x + 1
- {-# RULES "foo" [~1] forall x. foo x = bar x #-}
- Here the RULE makes bar recursive; but it's INLINE pragma remains
- non-recursive. It's tempting to then say that 'bar' should not be
- a loop breaker, but an attempt to do so goes wrong in two ways:
- a) We may get
- $df = ...$cfoo...
- $cfoo = ...$df....
- [INLINE $cfoo = ...no-$df...]
- But we want $cfoo to depend on $df explicitly so that we
- put the bindings in the right order to inline $df in $cfoo
- and perhaps break the loop altogether. (Maybe this
- b)
- 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 (occAnalRec env) (body_usage, []) sccs
- -- For a recursive group, we
- -- * occ-analyse all the RHSs
- -- * compute strongly-connected components
- -- * feed those components to occAnalRec
- where
- -------------Dependency analysis ------------------------------
- bndr_set = mkVarSet (map fst pairs)
- sccs :: [SCC (Node Details)]
- sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges
- rec_edges :: [Node Details]
- rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
-
- make_node (bndr, rhs)
- = (details, varUnique bndr, keysUFM out_edges)
- where
- details = ND { nd_bndr = bndr, nd_rhs = rhs'
- , nd_uds = rhs_usage3, nd_inl = inl_fvs}
- (rhs_usage1, rhs') = occAnalRhs env NoOccInfo rhs
- rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs]
- rhs_usage3 = addIdOccs rhs_usage2 unf_fvs
- unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag
- unf_fvs = stableUnfoldingVars unf
- rule_fvs = idRuleVars bndr -- See Note [Rule dependency info]
- inl_fvs = rhs_fvs `unionVarSet` unf_fvs
- rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1
- out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3
- -- (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 :: OccEnv -> SCC (Node Details)
- -> (UsageDetails, [CoreBind])
- -> (UsageDetails, [CoreBind])
- -- The NonRec case is just like a Let (NonRec ...) above
- occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _))
- (body_usage, binds)
- | not (bndr `usedIn` body_usage)
- = (body_usage, binds)
- | otherwise -- It's mentioned in the body
- = (body_usage' +++ rhs_usage,
- 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 env (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 { nd_bndr = b }, _, _) <- nodes]
- bndr_set = mkVarSet bndrs
- non_boring bndr = isId bndr &&
- (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr)
- ----------------------------
- -- Tag the binders with their occurrence info
- total_usage = foldl add_usage body_usage nodes
- add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage
- (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 (details@ND { nd_bndr = bndr }, k, ks)
- = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks))
- where
- 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 | any non_boring bndrs
- = foldr (reOrderRec 0) [] $
- stronglyConnCompFromEdgedVerticesR loop_breaker_edges
- | otherwise
- = reOrderCycle 0 tagged_nodes []
- -- See Note [Choosing loop breakers] for loop_breaker_edges
- loop_breaker_edges = map mk_node tagged_nodes
- mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks)
- where
- new_ks = keysUFM (fst (extendFvs rule_fv_env inl_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 = transClosureFV init_rule_fvs
- init_rule_fvs
- | Just is_active <- occ_rule_act env -- See Note [Finding rule RHS free vars]
- = [ (b, rule_fvs)
- | b <- bndrs
- , isId b
- , let rule_fvs = idRuleRhsVars is_active b
- `intersectVarSet` bndr_set
- , not (isEmptyVarSet rule_fvs)]
- | otherwise
- = []
- \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 IAmALoopBreaker pragma
- 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.
- 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.
- ==============
- [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....
- 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.
- ===============
- \begin{code}
- type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
- -- which is gotten from the Id.
- data Details
- = ND { nd_bndr :: Id -- Binder
- , nd_rhs :: CoreExpr -- RHS
- , nd_uds :: UsageDetails -- Usage from RHS,
- -- including RULES and InlineRule unfolding
- , nd_inl :: IdSet -- Other binders *from this Rec group* mentioned in
- } -- its InlineRule unfolding (if present)
- -- AND the RHS
- -- but *excluding* any RULES
- -- This is the IdSet that may be used if the Id is inlined
- reOrderRec :: Int -> SCC (Node Details)
- -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
- -- Sorted into a plausible order. Enough of the Ids have
- -- IAmALoopBreaker pragmas that there are no loops left.
- reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _))
- pairs = (bndr, rhs) : pairs
- reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
- reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
- reOrderCycle _ [] _
- = panic "reOrderCycle"
- reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs
- = -- Common case of simple self-recursion
- (makeLoopBreaker False bndr, rhs) : pairs
- reOrderCycle depth (bind : binds) pairs
- = -- Choose a loop breaker, mark it no-inline,
- -- do SCC analysis on the rest, and recursively sort them out
- -- pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $
- foldr (reOrderRec new_depth)
- ([ (makeLoopBreaker False bndr, rhs)
- | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs)
- (stronglyConnCompFromEdgedVerticesR unchosen)
- where
- (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds
- approximate_loop_breaker = depth >= 2
- new_depth | approximate_loop_breaker = 0
- | otherwise = depth+1
- -- After two iterations (d=0, d=1) give up
- -- and approximate, returning to d=0
- -- This loop looks for the bind with the lowest score
- -- to pick as the loop breaker. The rest accumulate in
- choose_loop_breaker loop_binds _loop_sc acc []
- = (loop_binds, acc) -- Done
- -- If approximate_loop_breaker is True, we pick *all*
- -- nodes with lowest score, else just one
- -- See Note [Complexity of loop breaking]
- choose_loop_breaker loop_binds loop_sc acc (bind : binds)
- | sc < loop_sc -- Lower score so pick this new one
- = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds
- | approximate_loop_breaker && sc == loop_sc
- = choose_loop_breaker (bind : loop_binds) loop_sc acc binds
-
- | otherwise -- Higher score so don't pick it
- = choose_loop_breaker loop_binds 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 { nd_bndr = bndr, nd_rhs = rhs }, _, _)
- | not (isId bndr) = 100 -- A type or cercion variable is never a loop breaker
- | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker
- -- Note [DFuns should not be loop breakers]
- | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
- = case inl_source of
- InlineWrapper {} -> 10 -- Note [INLINE pragmas]
- _other -> 3 -- Data structures are more important than this
- -- so that dictionary/method recursion unravels
- -- Note that this case hits all InlineRule things, so we
- -- never look at 'rhs for InlineRule stuff. That's right, because
- -- 'rhs' is irrelevant for inlining things with an InlineRule
-
- | is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications]
-
- | exprIsTrivial rhs = 10 -- 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
-
- -- 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
- | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined
- | canUnfold (realIdUnfolding bndr) = 1
- -- The Id has some kind of unfolding
- -- Ignore loop-breaker-ness here because that is what we are setting!
- | otherwise = 0
- -- Checking for a constructor application
- -- 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) = isConLikeId 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
- = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak)
- \end{code}
- Note [Complexity of loop breaking]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- The loop-breaking algorithm knocks out one binder at a time, and
- performs a new SCC analysis on the remaining binders. That can
- behave very badly in tightly-coupled groups of bindings; in the
- worst case it can be (N**2)*log N, because it does a full SCC
- on N, then N-1, then N-2 and so on.
- To avoid this, we switch plans after 2 (or whatever) attempts:
- Plan A: pick one binder with the lowest score, make it
- a loop breaker, and try again
- Plan B: pick *all* binders with the lowest score, make them
- all loop breakers, and try again
- Since there are only a small finite number of scores, this will
- terminate in a constant number of iterations, rather than O(N)
- iterations.
- You might thing that it's very unlikely, but RULES make it much
- more likely. Here's a real example from Trac #1969:
- Rec { $dm = \d.\x. op d
- {-# RULES forall d. $dm Int d = $s$dm1
- forall d. $dm Bool d = $s$dm2 #-}
-
- dInt = MkD .... opInt ...
- dInt = MkD .... opBool ...
- opInt = $dm dInt
- opBool = $dm dBool
- $s$dm1 = \x. op dInt
- $s$dm2 = \x. op dBool }
- The RULES stuff means that we can't choose $dm as a loop breaker
- (Note [Choosing loop breakers]), so we must choose at least (say)
- opInt *and* opBool, and so on. The number of loop breakders is
- linear in the number of instance declarations.
- Note [INLINE pragmas]
- ~~~~~~~~~~~~~~~~~~~~~
- Avoid choosing a function with an INLINE pramga as the loop breaker!
- If such a function is mutually-recursive with a non-INLINE thing,
- then the latter should be the loop-breaker.
- Usually this is just a question of optimisation. But a particularly
- bad case is wrappers generated by the demand analyser: if you make
- then into a loop breaker you may get 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:
- Tree.repTree
- = __inline_me (/\a. \w w1 w2 ->
- case Tree.$wrepTree @ a w w1 w2 of
- { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
- Tree.$wrepTree
- = /\a w w1 w2 ->
- (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
- Here we do *not* want to choose 'repTree' as the loop breaker.
- Note [DFuns should not be loop breakers]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- It's particularly bad to make a DFun into a loop breaker. See
- Note [How instance declarations are translated] in TcInstDcls
- We give DFuns a higher score than ordinary CONLIKE things because
- if there's a choice we want the DFun to be the non-looop breker. Eg
-
- rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)
- $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)
- {-# DFUN #-}
- $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)
- }
- Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it
- if we can't unravel the DFun first.
- Note [Constructor applications]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- 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.
- 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
- inlined binder also occurs many times in its scope, but if it doesn't
- 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
- -> OccInfo -> CoreExpr -- Binder and rhs
- -- For non-recs the binder is alrady tagged
- -- with occurrence info
- -> (UsageDetails, CoreExpr)
- -- Returned usage details covers only the RHS,
- -- and *not* the RULE or INLINE template for the Id
- occAnalRhs env occ rhs
- = occAnal ctxt rhs
- where
- ctxt | certainly_inline = env
- | otherwise = rhsCtxt env
- -- 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 = case occ of
- OneOcc in_lam one_br _ -> not in_lam && one_br
- _ -> False
- addIdOccs :: UsageDetails -> VarSet -> UsageDetails
- addIdOccs usage id_set = foldVarSet add usage id_set
- where
- add v u | isId v = addOneOcc u v NoOccInfo
- | otherwise = u
- -- Give a non-committal binder info (i.e NoOccInfo) because
- -- a) Many copies of the specialised thing can appear
- -- b) We don't want to substitute a BIG expression inside a RULE
- -- even if that's the only occurrence of the thing
- -- (Same goes for INLINE.)
- \end{code}
- Expressions
- ~~~~~~~~~~~
- \begin{code}
- occAnal :: OccEnv
- -> CoreExpr
- -> (UsageDetails, -- Gives info only about the "interesting" Ids
- CoreExpr)
- 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.
- -- 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.
- \end{code}
- We regard variables that occur as constructor arguments as "dangerousToDup":
- \begin{verbatim}
- module A where
- f x = let y = expensive x in
- let z = (True,y) in
- (case z of {(p,q)->q}, case z of {(p,q)->q})
- \end{verbatim}
- We feel free to duplicate the WHNF (True,y), but that means
- that y may be duplicated thereby.
- If we aren't careful we duplicate the (expensive x) call!
- Constructors are rather like lambdas in this way.
- \begin{code}
- occAnal _ expr@(Lit _) = (emptyDetails, expr)
- \end{code}
- \begin{code}
- occAnal env (Note note@(SCC _) 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')
- }
- occAnal env (Cast expr co)
- = case occAnal env expr of { (usage, expr') ->
- (markManyIf (isRhsEnv env) 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 _ _)
- = 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 (Lam x body) | isTyCoVar 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) = tagLamBinders body_usage binders'
- -- Use binders' to put one-shot info on the lambdas
- -- 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 (trimOccEnv env binders)
- -- 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 occ_anal_alt alts of { (alts_usage_s, alts') ->
- let
- alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
- (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
- total_usage = scrut_usage +++ alts_usage1
- in
- total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
- where
- -- Note [Case binder usage]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~
- -- 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) }
- tag_case_bndr usage bndr
- = case lookupVarEnv usage bndr of
- Nothing -> (usage, setIdOccInfo bndr IAmDead)
- Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)
- alt_env = mkAltEnv env scrut bndr
- occ_anal_alt = occAnalAlt alt_env bndr
- occ_anal_scrut (Var v) (alt1 : other_alts)
- | not (null other_alts) || not (isDefaultAlt alt1)
- = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs
- -- in an interesting context; the case has
- -- at least one non-default alternative
- occ_anal_scrut scrut _alts
- = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt
- occAnal env (Let bind body)
- = case occAnal env_body body of { (body_usage, body') ->
- case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) ->
- (final_usage, mkLets new_binds body') }}
- where
- env_body = trimOccEnv env (bindersOf bind)
- 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 env
- \end{code}
- Applications are dealt with specially because we want
- the "build hack" to work.
- \begin{code}
- occAnalApp :: OccEnv
- -> (Expr CoreBndr, [Arg CoreBndr])
- -> (UsageDetails, Expr CoreBndr)
- occAnalApp env (Var fun, args)
- = case args_stuff of { (args_uds, args') ->
- let
- final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
- -- 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
- in
- (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
- where
- fun_uniq = idUnique fun
- fun_uds = mkOneOcc env fun (valArgCount args > 0)
- is_exp = isExpandableApp fun (valArgCount args)
- -- See Note [CONLIKE pragma] in BasicTypes
- -- The definition of is_exp should match that in
- -- Simplify.prepareRhs
- -- 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 +++ args_uds
- in
- (final_uds, mkApps fun' args') }}
- markManyIf :: Bool -- If this is true
- -> UsageDetails -- Then do markMany on this
- -> UsageDetails
- markManyIf True uds = mapVarEnv markMany uds
- markManyIf False uds = 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 env
- go _ [] = (emptyDetails, []) -- Too few args
- go 1 (arg:args) -- The magic arg
- = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') ->
- case occAnalArgs env args of { (args_uds, 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') ->
- (arg_uds +++ args_uds, arg':args') }}
- \end{code}
- Note [Binders in case alternatives]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- Consider
- case x of y { (a,b) -> f y }
- We treat 'a', 'b' as dead, because they don't physically occur in the
- case alternative. (Indeed, a variable is dead iff it doesn't occur in
- its scope in the output of OccAnal.) It really helps to know when
- binders are unused. See esp the call to isDeadBinder in
- Simplify.mkDupableAlt
- In this example, though, the Simplifier will bring 'a' and 'b' back to
- life, beause it binds 'y' to (a,b) (imagine got inlined and
- scrutinised y).
- \begin{code}
- occAnalAlt :: OccEnv
- -> CoreBndr
- -> CoreAlt
- -> (UsageDetails, Alt IdWithOccInfo)
- occAnalAlt env case_bndr (con, bndrs, rhs)
- = let
- env' = trimOccEnv env bndrs
- in
- case occAnal env' rhs of { (rhs_usage1, rhs1) ->
- let
- proxies = getProxies env' case_bndr
- (rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies
- (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
- bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
- in
- (alt_usg, (con, bndrs', rhs2)) }
- wrapProxy :: ProxyBind -> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
- wrapProxy (bndr, rhs_var, co) (body_usg, body)
- | not (bndr `usedIn` body_usg)
- = (body_usg, body)
- | otherwise
- = (body_usg' +++ rhs_usg, Let (NonRec tagged_bndr rhs) body)
- where
- (body_usg', tagged_bndr) = tagBinder body_usg bndr
- rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
- rhs = mkCoerceI co (Var rhs_var)
- \end{code}
- %************************************************************************
- %* *
- OccEnv
- %* *
- %************************************************************************
- \begin{code}
- data OccEnv
- = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
- , occ_ctxt :: !CtxtTy -- Tells about linearity
- , occ_proxy :: ProxyEnv
- , occ_rule_fvs :: ImpRuleUsage
- , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive
- -- See Note [Finding rule RHS free vars]
- }
- -----------------------------
- -- 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
- instance Outputable OccEncl where
- ppr OccRhs = ptext (sLit "occRhs")
- ppr OccVanilla = ptext (sLit "occVanilla")
- 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 :: Maybe (Activation -> Bool) -> [CoreRule]
- -> OccEnv
- initOccEnv active_rule imp_rules
- = OccEnv { occ_encl = OccVanilla
- , occ_ctxt = []
- , occ_proxy = PE emptyVarEnv emptyVarSet
- , occ_rule_fvs = findImpRuleUsage active_rule imp_rules
- , occ_rule_act = active_rule }
- vanillaCtxt :: OccEnv -> OccEnv
- vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }
- rhsCtxt :: OccEnv -> OccEnv
- rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] }
- setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
- setCtxtTy env ctxt = env { occ_ctxt = ctxt }
- isRhsEnv :: OccEnv -> Bool
- isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
- isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
- 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 { occ_ctxt = ctxt }) bndrs
- = go ctxt bndrs []
- where
- 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
- go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
- addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
- addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
- = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }
- \end{code}
- %************************************************************************
- %* *
- ImpRuleUsage
- %* *
- %************************************************************************
- \begin{code}
- type ImpRuleUsage = NameEnv UsageDetails
- -- Maps an *imported* Id f to the UsageDetails for *local* Ids
- -- used on the RHS for a *local* rule for f.
- \end{code}
- Note [ImpRuleUsage]
- ~~~~~~~~~~~~~~~~
- Consider this, where A.g is an imported Id
-
- f x = A.g x
- {-# RULE "foo" forall x. A.g x = f x #-}
- Obviously there's a loop, but the danger is that the occurrence analyser
- will say that 'f' is not a loop breaker. Then the simplifier will
- optimise 'f' to
- f x = f x
- and then gaily inline 'f'. Result infinite loop. More realistically,
- these kind of rules are generated when specialising imported INLINABLE Ids.
- Solution: treat an occurrence of A.g as an occurrence of all the local Ids
- that occur on the RULE's RHS. This mapping from imported Id to local Ids
- is held in occ_rule_fvs.
- \begin{code}
- findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage
- -- Find the *local* Ids that can be reached transitively,
- -- via local rules, from each *imported* Id.
- -- Sigh: this function seems more complicated than it is really worth
- findImpRuleUsage Nothing _ = emptyNameEnv
- findImpRuleUsage (Just is_active) rules
- = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
- | f <- rule_names
- , let ls = find_lcl_deps f
- , not (isEmptyVarSet ls) ]
- where
- rule_names = map ru_fn rules
- rule_name_set = mkNameSet rule_names
- imp_deps :: NameEnv VarSet
- -- (f,g) means imported Id 'g' appears in RHS of
- -- rule for imported Id 'f', *or* does so transitively
- imp_deps = foldr add_imp emptyNameEnv rules
- add_imp rule acc
- | is_active (ruleActivation rule)
- = extendNameEnv_C unionVarSet acc (ru_fn rule)
- (exprSomeFreeVars keep_imp (ru_rhs rule))
- | otherwise = acc
- keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
- full_imp_deps = transClosureFV (ufmToList imp_deps)
- lcl_deps :: NameEnv VarSet
- -- (f, l) means localId 'l' appears immediately
- -- in the RHS of a rule for imported Id 'f'
- -- Remember, many rules might have the same ru_fn
- -- so we do need to fold
- lcl_deps = foldr add_lcl emptyNameEnv rules
- add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule)
- (exprFreeIds (ru_rhs rule))
- find_lcl_deps :: Name -> VarSet
- find_lcl_deps f
- …
Large files files are truncated, but you can click here to view the full file