2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[OccurAnal]{Occurrence analysis pass}
8 %************************************************************************
10 The occurrence analyser re-typechecks a core expression, returning a new
11 core expression with (hopefully) improved usage information.
15 occurAnalysePgm, occurAnalyseExpr
18 #include "HsVersions.h"
22 import CoreUtils ( exprIsTrivial, isDefaultAlt )
23 import Coercion ( mkSymCoercion )
25 import Name ( localiseName )
31 import Maybes ( orElse )
32 import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
33 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
34 import Unique ( Unique )
35 import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
36 import Util ( mapAndUnzip )
43 %************************************************************************
45 \subsection[OccurAnal-main]{Counting occurrences: main function}
47 %************************************************************************
49 Here's the externally-callable interface:
52 occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind]
53 occurAnalysePgm binds rules
54 = snd (go initOccEnv binds)
56 initial_details = addIdOccs emptyDetails (rulesFreeVars rules)
57 -- The RULES keep things alive!
59 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
61 = (initial_details, [])
63 = (final_usage, bind' ++ binds')
65 (bs_usage, binds') = go env binds
66 (final_usage, bind') = occAnalBind env bind bs_usage
68 occurAnalyseExpr :: CoreExpr -> CoreExpr
69 -- Do occurrence analysis, and discard occurence info returned
70 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
74 %************************************************************************
76 \subsection[OccurAnal-main]{Counting occurrences: main function}
78 %************************************************************************
86 -> UsageDetails -- Usage details of scope
87 -> (UsageDetails, -- Of the whole let(rec)
90 occAnalBind env (NonRec binder rhs) body_usage
91 | isTyVar binder -- A type let; we don't gather usage info
92 = (body_usage, [NonRec binder rhs])
94 | not (binder `usedIn` body_usage) -- It's not mentioned
97 | otherwise -- It's mentioned in the body
98 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
99 [NonRec tagged_binder rhs'])
101 (body_usage', tagged_binder) = tagBinder body_usage binder
102 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
107 Dropping dead code for recursive bindings is done in a very simple way:
109 the entire set of bindings is dropped if none of its binders are
110 mentioned in its body; otherwise none are.
112 This seems to miss an obvious improvement.
124 Now 'f' is unused! But it's OK! Dependency analysis will sort this
125 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
126 dropped. It isn't easy to do a perfect job in one blow. Consider
137 Note [Loop breaking and RULES]
138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
139 Loop breaking is surprisingly subtle. First read the section 4 of
140 "Secrets of the GHC inliner". This describes our basic plan.
142 However things are made quite a bit more complicated by RULES. Remember
144 * Note [Rules are extra RHSs]
145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
147 keeps the specialised "children" alive. If the parent dies
148 (because it isn't referenced any more), then the children will die
149 too (unless they are already referenced directly).
151 To that end, we build a Rec group for each cyclic strongly
153 *treating f's rules as extra RHSs for 'f'*.
155 When we make the Rec groups we include variables free in *either*
156 LHS *or* RHS of the rule. The former might seems silly, but see
157 Note [Rule dependency info].
159 So in Example [eftInt], eftInt and eftIntFB will be put in the
160 same Rec, even though their 'main' RHSs are both non-recursive.
162 * Note [Rules are visible in their own rec group]
163 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
164 We want the rules for 'f' to be visible in f's right-hand side.
165 And we'd like them to be visible in other functions in f's Rec
166 group. E.g. in Example [Specialisation rules] we want f' rule
167 to be visible in both f's RHS, and fs's RHS.
169 This means that we must simplify the RULEs first, before looking
170 at any of the definitions. This is done by Simplify.simplRecBind,
171 when it calls addLetIdInfo.
173 * Note [Choosing loop breakers]
174 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
175 We avoid infinite inlinings by choosing loop breakers, and
176 ensuring that a loop breaker cuts each loop. But what is a
177 "loop"? In particular, a RULE is like an equation for 'f' that
178 is *always* inlined if it is applicable. We do *not* disable
179 rules for loop-breakers. It's up to whoever makes the rules to
180 make sure that the rules themselves alwasys terminate. See Note
181 [Rules for recursive functions] in Simplify.lhs
184 f's RHS mentions g, and
185 g has a RULE that mentions h, and
186 h has a RULE that mentions f
188 then we *must* choose f to be a loop breaker. In general, take the
189 free variables of f's RHS, and augment it with all the variables
190 reachable by RULES from those starting points. That is the whole
191 reason for computing rule_fv_env in occAnalBind. (Of course we
192 only consider free vars that are also binders in this Rec group.)
194 Note that when we compute this rule_fv_env, we only consider variables
195 free in the *RHS* of the rule, in contrast to the way we build the
196 Rec group in the first place (Note [Rule dependency info])
198 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
199 chosen as a loop breaker, because their RHSs don't mention each other.
200 And indeed both can be inlined safely.
202 Note that the edges of the graph we use for computing loop breakers
203 are not the same as the edges we use for computing the Rec blocks.
204 That's why we compute
205 rec_edges for the Rec block analysis
206 loop_breaker_edges for the loop breaker analysis
209 * Note [Weak loop breakers]
210 ~~~~~~~~~~~~~~~~~~~~~~~~~
211 There is a last nasty wrinkle. Suppose we have
221 Remmber that we simplify the RULES before any RHS (see Note
222 [Rules are visible in their own rec group] above).
224 So we must *not* postInlineUnconditionally 'g', even though
225 its RHS turns out to be trivial. (I'm assuming that 'g' is
226 not choosen as a loop breaker.) Why not? Because then we
227 drop the binding for 'g', which leaves it out of scope in the
230 We "solve" this by making g a "weak" or "rules-only" loop breaker,
231 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
232 has IAmLoopBreaker False. So
234 Inline postInlineUnconditionally
235 IAmLoopBreaker False no no
236 IAmLoopBreaker True yes no
239 The **sole** reason for this kind of loop breaker is so that
240 postInlineUnconditionally does not fire. Ugh.
242 * Note [Rule dependency info]
243 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
244 The VarSet in a SpecInfo is used for dependency analysis in the
245 occurrence analyser. We must track free vars in *both* lhs and rhs.
246 Hence use of idRuleVars, rather than idRuleRhsVars in addRuleUsage.
250 Then if we substitute y for x, we'd better do so in the
251 rule's LHS too, so we'd better ensure the dependency is respected
254 * Note [Inline rules]
256 None of the above stuff about RULES applies to Inline Rules,
257 stored in a CoreUnfolding. The unfolding, if any, is simplified
258 at the same time as the regular RHS of the function, so it should
259 be treated *exactly* like an extra RHS.
264 Example (from GHC.Enum):
266 eftInt :: Int# -> Int# -> [Int]
267 eftInt x y = ...(non-recursive)...
269 {-# INLINE [0] eftIntFB #-}
270 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
271 eftIntFB c n x y = ...(non-recursive)...
274 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
275 "eftIntList" [1] eftIntFB (:) [] = eftInt
278 Example [Specialisation rules]
279 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
280 Consider this group, which is typical of what SpecConstr builds:
282 fs a = ....f (C a)....
283 f x = ....f (C a)....
284 {-# RULE f (C a) = fs a #-}
286 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
288 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
289 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
290 - fs is inlined (say it's small)
291 - now there's another opportunity to apply the RULE
293 This showed up when compiling Control.Concurrent.Chan.getChanContents.
297 occAnalBind env (Rec pairs) body_usage
298 = foldr occAnalRec (body_usage, []) sccs
299 -- For a recursive group, we
300 -- * occ-analyse all the RHSs
301 -- * compute strongly-connected components
302 -- * feed those components to occAnalRec
304 -------------Dependency analysis ------------------------------
305 bndr_set = mkVarSet (map fst pairs)
307 sccs :: [SCC (Node Details)]
308 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges
310 rec_edges :: [Node Details]
311 rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
313 make_node (bndr, rhs)
314 = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges)
316 (rhs_usage, rhs') = occAnalRhs env bndr rhs
317 all_rhs_usage = addRuleUsage rhs_usage bndr -- Note [Rules are extra RHSs]
318 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
319 out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
320 -- (a -> b) means a mentions b
321 -- Given the usage details (a UFM that gives occ info for each free var of
322 -- the RHS) we can get the list of free vars -- or rather their Int keys --
323 -- by just extracting the keys from the finite map. Grimy, but fast.
324 -- Previously we had this:
325 -- [ bndr | bndr <- bndrs,
326 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
327 -- which has n**2 cost, and this meant that edges_from alone
328 -- consumed 10% of total runtime!
330 -----------------------------
331 occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
332 -> (UsageDetails, [CoreBind])
334 -- The NonRec case is just like a Let (NonRec ...) above
335 occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
336 | not (bndr `usedIn` body_usage)
337 = (body_usage, binds)
339 | otherwise -- It's mentioned in the body
340 = (body_usage' +++ rhs_usage,
341 NonRec tagged_bndr rhs : binds)
343 (body_usage', tagged_bndr) = tagBinder body_usage bndr
346 -- The Rec case is the interesting one
347 -- See Note [Loop breaking]
348 occAnalRec (CyclicSCC nodes) (body_usage, binds)
349 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
350 = (body_usage, binds) -- Dead code
352 | otherwise -- At this point we always build a single Rec
353 = (final_usage, Rec pairs : binds)
356 bndrs = [b | (ND b _ _ _, _, _) <- nodes]
357 bndr_set = mkVarSet bndrs
359 ----------------------------
360 -- Tag the binders with their occurrence info
361 total_usage = foldl add_usage body_usage nodes
362 add_usage usage_so_far (ND _ _ rhs_usage _, _, _) = usage_so_far +++ rhs_usage
363 (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
365 tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
366 -- (a) Tag the binders in the details with occ info
367 -- (b) Mark the binder with "weak loop-breaker" OccInfo
368 -- saying "no preInlineUnconditionally" if it is used
369 -- in any rule (lhs or rhs) of the recursive group
370 -- See Note [Weak loop breakers]
371 tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
372 = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
374 bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
376 bndr1 = setBinderOcc usage bndr
377 all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
380 ----------------------------
381 -- Now reconstruct the cycle
382 pairs | no_rules = reOrderCycle 0 tagged_nodes []
383 | otherwise = foldr (reOrderRec 0) [] $
384 stronglyConnCompFromEdgedVerticesR loop_breaker_edges
386 -- See Note [Choosing loop breakers] for loop_breaker_edges
387 loop_breaker_edges = map mk_node tagged_nodes
388 mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
390 new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
392 ------------------------------------
393 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
394 -- Domain is *subset* of bound vars (others have no rule fvs)
395 rule_fv_env = rule_loop init_rule_fvs
397 no_rules = null init_rule_fvs
398 init_rule_fvs = [(b, rule_fvs)
400 , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
401 , not (isEmptyVarSet rule_fvs)]
403 rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
406 | otherwise = rule_loop new_fv_list
408 env = mkVarEnv init_rule_fvs
409 (no_change, new_fv_list) = mapAccumL bump True fv_list
410 bump no_change (b,fvs)
411 | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
412 | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
414 new_fvs = extendFvs env emptyVarSet fvs
416 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
417 -- (extendFVs env fvs s) returns (fvs `union` env(s))
418 extendFvs env fvs id_set
419 = foldUFM_Directly add fvs id_set
422 = case lookupVarEnv_Directly env uniq of
423 Just fvs' -> fvs' `unionVarSet` fvs
427 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
428 strongly connected component (there's guaranteed to be a cycle). It returns the
430 a) in a better order,
431 b) with some of the Ids having a IAmALoopBreaker pragma
433 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
434 that the simplifier can guarantee not to loop provided it never records an inlining
435 for these no-inline guys.
437 Furthermore, the order of the binds is such that if we neglect dependencies
438 on the no-inline Ids then the binds are topologically sorted. This means
439 that the simplifier will generally do a good job if it works from top bottom,
440 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
443 [June 98: I don't understand the following paragraphs, and I've
444 changed the a=b case again so that it isn't a special case any more.]
446 Here's a case that bit me:
454 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
456 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
457 Perhaps something cleverer would suffice.
462 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
463 -- which is gotten from the Id.
464 data Details = ND Id -- Binder
467 UsageDetails -- Full usage from RHS,
468 -- including *both* RULES *and* InlineRule unfolding
470 IdSet -- Other binders *from this Rec group* mentioned in
472 -- * any InlineRule unfolding
473 -- but *excluding* any RULES
475 reOrderRec :: Int -> SCC (Node Details)
476 -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
477 -- Sorted into a plausible order. Enough of the Ids have
478 -- IAmALoopBreaker pragmas that there are no loops left.
479 reOrderRec _ (AcyclicSCC (ND bndr rhs _ _, _, _)) pairs = (bndr, rhs) : pairs
480 reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
482 reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
484 = panic "reOrderCycle"
485 reOrderCycle _ [bind] pairs -- Common case of simple self-recursion
486 = (makeLoopBreaker False bndr, rhs) : pairs
488 (ND bndr rhs _ _, _, _) = bind
490 reOrderCycle depth (bind : binds) pairs
491 = -- Choose a loop breaker, mark it no-inline,
492 -- do SCC analysis on the rest, and recursively sort them out
493 -- pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $
494 foldr (reOrderRec new_depth)
495 ([ (makeLoopBreaker False bndr, rhs)
496 | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs)
497 (stronglyConnCompFromEdgedVerticesR unchosen)
499 (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds
501 approximate_loop_breaker = depth >= 2
502 new_depth | approximate_loop_breaker = 0
503 | otherwise = depth+1
504 -- After two iterations (d=0, d=1) give up
505 -- and approximate, returning to d=0
507 -- This loop looks for the bind with the lowest score
508 -- to pick as the loop breaker. The rest accumulate in
509 choose_loop_breaker loop_binds _loop_sc acc []
510 = (loop_binds, acc) -- Done
512 -- If approximate_loop_breaker is True, we pick *all*
513 -- nodes with lowest score, else just one
514 -- See Note [Complexity of loop breaking]
515 choose_loop_breaker loop_binds loop_sc acc (bind : binds)
516 | sc < loop_sc -- Lower score so pick this new one
517 = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds
519 | approximate_loop_breaker && sc == loop_sc
520 = choose_loop_breaker (bind : loop_binds) loop_sc acc binds
522 | otherwise -- Higher score so don't pick it
523 = choose_loop_breaker loop_binds loop_sc (bind : acc) binds
527 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
528 score (ND bndr rhs _ _, _, _)
529 | exprIsTrivial rhs = 10 -- Practically certain to be inlined
530 -- Used to have also: && not (isExportedId bndr)
531 -- But I found this sometimes cost an extra iteration when we have
532 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
533 -- where df is the exported dictionary. Then df makes a really
534 -- bad choice for loop breaker
536 | Just inl_rule_info <- isInlineRule_maybe (idUnfolding bndr)
537 = case inl_rule_info of
538 InlWrapper {} -> 10 -- Note [INLINE pragmas]
539 _other -> 3 -- Data structures are more important than this
540 -- so that dictionary/method recursion unravels
542 | is_con_app rhs = 5 -- Data types help with cases
543 -- Includes dict funs
544 -- Note [Constructor applictions]
546 -- If an Id is marked "never inline" then it makes a great loop breaker
547 -- The only reason for not checking that here is that it is rare
548 -- and I've never seen a situation where it makes a difference,
549 -- so it probably isn't worth the time to test on every binder
550 -- | isNeverActive (idInlinePragma bndr) = -10
552 | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined
554 | canUnfold (idUnfolding bndr) = 1
555 -- the Id has some kind of unfolding
561 -- Checking for a constructor application
562 -- Cheap and cheerful; the simplifer moves casts out of the way
563 -- The lambda case is important to spot x = /\a. C (f a)
564 -- which comes up when C is a dictionary constructor and
565 -- f is a default method.
566 -- Example: the instance for Show (ST s a) in GHC.ST
568 -- However we *also* treat (\x. C p q) as a con-app-like thing,
569 -- Note [Closure conversion]
570 is_con_app (Var v) = isConLikeId v
571 is_con_app (App f _) = is_con_app f
572 is_con_app (Lam _ e) = is_con_app e
573 is_con_app (Note _ e) = is_con_app e
576 makeLoopBreaker :: Bool -> Id -> Id
577 -- Set the loop-breaker flag: see Note [Weak loop breakers]
578 makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
581 Note [Complexity of loop breaking]
582 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
583 The loop-breaking algorithm knocks out one binder at a time, and
584 performs a new SCC analysis on the remaining binders. That can
585 behave very badly in tightly-coupled groups of bindings; in the
586 worst case it can be (N**2)*log N, because it does a full SCC
587 on N, then N-1, then N-2 and so on.
589 To avoid this, we switch plans after 2 (or whatever) attempts:
590 Plan A: pick one binder with the lowest score, make it
591 a loop breaker, and try again
592 Plan B: pick *all* binders with the lowest score, make them
593 all loop breakers, and try again
594 Since there are only a small finite number of scores, this will
595 terminate in a constant number of iterations, rather than O(N)
598 You might thing that it's very unlikely, but RULES make it much
599 more likely. Here's a real example from Trac #1969:
600 Rec { $dm = \d.\x. op d
601 {-# RULES forall d. $dm Int d = $s$dm1
602 forall d. $dm Bool d = $s$dm2 #-}
604 dInt = MkD .... opInt ...
605 dInt = MkD .... opBool ...
610 $s$dm2 = \x. op dBool }
611 The RULES stuff means that we can't choose $dm as a loop breaker
612 (Note [Choosing loop breakers]), so we must choose at least (say)
613 opInt *and* opBool, and so on. The number of loop breakders is
614 linear in the number of instance declarations.
616 Note [INLINE pragmas]
617 ~~~~~~~~~~~~~~~~~~~~~
618 Never choose a function with an INLINE pramga as the loop breaker!
619 If such a function is mutually-recursive with a non-INLINE thing,
620 then the latter should be the loop-breaker.
622 A particular case is wrappers generated by the demand analyser.
623 If you make then into a loop breaker you may get an infinite
624 inlining loop. For example:
626 $wfoo x = ....foo x....
628 {-loop brk-} foo x = ...$wfoo x...
630 The interface file sees the unfolding for $wfoo, and sees that foo is
631 strict (and hence it gets an auto-generated wrapper). Result: an
632 infinite inlining in the importing scope. So be a bit careful if you
633 change this. A good example is Tree.repTree in
634 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
635 breaker then compiling Game.hs goes into an infinite loop. This
636 happened when we gave is_con_app a lower score than inline candidates:
639 = __inline_me (/\a. \w w1 w2 ->
640 case Tree.$wrepTree @ a w w1 w2 of
641 { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
644 (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
646 Here we do *not* want to choose 'repTree' as the loop breaker.
648 Note [Constructor applications]
649 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
650 It's really really important to inline dictionaries. Real
651 example (the Enum Ordering instance from GHC.Base):
653 rec f = \ x -> case d of (p,q,r) -> p x
654 g = \ x -> case d of (p,q,r) -> q x
657 Here, f and g occur just once; but we can't inline them into d.
658 On the other hand we *could* simplify those case expressions if
659 we didn't stupidly choose d as the loop breaker.
660 But we won't because constructor args are marked "Many".
661 Inlining dictionaries is really essential to unravelling
662 the loops in static numeric dictionaries, see GHC.Float.
664 Note [Closure conversion]
665 ~~~~~~~~~~~~~~~~~~~~~~~~~
666 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
667 The immediate motivation came from the result of a closure-conversion transformation
668 which generated code like this:
670 data Clo a b = forall c. Clo (c -> a -> b) c
672 ($:) :: Clo a b -> a -> b
673 Clo f env $: x = f env x
675 rec { plus = Clo plus1 ()
677 ; plus1 _ n = Clo plus2 n
680 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
682 If we inline 'plus' and 'plus1', everything unravels nicely. But if
683 we choose 'plus1' as the loop breaker (which is entirely possible
684 otherwise), the loop does not unravel nicely.
687 @occAnalRhs@ deals with the question of bindings where the Id is marked
688 by an INLINE pragma. For these we record that anything which occurs
689 in its RHS occurs many times. This pessimistically assumes that ths
690 inlined binder also occurs many times in its scope, but if it doesn't
691 we'll catch it next time round. At worst this costs an extra simplifier pass.
692 ToDo: try using the occurrence info for the inline'd binder.
694 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
695 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
700 -> Id -> CoreExpr -- Binder and rhs
701 -- For non-recs the binder is alrady tagged
702 -- with occurrence info
703 -> (UsageDetails, CoreExpr)
704 -- Returned usage details includes any INLINE rhs
706 occAnalRhs env id rhs
707 = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
708 -- Include occurrences for the "extra RHS" from a CoreUnfolding
710 (rhs_usage, rhs') = occAnal ctxt rhs
711 ctxt | certainly_inline id = env
712 | otherwise = rhsCtxt env
713 -- Note that we generally use an rhsCtxt. This tells the occ anal n
714 -- that it's looking at an RHS, which has an effect in occAnalApp
716 -- But there's a problem. Consider
721 -- First time round, it looks as if x1 and x2 occur as an arg of a
722 -- let-bound constructor ==> give them a many-occurrence.
723 -- But then x3 is inlined (unconditionally as it happens) and
724 -- next time round, x2 will be, and the next time round x1 will be
725 -- Result: multiple simplifier iterations. Sigh.
726 -- Crude solution: use rhsCtxt for things that occur just once...
728 certainly_inline id = case idOccInfo id of
729 OneOcc in_lam one_br _ -> not in_lam && one_br
736 addRuleUsage :: UsageDetails -> Id -> UsageDetails
737 -- Add the usage from RULES in Id to the usage
738 addRuleUsage usage id = addIdOccs usage (idRuleVars id)
739 -- idRuleVars here: see Note [Rule dependency info]
741 addIdOccs :: UsageDetails -> VarSet -> UsageDetails
742 addIdOccs usage id_set = foldVarSet add usage id_set
744 add v u | isId v = addOneOcc u v NoOccInfo
746 -- Give a non-committal binder info (i.e NoOccInfo) because
747 -- a) Many copies of the specialised thing can appear
748 -- b) We don't want to substitute a BIG expression inside a RULE
749 -- even if that's the only occurrence of the thing
750 -- (Same goes for INLINE.)
758 -> (UsageDetails, -- Gives info only about the "interesting" Ids
761 occAnal _ (Type t) = (emptyDetails, Type t)
762 occAnal env (Var v) = (mkOneOcc env v False, Var v)
763 -- At one stage, I gathered the idRuleVars for v here too,
764 -- which in a way is the right thing to do.
765 -- But that went wrong right after specialisation, when
766 -- the *occurrences* of the overloaded function didn't have any
767 -- rules in them, so the *specialised* versions looked as if they
768 -- weren't used at all.
771 We regard variables that occur as constructor arguments as "dangerousToDup":
775 f x = let y = expensive x in
777 (case z of {(p,q)->q}, case z of {(p,q)->q})
780 We feel free to duplicate the WHNF (True,y), but that means
781 that y may be duplicated thereby.
783 If we aren't careful we duplicate the (expensive x) call!
784 Constructors are rather like lambdas in this way.
787 occAnal _ expr@(Lit _) = (emptyDetails, expr)
791 occAnal env (Note note@(SCC _) body)
792 = case occAnal env body of { (usage, body') ->
793 (mapVarEnv markInsideSCC usage, Note note body')
796 occAnal env (Note note body)
797 = case occAnal env body of { (usage, body') ->
798 (usage, Note note body')
801 occAnal env (Cast expr co)
802 = case occAnal env expr of { (usage, expr') ->
803 (markRhsUds env True usage, Cast expr' co)
804 -- If we see let x = y `cast` co
805 -- then mark y as 'Many' so that we don't
806 -- immediately inline y again.
811 occAnal env app@(App _ _)
812 = occAnalApp env (collectArgs app)
814 -- Ignore type variables altogether
815 -- (a) occurrences inside type lambdas only not marked as InsideLam
816 -- (b) type variables not in environment
818 occAnal env (Lam x body) | isTyVar x
819 = case occAnal env body of { (body_usage, body') ->
820 (body_usage, Lam x body')
823 -- For value lambdas we do a special hack. Consider
825 -- If we did nothing, x is used inside the \y, so would be marked
826 -- as dangerous to dup. But in the common case where the abstraction
827 -- is applied to two arguments this is over-pessimistic.
828 -- So instead, we just mark each binder with its occurrence
829 -- info in the *body* of the multiple lambda.
830 -- Then, the simplifier is careful when partially applying lambdas.
832 occAnal env expr@(Lam _ _)
833 = case occAnal env_body body of { (body_usage, body') ->
835 (final_usage, tagged_binders) = tagLamBinders body_usage binders'
836 -- Use binders' to put one-shot info on the lambdas
838 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
839 -- we get linear-typed things in the resulting program that we can't handle yet.
840 -- (e.g. PrelShow) TODO
842 really_final_usage = if linear then
845 mapVarEnv markInsideLam final_usage
848 mkLams tagged_binders body') }
850 env_body = vanillaCtxt env -- Body is (no longer) an RhsContext
851 (binders, body) = collectBinders expr
852 binders' = oneShotGroup env binders
853 linear = all is_one_shot binders'
854 is_one_shot b = isId b && isOneShotBndr b
856 occAnal env (Case scrut bndr ty alts)
857 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
858 case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
860 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
861 (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
862 total_usage = scrut_usage +++ alts_usage1
864 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
866 -- Note [Case binder usage]
867 -- ~~~~~~~~~~~~~~~~~~~~~~~~
868 -- The case binder gets a usage of either "many" or "dead", never "one".
869 -- Reason: we like to inline single occurrences, to eliminate a binding,
870 -- but inlining a case binder *doesn't* eliminate a binding.
871 -- We *don't* want to transform
872 -- case x of w { (p,q) -> f w }
874 -- case x of w { (p,q) -> f (p,q) }
875 tag_case_bndr usage bndr
876 = case lookupVarEnv usage bndr of
877 Nothing -> (usage, setIdOccInfo bndr IAmDead)
878 Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)
880 alt_env = mkAltEnv env bndr_swap
881 -- Consider x = case v of { True -> (p,q); ... }
882 -- Then it's fine to inline p and q
884 bndr_swap = case scrut of
885 Var v -> Just (v, Var bndr)
886 Cast (Var v) co -> Just (v, Cast (Var bndr) (mkSymCoercion co))
889 occ_anal_alt = occAnalAlt alt_env bndr bndr_swap
891 occ_anal_scrut (Var v) (alt1 : other_alts)
892 | not (null other_alts) || not (isDefaultAlt alt1)
893 = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs
894 -- in an interesting context; the case has
895 -- at least one non-default alternative
896 occ_anal_scrut scrut _alts
897 = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt
899 occAnal env (Let bind body)
900 = case occAnal env body of { (body_usage, body') ->
901 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
902 (final_usage, mkLets new_binds body') }}
904 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
906 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
907 (foldr (+++) emptyDetails arg_uds_s, args')}
909 arg_env = vanillaCtxt env
912 Applications are dealt with specially because we want
913 the "build hack" to work.
917 -> (Expr CoreBndr, [Arg CoreBndr])
918 -> (UsageDetails, Expr CoreBndr)
919 occAnalApp env (Var fun, args)
920 = case args_stuff of { (args_uds, args') ->
922 final_args_uds = markRhsUds env is_pap args_uds
924 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
926 fun_uniq = idUnique fun
927 fun_uds = mkOneOcc env fun (valArgCount args > 0)
928 is_pap = isConLikeId fun || valArgCount args < idArity fun
929 -- See Note [CONLIKE pragma] in BasicTypes
931 -- Hack for build, fold, runST
932 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
933 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
934 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
935 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
936 -- (foldr k z xs) may call k many times, but it never
937 -- shares a partial application of k; hence [False,True]
938 -- This means we can optimise
939 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
940 -- by floating in the v
942 | otherwise = occAnalArgs env args
945 occAnalApp env (fun, args)
946 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
947 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
948 -- often leaves behind beta redexs like
950 -- Here we would like to mark x,y as one-shot, and treat the whole
951 -- thing much like a let. We do this by pushing some True items
952 -- onto the context stack.
954 case occAnalArgs env args of { (args_uds, args') ->
956 final_uds = fun_uds +++ args_uds
958 (final_uds, mkApps fun' args') }}
961 markRhsUds :: OccEnv -- Check if this is a RhsEnv
962 -> Bool -- and this is true
963 -> UsageDetails -- The do markMany on this
965 -- We mark the free vars of the argument of a constructor or PAP
966 -- as "many", if it is the RHS of a let(rec).
967 -- This means that nothing gets inlined into a constructor argument
968 -- position, which is what we want. Typically those constructor
969 -- arguments are just variables, or trivial expressions.
971 -- This is the *whole point* of the isRhsEnv predicate
972 markRhsUds env is_pap arg_uds
973 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
974 | otherwise = arg_uds
978 -> Int -> CtxtTy -- Argument number, and context to use for it
980 -> (UsageDetails, [CoreExpr])
981 appSpecial env n ctxt args
984 arg_env = vanillaCtxt env
986 go _ [] = (emptyDetails, []) -- Too few args
988 go 1 (arg:args) -- The magic arg
989 = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') ->
990 case occAnalArgs env args of { (args_uds, args') ->
991 (arg_uds +++ args_uds, arg':args') }}
994 = case occAnal arg_env arg of { (arg_uds, arg') ->
995 case go (n-1) args of { (args_uds, args') ->
996 (arg_uds +++ args_uds, arg':args') }}
1002 We do these two transformations right here:
1004 (1) case x of b { pi -> ri }
1006 case x of b { pi -> let x=b in ri }
1008 (2) case (x |> co) of b { pi -> ri }
1010 case (x |> co) of b { pi -> let x = b |> sym co in ri }
1012 Why (2)? See Note [Case of cast]
1014 In both cases, in a particular alternative (pi -> ri), we only
1016 (a) x occurs free in (pi -> ri)
1017 (ie it occurs in ri, but is not bound in pi)
1018 (b) the pi does not bind b (or the free vars of co)
1019 We need (a) and (b) for the inserted binding to be correct.
1021 For the alternatives where we inject the binding, we can transfer
1022 all x's OccInfo to b. And that is the point.
1025 * The deliberate shadowing of 'x'.
1026 * That (a) rapidly becomes false, so no bindings are injected.
1028 The reason for doing these transformations here is because it allows
1029 us to adjust the OccInfo for 'x' and 'b' as we go.
1031 * Suppose the only occurrences of 'x' are the scrutinee and in the
1032 ri; then this transformation makes it occur just once, and hence
1033 get inlined right away.
1035 * If we do this in the Simplifier, we don't know whether 'x' is used
1036 in ri, so we are forced to pessimistically zap b's OccInfo even
1037 though it is typically dead (ie neither it nor x appear in the
1038 ri). There's nothing actually wrong with zapping it, except that
1039 it's kind of nice to know which variables are dead. My nose
1040 tells me to keep this information as robustly as possible.
1042 The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
1043 {x=b}; it's Nothing if the binder-swap doesn't happen.
1045 There is a danger though. Consider
1047 in case (f v) of w -> ...v...v...
1048 And suppose that (f v) expands to just v. Then we'd like to
1049 use 'w' instead of 'v' in the alternative. But it may be too
1050 late; we may have substituted the (cheap) x+#y for v in the
1051 same simplifier pass that reduced (f v) to v.
1053 I think this is just too bad. CSE will recover some of it.
1055 Note [Binder swap on GlobalId scrutinees]
1056 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1057 When the scrutinee is a GlobalId we must take care in two ways
1059 i) In order to *know* whether 'x' occurs free in the RHS, we need its
1060 occurrence info. BUT, we don't gather occurrence info for
1061 GlobalIds. That's what the (small) occ_scrut_ids set in OccEnv is
1062 for: it says "gather occurrence info for these.
1064 ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
1065 has an External Name. See, for example, SimplEnv Note [Global Ids in
1068 Historical note [no-case-of-case]
1069 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1070 We *used* to suppress the binder-swap in case expressoins when
1071 -fno-case-of-case is on. Old remarks:
1072 "This happens in the first simplifier pass,
1073 and enhances full laziness. Here's the bad case:
1074 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1075 If we eliminate the inner case, we trap it inside the I# v -> arm,
1076 which might prevent some full laziness happening. I've seen this
1077 in action in spectral/cichelli/Prog.hs:
1078 [(m,n) | m <- [1..max], n <- [1..max]]
1079 Hence the check for NoCaseOfCase."
1080 However, now the full-laziness pass itself reverses the binder-swap, so this
1081 check is no longer necessary.
1083 Historical note [Suppressing the case binder-swap]
1084 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1085 This old note describes a problem that is also fixed by doing the
1086 binder-swap in OccAnal:
1088 There is another situation when it might make sense to suppress the
1089 case-expression binde-swap. If we have
1091 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1092 ...other cases .... }
1094 We'll perform the binder-swap for the outer case, giving
1096 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1097 ...other cases .... }
1099 But there is no point in doing it for the inner case, because w1 can't
1100 be inlined anyway. Furthermore, doing the case-swapping involves
1101 zapping w2's occurrence info (see paragraphs that follow), and that
1102 forces us to bind w2 when doing case merging. So we get
1104 case x of w1 { A -> let w2 = w1 in e1
1105 B -> let w2 = w1 in e2
1106 ...other cases .... }
1108 This is plain silly in the common case where w2 is dead.
1110 Even so, I can't see a good way to implement this idea. I tried
1111 not doing the binder-swap if the scrutinee was already evaluated
1112 but that failed big-time:
1116 case v of w { MkT x ->
1117 case x of x1 { I# y1 ->
1118 case x of x2 { I# y2 -> ...
1120 Notice that because MkT is strict, x is marked "evaluated". But to
1121 eliminate the last case, we must either make sure that x (as well as
1122 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1123 the binder-swap. So this whole note is a no-op.
1125 It's fixed by doing the binder-swap in OccAnal because we can do the
1126 binder-swap unconditionally and still get occurrence analysis
1131 Consider case (x `cast` co) of b { I# ->
1132 ... (case (x `cast` co) of {...}) ...
1133 We'd like to eliminate the inner case. That is the motivation for
1134 equation (2) in Note [Binder swap]. When we get to the inner case, we
1135 inline x, cancel the casts, and away we go.
1137 Note [Binders in case alternatives]
1138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1140 case x of y { (a,b) -> f y }
1141 We treat 'a', 'b' as dead, because they don't physically occur in the
1142 case alternative. (Indeed, a variable is dead iff it doesn't occur in
1143 its scope in the output of OccAnal.) It really helps to know when
1144 binders are unused. See esp the call to isDeadBinder in
1145 Simplify.mkDupableAlt
1147 In this example, though, the Simplifier will bring 'a' and 'b' back to
1148 life, beause it binds 'y' to (a,b) (imagine got inlined and
1152 occAnalAlt :: OccEnv
1154 -> Maybe (Id, CoreExpr) -- Note [Binder swap]
1156 -> (UsageDetails, Alt IdWithOccInfo)
1157 occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs)
1158 = case occAnal env rhs of { (rhs_usage, rhs') ->
1160 (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage bndrs
1161 bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
1163 case mb_scrut_var of
1164 Just (scrut_var, scrut_rhs) -- See Note [Binder swap]
1165 | scrut_var `localUsedIn` alt_usg -- (a) Fast path, usually false
1166 , not (any shadowing bndrs) -- (b)
1167 -> (addOneOcc usg_wo_scrut case_bndr NoOccInfo,
1168 -- See Note [Case binder usage] for the NoOccInfo
1169 (con, bndrs', Let (NonRec scrut_var2 scrut_rhs) rhs'))
1171 scrut_var1 = mkLocalId (localiseName (idName scrut_var)) (idType scrut_var)
1172 -- Localise the scrut_var before shadowing it; we're making a
1173 -- new binding for it, and it might have an External Name, or
1174 -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
1175 -- Also we don't want any INLILNE or NOINLINE pragmas!
1177 (usg_wo_scrut, scrut_var2) = tagBinder alt_usg scrut_var1
1178 shadowing bndr = bndr `elemVarSet` rhs_fvs
1179 rhs_fvs = exprFreeVars scrut_rhs
1181 _other -> (alt_usg, (con, bndrs', rhs')) }
1185 %************************************************************************
1187 \subsection[OccurAnal-types]{OccEnv}
1189 %************************************************************************
1193 = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
1194 , occ_ctxt :: !CtxtTy -- Tells about linearity
1195 , occ_scrut_ids :: !GblScrutIds }
1197 type GblScrutIds = IdSet -- GlobalIds that are scrutinised, and for which
1198 -- we want to gather occurence info; see
1199 -- Note [Binder swap for GlobalId scrutinee]
1200 -- No need to prune this if there's a shadowing binding
1201 -- because it's OK for it to be too big
1203 -- OccEncl is used to control whether to inline into constructor arguments
1205 -- x = (p,q) -- Don't inline p or q
1206 -- y = /\a -> (p a, q a) -- Still don't inline p or q
1207 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
1208 -- So OccEncl tells enought about the context to know what to do when
1209 -- we encounter a contructor application or PAP.
1212 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
1213 -- Don't inline into constructor args here
1214 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
1215 -- Do inline into constructor args here
1217 type CtxtTy = [Bool]
1220 -- True:ctxt Analysing a function-valued expression that will be
1221 -- applied just once
1223 -- False:ctxt Analysing a function-valued expression that may
1224 -- be applied many times; but when it is,
1225 -- the CtxtTy inside applies
1227 initOccEnv :: OccEnv
1228 initOccEnv = OccEnv { occ_encl = OccVanilla
1230 , occ_scrut_ids = emptyVarSet }
1232 vanillaCtxt :: OccEnv -> OccEnv
1233 vanillaCtxt env = OccEnv { occ_encl = OccVanilla, occ_ctxt = []
1234 , occ_scrut_ids = occ_scrut_ids env }
1236 rhsCtxt :: OccEnv -> OccEnv
1237 rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = []
1238 , occ_scrut_ids = occ_scrut_ids env }
1240 mkAltEnv :: OccEnv -> Maybe (Id, CoreExpr) -> OccEnv
1241 -- Does two things: a) makes the occ_ctxt = OccVanilla
1242 -- b) extends the scrut_ids if necessary
1243 mkAltEnv env (Just (scrut_id, _))
1244 | not (isLocalId scrut_id)
1245 = OccEnv { occ_encl = OccVanilla
1246 , occ_scrut_ids = extendVarSet (occ_scrut_ids env) scrut_id
1247 , occ_ctxt = occ_ctxt env }
1249 | isRhsEnv env = env { occ_encl = OccVanilla }
1252 setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
1253 setCtxtTy env ctxt = env { occ_ctxt = ctxt }
1255 isRhsEnv :: OccEnv -> Bool
1256 isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
1257 isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
1259 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
1260 -- The result binders have one-shot-ness set that they might not have had originally.
1261 -- This happens in (build (\cn -> e)). Here the occurrence analyser
1262 -- linearity context knows that c,n are one-shot, and it records that fact in
1263 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
1265 oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs
1268 go _ [] rev_bndrs = reverse rev_bndrs
1270 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
1271 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
1273 bndr' | lin_ctxt = setOneShotLambda bndr
1276 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1278 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1279 addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
1280 = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }
1283 %************************************************************************
1285 \subsection[OccurAnal-types]{OccEnv}
1287 %************************************************************************
1290 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
1291 -- INVARIANT: never IAmDead
1292 -- (Deadness is signalled by not being in the map at all)
1294 (+++), combineAltsUsageDetails
1295 :: UsageDetails -> UsageDetails -> UsageDetails
1298 = plusVarEnv_C addOccInfo usage1 usage2
1300 combineAltsUsageDetails usage1 usage2
1301 = plusVarEnv_C orOccInfo usage1 usage2
1303 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1304 addOneOcc usage id info
1305 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1306 -- ToDo: make this more efficient
1308 emptyDetails :: UsageDetails
1309 emptyDetails = (emptyVarEnv :: UsageDetails)
1311 localUsedIn, usedIn :: Id -> UsageDetails -> Bool
1312 v `localUsedIn` details = v `elemVarEnv` details
1313 v `usedIn` details = isExportedId v || v `localUsedIn` details
1315 type IdWithOccInfo = Id
1317 tagLamBinders :: UsageDetails -- Of scope
1319 -> (UsageDetails, -- Details with binders removed
1320 [IdWithOccInfo]) -- Tagged binders
1321 -- Used for lambda and case binders
1322 -- It copes with the fact that lambda bindings can have InlineRule
1323 -- unfoldings, used for join points
1324 tagLamBinders usage binders = usage' `seq` (usage', bndrs')
1326 (usage', bndrs') = mapAccumR tag_lam usage binders
1327 tag_lam usage bndr = (usage2, setBinderOcc usage bndr)
1329 usage1 = usage `delVarEnv` bndr
1330 usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr)
1331 | otherwise = usage1
1333 tagBinder :: UsageDetails -- Of scope
1335 -> (UsageDetails, -- Details with binders removed
1336 IdWithOccInfo) -- Tagged binders
1338 tagBinder usage binder
1340 usage' = usage `delVarEnv` binder
1341 binder' = setBinderOcc usage binder
1343 usage' `seq` (usage', binder')
1345 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1346 setBinderOcc usage bndr
1347 | isTyVar bndr = bndr
1348 | isExportedId bndr = case idOccInfo bndr of
1350 _ -> setIdOccInfo bndr NoOccInfo
1351 -- Don't use local usage info for visible-elsewhere things
1352 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1353 -- about to re-generate it and it shouldn't be "sticky"
1355 | otherwise = setIdOccInfo bndr occ_info
1357 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1361 %************************************************************************
1363 \subsection{Operations over OccInfo}
1365 %************************************************************************
1368 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1369 mkOneOcc env id int_cxt
1370 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1371 | id `elemVarSet` occ_scrut_ids env = unitVarEnv id NoOccInfo
1372 | otherwise = emptyDetails
1374 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1376 markMany _ = NoOccInfo
1378 markInsideSCC occ = markMany occ
1380 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1381 markInsideLam occ = occ
1383 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1385 addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
1386 NoOccInfo -- Both branches are at least One
1387 -- (Argument is never IAmDead)
1389 -- (orOccInfo orig new) is used
1390 -- when combining occurrence info from branches of a case
1392 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1393 (OneOcc in_lam2 _ int_cxt2)
1394 = OneOcc (in_lam1 || in_lam2)
1395 False -- False, because it occurs in both branches
1396 (int_cxt1 && int_cxt2)
1397 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )