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 )
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] -> [CoreBind]
54 = snd (go initOccEnv binds)
56 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
60 = (final_usage, bind' ++ binds')
62 (bs_usage, binds') = go env binds
63 (final_usage, bind') = occAnalBind env bind bs_usage
65 occurAnalyseExpr :: CoreExpr -> CoreExpr
66 -- Do occurrence analysis, and discard occurence info returned
67 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
71 %************************************************************************
73 \subsection[OccurAnal-main]{Counting occurrences: main function}
75 %************************************************************************
83 -> UsageDetails -- Usage details of scope
84 -> (UsageDetails, -- Of the whole let(rec)
87 occAnalBind env (NonRec binder rhs) body_usage
88 | isTyVar binder -- A type let; we don't gather usage info
89 = (body_usage, [NonRec binder rhs])
91 | not (binder `usedIn` body_usage) -- It's not mentioned
94 | otherwise -- It's mentioned in the body
95 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
96 [NonRec tagged_binder rhs'])
98 (body_usage', tagged_binder) = tagBinder body_usage binder
99 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
104 Dropping dead code for recursive bindings is done in a very simple way:
106 the entire set of bindings is dropped if none of its binders are
107 mentioned in its body; otherwise none are.
109 This seems to miss an obvious improvement.
121 Now 'f' is unused! But it's OK! Dependency analysis will sort this
122 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
123 dropped. It isn't easy to do a perfect job in one blow. Consider
134 Note [Loop breaking and RULES]
135 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
136 Loop breaking is surprisingly subtle. First read the section 4 of
137 "Secrets of the GHC inliner". This describes our basic plan.
139 However things are made quite a bit more complicated by RULES. Remember
141 * Note [Rules are extra RHSs]
142 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
143 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
144 keeps the specialised "children" alive. If the parent dies
145 (because it isn't referenced any more), then the children will die
146 too (unless they are already referenced directly).
148 To that end, we build a Rec group for each cyclic strongly
150 *treating f's rules as extra RHSs for 'f'*.
152 When we make the Rec groups we include variables free in *either*
153 LHS *or* RHS of the rule. The former might seems silly, but see
154 Note [Rule dependency info].
156 So in Example [eftInt], eftInt and eftIntFB will be put in the
157 same Rec, even though their 'main' RHSs are both non-recursive.
159 * Note [Rules are visible in their own rec group]
160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
161 We want the rules for 'f' to be visible in f's right-hand side.
162 And we'd like them to be visible in other functions in f's Rec
163 group. E.g. in Example [Specialisation rules] we want f' rule
164 to be visible in both f's RHS, and fs's RHS.
166 This means that we must simplify the RULEs first, before looking
167 at any of the definitions. This is done by Simplify.simplRecBind,
168 when it calls addLetIdInfo.
170 * Note [Choosing loop breakers]
171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
172 We avoid infinite inlinings by choosing loop breakers, and
173 ensuring that a loop breaker cuts each loop. But what is a
174 "loop"? In particular, a RULE is like an equation for 'f' that
175 is *always* inlined if it is applicable. We do *not* disable
176 rules for loop-breakers. It's up to whoever makes the rules to
177 make sure that the rules themselves alwasys terminate. See Note
178 [Rules for recursive functions] in Simplify.lhs
181 f's RHS mentions g, and
182 g has a RULE that mentions h, and
183 h has a RULE that mentions f
185 then we *must* choose f to be a loop breaker. In general, take the
186 free variables of f's RHS, and augment it with all the variables
187 reachable by RULES from those starting points. That is the whole
188 reason for computing rule_fv_env in occAnalBind. (Of course we
189 only consider free vars that are also binders in this Rec group.)
191 Note that when we compute this rule_fv_env, we only consider variables
192 free in the *RHS* of the rule, in contrast to the way we build the
193 Rec group in the first place (Note [Rule dependency info])
195 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
196 chosen as a loop breaker, because their RHSs don't mention each other.
197 And indeed both can be inlined safely.
199 Note that the edges of the graph we use for computing loop breakers
200 are not the same as the edges we use for computing the Rec blocks.
201 That's why we compute
202 rec_edges for the Rec block analysis
203 loop_breaker_edges for the loop breaker analysis
206 * Note [Weak loop breakers]
207 ~~~~~~~~~~~~~~~~~~~~~~~~~
208 There is a last nasty wrinkle. Suppose we have
218 Remmber that we simplify the RULES before any RHS (see Note
219 [Rules are visible in their own rec group] above).
221 So we must *not* postInlineUnconditionally 'g', even though
222 its RHS turns out to be trivial. (I'm assuming that 'g' is
223 not choosen as a loop breaker.)
225 We "solve" this by making g a "weak" or "rules-only" loop breaker,
226 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
227 has IAmLoopBreaker False. So
229 Inline postInlineUnconditinoally
230 IAmLoopBreaker False no no
231 IAmLoopBreaker True yes no
234 The **sole** reason for this kind of loop breaker is so that
235 postInlineUnconditionally does not fire. Ugh.
237 * Note [Rule dependency info]
238 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
239 The VarSet in a SpecInfo is used for dependency analysis in the
240 occurrence analyser. We must track free vars in *both* lhs and rhs.
241 Hence use of idRuleVars, rather than idRuleRhsVars in addRuleUsage.
245 Then if we substitute y for x, we'd better do so in the
246 rule's LHS too, so we'd better ensure the dependency is respected
251 Example (from GHC.Enum):
253 eftInt :: Int# -> Int# -> [Int]
254 eftInt x y = ...(non-recursive)...
256 {-# INLINE [0] eftIntFB #-}
257 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
258 eftIntFB c n x y = ...(non-recursive)...
261 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
262 "eftIntList" [1] eftIntFB (:) [] = eftInt
265 Example [Specialisation rules]
266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
267 Consider this group, which is typical of what SpecConstr builds:
269 fs a = ....f (C a)....
270 f x = ....f (C a)....
271 {-# RULE f (C a) = fs a #-}
273 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
275 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
276 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
277 - fs is inlined (say it's small)
278 - now there's another opportunity to apply the RULE
280 This showed up when compiling Control.Concurrent.Chan.getChanContents.
284 occAnalBind env (Rec pairs) body_usage
285 = foldr occAnalRec (body_usage, []) sccs
286 -- For a recursive group, we
287 -- * occ-analyse all the RHSs
288 -- * compute strongly-connected components
289 -- * feed those components to occAnalRec
291 -------------Dependency analysis ------------------------------
292 bndr_set = mkVarSet (map fst pairs)
294 sccs :: [SCC (Node Details)]
295 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges
297 rec_edges :: [Node Details]
298 rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
300 make_node (bndr, rhs)
301 = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
303 (rhs_usage, rhs') = occAnalRhs env bndr rhs
304 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
305 out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
306 -- (a -> b) means a mentions b
307 -- Given the usage details (a UFM that gives occ info for each free var of
308 -- the RHS) we can get the list of free vars -- or rather their Int keys --
309 -- by just extracting the keys from the finite map. Grimy, but fast.
310 -- Previously we had this:
311 -- [ bndr | bndr <- bndrs,
312 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
313 -- which has n**2 cost, and this meant that edges_from alone
314 -- consumed 10% of total runtime!
316 -----------------------------
317 occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
318 -> (UsageDetails, [CoreBind])
320 -- The NonRec case is just like a Let (NonRec ...) above
321 occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
322 | not (bndr `usedIn` body_usage)
323 = (body_usage, binds)
325 | otherwise -- It's mentioned in the body
326 = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs]
327 NonRec tagged_bndr rhs : binds)
329 (body_usage', tagged_bndr) = tagBinder body_usage bndr
332 -- The Rec case is the interesting one
333 -- See Note [Loop breaking]
334 occAnalRec (CyclicSCC nodes) (body_usage, binds)
335 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
336 = (body_usage, binds) -- Dead code
338 | otherwise -- At this point we always build a single Rec
339 = (final_usage, Rec pairs : binds)
342 bndrs = [b | (ND b _ _ _, _, _) <- nodes]
343 bndr_set = mkVarSet bndrs
345 ----------------------------
346 -- Tag the binders with their occurrence info
347 total_usage = foldl add_usage body_usage nodes
348 add_usage body_usage (ND bndr _ rhs_usage _, _, _)
349 = body_usage +++ addRuleUsage rhs_usage bndr
350 (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
352 tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
353 -- (a) Tag the binders in the details with occ info
354 -- (b) Mark the binder with "weak loop-breaker" OccInfo
355 -- saying "no preInlineUnconditionally" if it is used
356 -- in any rule (lhs or rhs) of the recursive group
357 -- See Note [Weak loop breakers]
358 tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
359 = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
361 bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
363 bndr1 = setBinderOcc usage bndr
364 all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
367 ----------------------------
368 -- Now reconstruct the cycle
369 pairs | no_rules = reOrderCycle 0 tagged_nodes []
370 | otherwise = foldr (reOrderRec 0) [] $
371 stronglyConnCompFromEdgedVerticesR loop_breaker_edges
373 -- See Note [Choosing loop breakers] for looop_breaker_edges
374 loop_breaker_edges = map mk_node tagged_nodes
375 mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
377 new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
379 ------------------------------------
380 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
381 -- Domain is *subset* of bound vars (others have no rule fvs)
382 rule_fv_env = rule_loop init_rule_fvs
384 no_rules = null init_rule_fvs
385 init_rule_fvs = [(b, rule_fvs)
387 , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
388 , not (isEmptyVarSet rule_fvs)]
390 rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
393 | otherwise = rule_loop new_fv_list
395 env = mkVarEnv init_rule_fvs
396 (no_change, new_fv_list) = mapAccumL bump True fv_list
397 bump no_change (b,fvs)
398 | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
399 | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
401 new_fvs = extendFvs env emptyVarSet fvs
403 idRuleRhsVars :: Id -> VarSet
404 -- Just the variables free on the *rhs* of a rule
405 -- See Note [Choosing loop breakers]
406 idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
408 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
409 -- (extendFVs env fvs s) returns (fvs `union` env(s))
410 extendFvs env fvs id_set
411 = foldUFM_Directly add fvs id_set
414 = case lookupVarEnv_Directly env uniq of
415 Just fvs' -> fvs' `unionVarSet` fvs
419 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
420 strongly connected component (there's guaranteed to be a cycle). It returns the
422 a) in a better order,
423 b) with some of the Ids having a IAmALoopBreaker pragma
425 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
426 that the simplifier can guarantee not to loop provided it never records an inlining
427 for these no-inline guys.
429 Furthermore, the order of the binds is such that if we neglect dependencies
430 on the no-inline Ids then the binds are topologically sorted. This means
431 that the simplifier will generally do a good job if it works from top bottom,
432 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
435 [June 98: I don't understand the following paragraphs, and I've
436 changed the a=b case again so that it isn't a special case any more.]
438 Here's a case that bit me:
446 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
448 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
449 Perhaps something cleverer would suffice.
454 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
455 -- which is gotten from the Id.
456 data Details = ND Id -- Binder
458 UsageDetails -- Full usage from RHS (*not* including rules)
459 IdSet -- Other binders from this Rec group mentioned on RHS
460 -- (derivable from UsageDetails but cached here)
462 reOrderRec :: Int -> SCC (Node Details)
463 -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
464 -- Sorted into a plausible order. Enough of the Ids have
465 -- IAmALoopBreaker pragmas that there are no loops left.
466 reOrderRec _ (AcyclicSCC (ND bndr rhs _ _, _, _)) pairs = (bndr, rhs) : pairs
467 reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
469 reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
471 = panic "reOrderCycle"
472 reOrderCycle _ [bind] pairs -- Common case of simple self-recursion
473 = (makeLoopBreaker False bndr, rhs) : pairs
475 (ND bndr rhs _ _, _, _) = bind
477 reOrderCycle depth (bind : binds) pairs
478 = -- Choose a loop breaker, mark it no-inline,
479 -- do SCC analysis on the rest, and recursively sort them out
480 -- pprTrace "reOrderCycle" (ppr [b | (ND b _ _ _, _, _) <- bind:binds]) $
481 foldr (reOrderRec new_depth)
482 ([ (makeLoopBreaker False bndr, rhs)
483 | (ND bndr rhs _ _, _, _) <- chosen_binds] ++ pairs)
484 (stronglyConnCompFromEdgedVerticesR unchosen)
486 (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds
488 approximate_loop_breaker = depth >= 2
489 new_depth | approximate_loop_breaker = 0
490 | otherwise = depth+1
491 -- After two iterations (d=0, d=1) give up
492 -- and approximate, returning to d=0
494 -- This loop looks for the bind with the lowest score
495 -- to pick as the loop breaker. The rest accumulate in
496 choose_loop_breaker loop_binds _loop_sc acc []
497 = (loop_binds, acc) -- Done
499 -- If approximate_loop_breaker is True, we pick *all*
500 -- nodes with lowest score, else just one
501 -- See Note [Complexity of loop breaking]
502 choose_loop_breaker loop_binds loop_sc acc (bind : binds)
503 | sc < loop_sc -- Lower score so pick this new one
504 = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds
506 | approximate_loop_breaker && sc == loop_sc
507 = choose_loop_breaker (bind : loop_binds) loop_sc acc binds
509 | otherwise -- Higher score so don't pick it
510 = choose_loop_breaker loop_binds loop_sc (bind : acc) binds
514 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
515 score (ND bndr rhs _ _, _, _)
516 | workerExists (idWorkerInfo bndr) = 10
517 -- Note [Worker inline loop]
519 | exprIsTrivial rhs = 5 -- Practically certain to be inlined
520 -- Used to have also: && not (isExportedId bndr)
521 -- But I found this sometimes cost an extra iteration when we have
522 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
523 -- where df is the exported dictionary. Then df makes a really
524 -- bad choice for loop breaker
526 | is_con_app rhs = 3 -- Data types help with cases
527 -- Note [Constructor applictions]
529 -- If an Id is marked "never inline" then it makes a great loop breaker
530 -- The only reason for not checking that here is that it is rare
531 -- and I've never seen a situation where it makes a difference,
532 -- so it probably isn't worth the time to test on every binder
533 -- | isNeverActive (idInlinePragma bndr) = -10
535 | inlineCandidate bndr rhs = 2 -- Likely to be inlined
536 -- Note [Inline candidates]
538 | not (neverUnfold (idUnfolding bndr)) = 1
539 -- the Id has some kind of unfolding
543 inlineCandidate :: Id -> CoreExpr -> Bool
544 inlineCandidate _ (Note InlineMe _) = True
545 inlineCandidate id _ = isOneOcc (idOccInfo id)
549 -- It's really really important to inline dictionaries. Real
550 -- example (the Enum Ordering instance from GHC.Base):
552 -- rec f = \ x -> case d of (p,q,r) -> p x
553 -- g = \ x -> case d of (p,q,r) -> q x
556 -- Here, f and g occur just once; but we can't inline them into d.
557 -- On the other hand we *could* simplify those case expressions if
558 -- we didn't stupidly choose d as the loop breaker.
559 -- But we won't because constructor args are marked "Many".
560 -- Inlining dictionaries is really essential to unravelling
561 -- the loops in static numeric dictionaries, see GHC.Float.
563 -- Cheap and cheerful; the simplifer moves casts out of the way
564 -- The lambda case is important to spot x = /\a. C (f a)
565 -- which comes up when C is a dictionary constructor and
566 -- f is a default method.
567 -- Example: the instance for Show (ST s a) in GHC.ST
569 -- However we *also* treat (\x. C p q) as a con-app-like thing,
570 -- Note [Closure conversion]
571 is_con_app (Var v) = isDataConWorkId v
572 is_con_app (App f _) = is_con_app f
573 is_con_app (Lam _ e) = is_con_app e
574 is_con_app (Note _ e) = is_con_app e
577 makeLoopBreaker :: Bool -> Id -> Id
578 -- Set the loop-breaker flag: see Note [Weak loop breakers]
579 makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
582 Note [Complexity of loop breaking]
583 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
584 The loop-breaking algorithm knocks out one binder at a time, and
585 performs a new SCC analysis on the remaining binders. That can
586 behave very badly in tightly-coupled groups of bindings; in the
587 worst case it can be (N**2)*log N, because it does a full SCC
588 on N, then N-1, then N-2 and so on.
590 To avoid this, we switch plans after 2 (or whatever) attempts:
591 Plan A: pick one binder with the lowest score, make it
592 a loop breaker, and try again
593 Plan B: pick *all* binders with the lowest score, make them
594 all loop breakers, and try again
595 Since there are only a small finite number of scores, this will
596 terminate in a constant number of iterations, rather than O(N)
599 You might thing that it's very unlikely, but RULES make it much
600 more likely. Here's a real example from Trac #1969:
601 Rec { $dm = \d.\x. op d
602 {-# RULES forall d. $dm Int d = $s$dm1
603 forall d. $dm Bool d = $s$dm2 #-}
605 dInt = MkD .... opInt ...
606 dInt = MkD .... opBool ...
611 $s$dm2 = \x. op dBool }
612 The RULES stuff means that we can't choose $dm as a loop breaker
613 (Note [Choosing loop breakers]), so we must choose at least (say)
614 opInt *and* opBool, and so on. The number of loop breakders is
615 linear in the number of instance declarations.
617 Note [INLINE pragmas]
618 ~~~~~~~~~~~~~~~~~~~~~
619 Never choose a function with an INLINE pramga as the loop breaker!
620 If such a function is mutually-recursive with a non-INLINE thing,
621 then the latter should be the loop-breaker.
623 A particular case is wrappers generated by the demand analyser.
624 If you make then into a loop breaker you may get an infinite
625 inlining loop. For example:
627 $wfoo x = ....foo x....
629 {-loop brk-} foo x = ...$wfoo x...
631 The interface file sees the unfolding for $wfoo, and sees that foo is
632 strict (and hence it gets an auto-generated wrapper). Result: an
633 infinite inlining in the importing scope. So be a bit careful if you
634 change this. A good example is Tree.repTree in
635 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
636 breaker then compiling Game.hs goes into an infinite loop (this
637 happened when we gave is_con_app a lower score than inline candidates).
639 Note [Constructor applications]
640 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
641 It's really really important to inline dictionaries. Real
642 example (the Enum Ordering instance from GHC.Base):
644 rec f = \ x -> case d of (p,q,r) -> p x
645 g = \ x -> case d of (p,q,r) -> q x
648 Here, f and g occur just once; but we can't inline them into d.
649 On the other hand we *could* simplify those case expressions if
650 we didn't stupidly choose d as the loop breaker.
651 But we won't because constructor args are marked "Many".
652 Inlining dictionaries is really essential to unravelling
653 the loops in static numeric dictionaries, see GHC.Float.
655 Note [Closure conversion]
656 ~~~~~~~~~~~~~~~~~~~~~~~~~
657 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
658 The immediate motivation came from the result of a closure-conversion transformation
659 which generated code like this:
661 data Clo a b = forall c. Clo (c -> a -> b) c
663 ($:) :: Clo a b -> a -> b
664 Clo f env $: x = f env x
666 rec { plus = Clo plus1 ()
668 ; plus1 _ n = Clo plus2 n
671 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
673 If we inline 'plus' and 'plus1', everything unravels nicely. But if
674 we choose 'plus1' as the loop breaker (which is entirely possible
675 otherwise), the loop does not unravel nicely.
678 @occAnalRhs@ deals with the question of bindings where the Id is marked
679 by an INLINE pragma. For these we record that anything which occurs
680 in its RHS occurs many times. This pessimistically assumes that ths
681 inlined binder also occurs many times in its scope, but if it doesn't
682 we'll catch it next time round. At worst this costs an extra simplifier pass.
683 ToDo: try using the occurrence info for the inline'd binder.
685 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
686 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
691 -> Id -> CoreExpr -- Binder and rhs
692 -- For non-recs the binder is alrady tagged
693 -- with occurrence info
694 -> (UsageDetails, CoreExpr)
696 occAnalRhs env id rhs
699 ctxt | certainly_inline id = env
700 | otherwise = rhsCtxt env
701 -- Note that we generally use an rhsCtxt. This tells the occ anal n
702 -- that it's looking at an RHS, which has an effect in occAnalApp
704 -- But there's a problem. Consider
709 -- First time round, it looks as if x1 and x2 occur as an arg of a
710 -- let-bound constructor ==> give them a many-occurrence.
711 -- But then x3 is inlined (unconditionally as it happens) and
712 -- next time round, x2 will be, and the next time round x1 will be
713 -- Result: multiple simplifier iterations. Sigh.
714 -- Crude solution: use rhsCtxt for things that occur just once...
716 certainly_inline id = case idOccInfo id of
717 OneOcc in_lam one_br _ -> not in_lam && one_br
724 addRuleUsage :: UsageDetails -> Id -> UsageDetails
725 -- Add the usage from RULES in Id to the usage
726 addRuleUsage usage id
727 = foldVarSet add usage (idRuleVars id)
728 -- idRuleVars here: see Note [Rule dependency info]
730 add v u = addOneOcc u v NoOccInfo
731 -- Give a non-committal binder info (i.e manyOcc) because
732 -- a) Many copies of the specialised thing can appear
733 -- b) We don't want to substitute a BIG expression inside a RULE
734 -- even if that's the only occurrence of the thing
735 -- (Same goes for INLINE.)
743 -> (UsageDetails, -- Gives info only about the "interesting" Ids
746 occAnal _ (Type t) = (emptyDetails, Type t)
747 occAnal env (Var v) = (mkOneOcc env v False, Var v)
748 -- At one stage, I gathered the idRuleVars for v here too,
749 -- which in a way is the right thing to do.
750 -- But that went wrong right after specialisation, when
751 -- the *occurrences* of the overloaded function didn't have any
752 -- rules in them, so the *specialised* versions looked as if they
753 -- weren't used at all.
756 We regard variables that occur as constructor arguments as "dangerousToDup":
760 f x = let y = expensive x in
762 (case z of {(p,q)->q}, case z of {(p,q)->q})
765 We feel free to duplicate the WHNF (True,y), but that means
766 that y may be duplicated thereby.
768 If we aren't careful we duplicate the (expensive x) call!
769 Constructors are rather like lambdas in this way.
772 occAnal _ expr@(Lit _) = (emptyDetails, expr)
776 occAnal env (Note InlineMe body)
777 = case occAnal env body of { (usage, body') ->
778 (mapVarEnv markMany usage, Note InlineMe body')
781 occAnal env (Note note@(SCC _) body)
782 = case occAnal env body of { (usage, body') ->
783 (mapVarEnv markInsideSCC usage, Note note body')
786 occAnal env (Note note body)
787 = case occAnal env body of { (usage, body') ->
788 (usage, Note note body')
791 occAnal env (Cast expr co)
792 = case occAnal env expr of { (usage, expr') ->
793 (markRhsUds env True usage, Cast expr' co)
794 -- If we see let x = y `cast` co
795 -- then mark y as 'Many' so that we don't
796 -- immediately inline y again.
801 occAnal env app@(App _ _)
802 = occAnalApp env (collectArgs app)
804 -- Ignore type variables altogether
805 -- (a) occurrences inside type lambdas only not marked as InsideLam
806 -- (b) type variables not in environment
808 occAnal env (Lam x body) | isTyVar x
809 = case occAnal env body of { (body_usage, body') ->
810 (body_usage, Lam x body')
813 -- For value lambdas we do a special hack. Consider
815 -- If we did nothing, x is used inside the \y, so would be marked
816 -- as dangerous to dup. But in the common case where the abstraction
817 -- is applied to two arguments this is over-pessimistic.
818 -- So instead, we just mark each binder with its occurrence
819 -- info in the *body* of the multiple lambda.
820 -- Then, the simplifier is careful when partially applying lambdas.
822 occAnal env expr@(Lam _ _)
823 = case occAnal env_body body of { (body_usage, body') ->
825 (final_usage, tagged_binders) = tagBinders body_usage binders
826 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
827 -- we get linear-typed things in the resulting program that we can't handle yet.
828 -- (e.g. PrelShow) TODO
830 really_final_usage = if linear then
833 mapVarEnv markInsideLam final_usage
836 mkLams tagged_binders body') }
838 env_body = vanillaCtxt env -- Body is (no longer) an RhsContext
839 (binders, body) = collectBinders expr
840 binders' = oneShotGroup env binders
841 linear = all is_one_shot binders'
842 is_one_shot b = isId b && isOneShotBndr b
844 occAnal env (Case scrut bndr ty alts)
845 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
846 case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
848 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
849 alts_usage' = addCaseBndrUsage alts_usage
850 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
851 total_usage = scrut_usage +++ alts_usage1
853 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
855 -- Note [Case binder usage]
856 -- ~~~~~~~~~~~~~~~~~~~~~~~~
857 -- The case binder gets a usage of either "many" or "dead", never "one".
858 -- Reason: we like to inline single occurrences, to eliminate a binding,
859 -- but inlining a case binder *doesn't* eliminate a binding.
860 -- We *don't* want to transform
861 -- case x of w { (p,q) -> f w }
863 -- case x of w { (p,q) -> f (p,q) }
864 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
866 Just _ -> extendVarEnv usage bndr NoOccInfo
868 alt_env = mkAltEnv env bndr_swap
869 -- Consider x = case v of { True -> (p,q); ... }
870 -- Then it's fine to inline p and q
872 bndr_swap = case scrut of
873 Var v -> Just (v, Var bndr)
874 Cast (Var v) co -> Just (v, Cast (Var bndr) (mkSymCoercion co))
877 occ_anal_alt = occAnalAlt alt_env bndr bndr_swap
879 occ_anal_scrut (Var v) (alt1 : other_alts)
880 | not (null other_alts) || not (isDefaultAlt alt1)
881 = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs
882 -- in an interesting context; the case has
883 -- at least one non-default alternative
884 occ_anal_scrut scrut _alts
885 = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt
887 occAnal env (Let bind body)
888 = case occAnal env body of { (body_usage, body') ->
889 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
890 (final_usage, mkLets new_binds body') }}
892 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
894 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
895 (foldr (+++) emptyDetails arg_uds_s, args')}
897 arg_env = vanillaCtxt env
900 Applications are dealt with specially because we want
901 the "build hack" to work.
905 -> (Expr CoreBndr, [Arg CoreBndr])
906 -> (UsageDetails, Expr CoreBndr)
907 occAnalApp env (Var fun, args)
908 = case args_stuff of { (args_uds, args') ->
910 final_args_uds = markRhsUds env is_pap args_uds
912 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
914 fun_uniq = idUnique fun
915 fun_uds = mkOneOcc env fun (valArgCount args > 0)
916 is_pap = isConLikeId fun || valArgCount args < idArity fun
918 -- Hack for build, fold, runST
919 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
920 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
921 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
922 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
923 -- (foldr k z xs) may call k many times, but it never
924 -- shares a partial application of k; hence [False,True]
925 -- This means we can optimise
926 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
927 -- by floating in the v
929 | otherwise = occAnalArgs env args
932 occAnalApp env (fun, args)
933 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
934 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
935 -- often leaves behind beta redexs like
937 -- Here we would like to mark x,y as one-shot, and treat the whole
938 -- thing much like a let. We do this by pushing some True items
939 -- onto the context stack.
941 case occAnalArgs env args of { (args_uds, args') ->
943 final_uds = fun_uds +++ args_uds
945 (final_uds, mkApps fun' args') }}
948 markRhsUds :: OccEnv -- Check if this is a RhsEnv
949 -> Bool -- and this is true
950 -> UsageDetails -- The do markMany on this
952 -- We mark the free vars of the argument of a constructor or PAP
953 -- as "many", if it is the RHS of a let(rec).
954 -- This means that nothing gets inlined into a constructor argument
955 -- position, which is what we want. Typically those constructor
956 -- arguments are just variables, or trivial expressions.
958 -- This is the *whole point* of the isRhsEnv predicate
959 markRhsUds env is_pap arg_uds
960 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
961 | otherwise = arg_uds
965 -> Int -> CtxtTy -- Argument number, and context to use for it
967 -> (UsageDetails, [CoreExpr])
968 appSpecial env n ctxt args
971 arg_env = vanillaCtxt env
973 go _ [] = (emptyDetails, []) -- Too few args
975 go 1 (arg:args) -- The magic arg
976 = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') ->
977 case occAnalArgs env args of { (args_uds, args') ->
978 (arg_uds +++ args_uds, arg':args') }}
981 = case occAnal arg_env arg of { (arg_uds, arg') ->
982 case go (n-1) args of { (args_uds, args') ->
983 (arg_uds +++ args_uds, arg':args') }}
989 We do these two transformations right here:
991 (1) case x of b { pi -> ri }
993 case x of b { pi -> let x=b in ri }
995 (2) case (x |> co) of b { pi -> ri }
997 case (x |> co) of b { pi -> let x = b |> sym co in ri }
999 Why (2)? See Note [Case of cast]
1001 In both cases, in a particular alternative (pi -> ri), we only
1003 (a) x occurs free in (pi -> ri)
1004 (ie it occurs in ri, but is not bound in pi)
1005 (b) the pi does not bind b (or the free vars of co)
1006 We need (a) and (b) for the inserted binding to be correct.
1008 For the alternatives where we inject the binding, we can transfer
1009 all x's OccInfo to b. And that is the point.
1012 * The deliberate shadowing of 'x'.
1013 * That (a) rapidly becomes false, so no bindings are injected.
1015 The reason for doing these transformations here is because it allows
1016 us to adjust the OccInfo for 'x' and 'b' as we go.
1018 * Suppose the only occurrences of 'x' are the scrutinee and in the
1019 ri; then this transformation makes it occur just once, and hence
1020 get inlined right away.
1022 * If we do this in the Simplifier, we don't know whether 'x' is used
1023 in ri, so we are forced to pessimistically zap b's OccInfo even
1024 though it is typically dead (ie neither it nor x appear in the
1025 ri). There's nothing actually wrong with zapping it, except that
1026 it's kind of nice to know which variables are dead. My nose
1027 tells me to keep this information as robustly as possible.
1029 The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
1030 {x=b}; it's Nothing if the binder-swap doesn't happen.
1032 There is a danger though. Consider
1034 in case (f v) of w -> ...v...v...
1035 And suppose that (f v) expands to just v. Then we'd like to
1036 use 'w' instead of 'v' in the alternative. But it may be too
1037 late; we may have substituted the (cheap) x+#y for v in the
1038 same simplifier pass that reduced (f v) to v.
1040 I think this is just too bad. CSE will recover some of it.
1042 Note [Binder swap on GlobalId scrutinees]
1043 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1044 When the scrutinee is a GlobalId we must take care in two ways
1046 i) In order to *know* whether 'x' occurs free in the RHS, we need its
1047 occurrence info. BUT, we don't gather occurrence info for
1048 GlobalIds. That's what the (small) occ_scrut_ids set in OccEnv is
1049 for: it says "gather occurrence info for these.
1051 ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
1052 has an External Name. See, for example, SimplEnv Note [Global Ids in
1055 Historical note [no-case-of-case]
1056 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1057 We *used* to suppress the binder-swap in case expressoins when
1058 -fno-case-of-case is on. Old remarks:
1059 "This happens in the first simplifier pass,
1060 and enhances full laziness. Here's the bad case:
1061 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1062 If we eliminate the inner case, we trap it inside the I# v -> arm,
1063 which might prevent some full laziness happening. I've seen this
1064 in action in spectral/cichelli/Prog.hs:
1065 [(m,n) | m <- [1..max], n <- [1..max]]
1066 Hence the check for NoCaseOfCase."
1067 However, now the full-laziness pass itself reverses the binder-swap, so this
1068 check is no longer necessary.
1070 Historical note [Suppressing the case binder-swap]
1071 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1072 This old note describes a problem that is also fixed by doing the
1073 binder-swap in OccAnal:
1075 There is another situation when it might make sense to suppress the
1076 case-expression binde-swap. If we have
1078 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1079 ...other cases .... }
1081 We'll perform the binder-swap for the outer case, giving
1083 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1084 ...other cases .... }
1086 But there is no point in doing it for the inner case, because w1 can't
1087 be inlined anyway. Furthermore, doing the case-swapping involves
1088 zapping w2's occurrence info (see paragraphs that follow), and that
1089 forces us to bind w2 when doing case merging. So we get
1091 case x of w1 { A -> let w2 = w1 in e1
1092 B -> let w2 = w1 in e2
1093 ...other cases .... }
1095 This is plain silly in the common case where w2 is dead.
1097 Even so, I can't see a good way to implement this idea. I tried
1098 not doing the binder-swap if the scrutinee was already evaluated
1099 but that failed big-time:
1103 case v of w { MkT x ->
1104 case x of x1 { I# y1 ->
1105 case x of x2 { I# y2 -> ...
1107 Notice that because MkT is strict, x is marked "evaluated". But to
1108 eliminate the last case, we must either make sure that x (as well as
1109 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1110 the binder-swap. So this whole note is a no-op.
1112 It's fixed by doing the binder-swap in OccAnal because we can do the
1113 binder-swap unconditionally and still get occurrence analysis
1118 Consider case (x `cast` co) of b { I# ->
1119 ... (case (x `cast` co) of {...}) ...
1120 We'd like to eliminate the inner case. That is the motivation for
1121 equation (2) in Note [Binder swap]. When we get to the inner case, we
1122 inline x, cancel the casts, and away we go.
1124 Note [Binders in case alternatives]
1125 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1127 case x of y { (a,b) -> f y }
1128 We treat 'a', 'b' as dead, because they don't physically occur in the
1129 case alternative. (Indeed, a variable is dead iff it doesn't occur in
1130 its scope in the output of OccAnal.) This invariant is It really
1131 helpe to know when binders are unused. See esp the call to
1132 isDeadBinder in Simplify.mkDupableAlt
1134 In this example, though, the Simplifier will bring 'a' and 'b' back to
1135 life, beause it binds 'y' to (a,b) (imagine got inlined and
1139 occAnalAlt :: OccEnv
1141 -> Maybe (Id, CoreExpr) -- Note [Binder swap]
1143 -> (UsageDetails, Alt IdWithOccInfo)
1144 occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs)
1145 = case occAnal env rhs of { (rhs_usage, rhs') ->
1147 (alt_usg, tagged_bndrs) = tagBinders rhs_usage bndrs
1148 bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
1150 case mb_scrut_var of
1151 Just (scrut_var, scrut_rhs) -- See Note [Binder swap]
1152 | scrut_var `localUsedIn` alt_usg -- (a) Fast path, usually false
1153 , not (any shadowing bndrs) -- (b)
1154 -> (addOneOcc usg_wo_scrut case_bndr NoOccInfo,
1155 -- See Note [Case binder usage] for the NoOccInfo
1156 (con, bndrs', Let (NonRec scrut_var' scrut_rhs) rhs'))
1158 (usg_wo_scrut, scrut_var') = tagBinder alt_usg (localiseId scrut_var)
1159 -- Note the localiseId; we're making a new binding
1160 -- for it, and it might have an External Name, or
1161 -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
1162 shadowing bndr = bndr `elemVarSet` rhs_fvs
1163 rhs_fvs = exprFreeVars scrut_rhs
1165 _other -> (alt_usg, (con, bndrs', rhs')) }
1169 %************************************************************************
1171 \subsection[OccurAnal-types]{OccEnv}
1173 %************************************************************************
1177 = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
1178 , occ_ctxt :: !CtxtTy -- Tells about linearity
1179 , occ_scrut_ids :: !GblScrutIds }
1181 type GblScrutIds = IdSet -- GlobalIds that are scrutinised, and for which
1182 -- we want to gather occurence info; see
1183 -- Note [Binder swap for GlobalId scrutinee]
1184 -- No need to prune this if there's a shadowing binding
1185 -- because it's OK for it to be too big
1187 -- OccEncl is used to control whether to inline into constructor arguments
1189 -- x = (p,q) -- Don't inline p or q
1190 -- y = /\a -> (p a, q a) -- Still don't inline p or q
1191 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
1192 -- So OccEncl tells enought about the context to know what to do when
1193 -- we encounter a contructor application or PAP.
1196 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
1197 -- Don't inline into constructor args here
1198 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
1199 -- Do inline into constructor args here
1201 type CtxtTy = [Bool]
1204 -- True:ctxt Analysing a function-valued expression that will be
1205 -- applied just once
1207 -- False:ctxt Analysing a function-valued expression that may
1208 -- be applied many times; but when it is,
1209 -- the CtxtTy inside applies
1211 initOccEnv :: OccEnv
1212 initOccEnv = OccEnv { occ_encl = OccRhs
1214 , occ_scrut_ids = emptyVarSet }
1216 vanillaCtxt :: OccEnv -> OccEnv
1217 vanillaCtxt env = OccEnv { occ_encl = OccVanilla, occ_ctxt = []
1218 , occ_scrut_ids = occ_scrut_ids env }
1220 rhsCtxt :: OccEnv -> OccEnv
1221 rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = []
1222 , occ_scrut_ids = occ_scrut_ids env }
1224 mkAltEnv :: OccEnv -> Maybe (Id, CoreExpr) -> OccEnv
1225 -- Does two things: a) makes the occ_ctxt = OccVanilla
1226 -- b) extends the scrut_ids if necessary
1227 mkAltEnv env (Just (scrut_id, _))
1228 | not (isLocalId scrut_id)
1229 = OccEnv { occ_encl = OccVanilla
1230 , occ_scrut_ids = extendVarSet (occ_scrut_ids env) scrut_id
1231 , occ_ctxt = occ_ctxt env }
1233 | isRhsEnv env = env { occ_encl = OccVanilla }
1236 setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
1237 setCtxtTy env ctxt = env { occ_ctxt = ctxt }
1239 isRhsEnv :: OccEnv -> Bool
1240 isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
1241 isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
1243 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
1244 -- The result binders have one-shot-ness set that they might not have had originally.
1245 -- This happens in (build (\cn -> e)). Here the occurrence analyser
1246 -- linearity context knows that c,n are one-shot, and it records that fact in
1247 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
1249 oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs
1252 go _ [] rev_bndrs = reverse rev_bndrs
1254 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
1255 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
1257 bndr' | lin_ctxt = setOneShotLambda bndr
1260 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1262 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1263 addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
1264 = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }
1267 %************************************************************************
1269 \subsection[OccurAnal-types]{OccEnv}
1271 %************************************************************************
1274 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
1275 -- INVARIANT: never IAmDead
1276 -- (Deadness is signalled by not being in the map at all)
1278 (+++), combineAltsUsageDetails
1279 :: UsageDetails -> UsageDetails -> UsageDetails
1282 = plusVarEnv_C addOccInfo usage1 usage2
1284 combineAltsUsageDetails usage1 usage2
1285 = plusVarEnv_C orOccInfo usage1 usage2
1287 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1288 addOneOcc usage id info
1289 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1290 -- ToDo: make this more efficient
1292 emptyDetails :: UsageDetails
1293 emptyDetails = (emptyVarEnv :: UsageDetails)
1295 localUsedIn, usedIn :: Id -> UsageDetails -> Bool
1296 v `localUsedIn` details = v `elemVarEnv` details
1297 v `usedIn` details = isExportedId v || v `localUsedIn` details
1299 type IdWithOccInfo = Id
1301 tagBinders :: UsageDetails -- Of scope
1303 -> (UsageDetails, -- Details with binders removed
1304 [IdWithOccInfo]) -- Tagged binders
1306 tagBinders usage binders
1308 usage' = usage `delVarEnvList` binders
1309 uss = map (setBinderOcc usage) binders
1311 usage' `seq` (usage', uss)
1313 tagBinder :: UsageDetails -- Of scope
1315 -> (UsageDetails, -- Details with binders removed
1316 IdWithOccInfo) -- Tagged binders
1318 tagBinder usage binder
1320 usage' = usage `delVarEnv` binder
1321 binder' = setBinderOcc usage binder
1323 usage' `seq` (usage', binder')
1325 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1326 setBinderOcc usage bndr
1327 | isTyVar bndr = bndr
1328 | isExportedId bndr = case idOccInfo bndr of
1330 _ -> setIdOccInfo bndr NoOccInfo
1331 -- Don't use local usage info for visible-elsewhere things
1332 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1333 -- about to re-generate it and it shouldn't be "sticky"
1335 | otherwise = setIdOccInfo bndr occ_info
1337 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1341 %************************************************************************
1343 \subsection{Operations over OccInfo}
1345 %************************************************************************
1348 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1349 mkOneOcc env id int_cxt
1350 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1351 | id `elemVarSet` occ_scrut_ids env = unitVarEnv id NoOccInfo
1352 | otherwise = emptyDetails
1354 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1356 markMany _ = NoOccInfo
1358 markInsideSCC occ = markMany occ
1360 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1361 markInsideLam occ = occ
1363 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1365 addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
1366 NoOccInfo -- Both branches are at least One
1367 -- (Argument is never IAmDead)
1369 -- (orOccInfo orig new) is used
1370 -- when combining occurrence info from branches of a case
1372 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1373 (OneOcc in_lam2 _ int_cxt2)
1374 = OneOcc (in_lam1 || in_lam2)
1375 False -- False, because it occurs in both branches
1376 (int_cxt1 && int_cxt2)
1377 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )