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, isExpandableApp, mkCoerce )
26 import Name ( Name, localiseName )
34 import Maybes ( orElse )
35 import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
36 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
39 import Util ( mapAndUnzip, filterOut )
47 %************************************************************************
49 \subsection[OccurAnal-main]{Counting occurrences: main function}
51 %************************************************************************
53 Here's the externally-callable interface:
56 occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
57 -> [CoreBind] -> [CoreBind]
58 occurAnalysePgm active_rule imp_rules binds
59 = snd (go (initOccEnv active_rule imp_rules) binds)
61 initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)
62 -- The RULES keep things alive!
64 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
68 = (final_usage, bind' ++ binds')
70 (bs_usage, binds') = go env binds
71 (final_usage, bind') = occAnalBind env env bind bs_usage
73 occurAnalyseExpr :: CoreExpr -> CoreExpr
74 -- Do occurrence analysis, and discard occurence info returned
76 = snd (occAnal (initOccEnv all_active_rules []) expr)
78 -- To be conservative, we say that all inlines and rules are active
79 all_active_rules = Just (\_ -> True)
83 %************************************************************************
85 \subsection[OccurAnal-main]{Counting occurrences: main function}
87 %************************************************************************
93 occAnalBind :: OccEnv -- The incoming OccEnv
94 -> OccEnv -- Same, but trimmed by (binderOf bind)
96 -> UsageDetails -- Usage details of scope
97 -> (UsageDetails, -- Of the whole let(rec)
100 occAnalBind env _ (NonRec binder rhs) body_usage
101 | isTyVar binder -- A type let; we don't gather usage info
102 = (body_usage, [NonRec binder rhs])
104 | isCoVar binder -- A coercion let; again no usage info
105 -- We trust that it'll get inlined away
106 -- as soon as it takes form (cv = Coercion co)
107 = (body_usage, [NonRec binder rhs])
109 | not (binder `usedIn` body_usage) -- It's not mentioned
112 | otherwise -- It's mentioned in the body
113 = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs'])
115 (body_usage', tagged_binder) = tagBinder body_usage binder
116 (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs
117 rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder)
118 rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder)
119 -- See Note [Rules are extra RHSs] and Note [Rule dependency info]
124 Dropping dead code for recursive bindings is done in a very simple way:
126 the entire set of bindings is dropped if none of its binders are
127 mentioned in its body; otherwise none are.
129 This seems to miss an obvious improvement.
141 Now 'f' is unused! But it's OK! Dependency analysis will sort this
142 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
143 dropped. It isn't easy to do a perfect job in one blow. Consider
154 Note [Loop breaking and RULES]
155 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 Loop breaking is surprisingly subtle. First read the section 4 of
157 "Secrets of the GHC inliner". This describes our basic plan.
159 However things are made quite a bit more complicated by RULES. Remember
161 * Note [Rules are extra RHSs]
162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
163 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
164 keeps the specialised "children" alive. If the parent dies
165 (because it isn't referenced any more), then the children will die
166 too (unless they are already referenced directly).
168 To that end, we build a Rec group for each cyclic strongly
170 *treating f's rules as extra RHSs for 'f'*.
171 More concretely, the SCC analysis runs on a graph with an edge
172 from f -> g iff g is mentioned in
177 Under (b) we include variables free in *either* LHS *or* RHS of
178 the rule. The former might seems silly, but see Note [Rule
179 dependency info]. So in Example [eftInt], eftInt and eftIntFB
180 will be put in the same Rec, even though their 'main' RHSs are
183 * Note [Rules are visible in their own rec group]
184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
185 We want the rules for 'f' to be visible in f's right-hand side.
186 And we'd like them to be visible in other functions in f's Rec
187 group. E.g. in Example [Specialisation rules] we want f' rule
188 to be visible in both f's RHS, and fs's RHS.
190 This means that we must simplify the RULEs first, before looking
191 at any of the definitions. This is done by Simplify.simplRecBind,
192 when it calls addLetIdInfo.
194 * Note [Choosing loop breakers]
195 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
196 We avoid infinite inlinings by choosing loop breakers, and
197 ensuring that a loop breaker cuts each loop. But what is a
198 "loop"? In particular, a RULE is like an equation for 'f' that
199 is *always* inlined if it is applicable. We do *not* disable
200 rules for loop-breakers. It's up to whoever makes the rules to
201 make sure that the rules themselves always terminate. See Note
202 [Rules for recursive functions] in Simplify.lhs
205 f's RHS (or its INLINE template if it has one) mentions g, and
206 g has a RULE that mentions h, and
207 h has a RULE that mentions f
209 then we *must* choose f to be a loop breaker. In general, take the
210 free variables of f's RHS, and augment it with all the variables
211 reachable by RULES from those starting points. That is the whole
212 reason for computing rule_fv_env in occAnalBind. (Of course we
213 only consider free vars that are also binders in this Rec group.)
214 See also Note [Finding rule RHS free vars]
216 Note that when we compute this rule_fv_env, we only consider variables
217 free in the *RHS* of the rule, in contrast to the way we build the
218 Rec group in the first place (Note [Rule dependency info])
220 Note that if 'g' has RHS that mentions 'w', we should add w to
221 g's loop-breaker edges. More concretely there is an edge from f -> g
223 (a) g is mentioned in f's RHS
224 (b) h is mentioned in f's RHS, and
225 g appears in the RHS of a RULE of h
226 or a transitive sequence of rules starting with h
228 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
229 chosen as a loop breaker, because their RHSs don't mention each other.
230 And indeed both can be inlined safely.
232 Note that the edges of the graph we use for computing loop breakers
233 are not the same as the edges we use for computing the Rec blocks.
234 That's why we compute
235 rec_edges for the Rec block analysis
236 loop_breaker_edges for the loop breaker analysis
238 * Note [Finding rule RHS free vars]
239 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
240 Consider this real example from Data Parallel Haskell
241 tagZero :: Array Int -> Array Tag
242 {-# INLINE [1] tagZeroes #-}
243 tagZero xs = pmap (\x -> fromBool (x==0)) xs
245 {-# RULES "tagZero" [~1] forall xs n.
246 pmap fromBool <blah blah> = tagZero xs #-}
247 So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.
248 However, tagZero can only be inlined in phase 1 and later, while
249 the RULE is only active *before* phase 1. So there's no problem.
251 To make this work, we look for the RHS free vars only for
252 *active* rules. That's the reason for the is_active argument
253 to idRhsRuleVars, and the occ_rule_act field of the OccEnv.
255 * Note [Weak loop breakers]
256 ~~~~~~~~~~~~~~~~~~~~~~~~~
257 There is a last nasty wrinkle. Suppose we have
267 Remember that we simplify the RULES before any RHS (see Note
268 [Rules are visible in their own rec group] above).
270 So we must *not* postInlineUnconditionally 'g', even though
271 its RHS turns out to be trivial. (I'm assuming that 'g' is
272 not choosen as a loop breaker.) Why not? Because then we
273 drop the binding for 'g', which leaves it out of scope in the
276 We "solve" this by making g a "weak" or "rules-only" loop breaker,
277 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
278 has IAmLoopBreaker False. So
280 Inline postInlineUnconditionally
281 IAmLoopBreaker False no no
282 IAmLoopBreaker True yes no
285 The **sole** reason for this kind of loop breaker is so that
286 postInlineUnconditionally does not fire. Ugh.
288 * Note [Rule dependency info]
289 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
290 The VarSet in a SpecInfo is used for dependency analysis in the
291 occurrence analyser. We must track free vars in *both* lhs and rhs.
292 Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
296 Then if we substitute y for x, we'd better do so in the
297 rule's LHS too, so we'd better ensure the dependency is respected
300 * Note [Inline rules]
302 None of the above stuff about RULES applies to Inline Rules,
303 stored in a CoreUnfolding. The unfolding, if any, is simplified
304 at the same time as the regular RHS of the function, so it should
305 be treated *exactly* like an extra RHS.
307 There is a danger that we'll be sub-optimal if we see this
309 [INLINE f = ..no f...]
310 where f is recursive, but the INLINE is not. This can just about
311 happen with a sufficiently odd set of rules; eg
314 {-# INLINE [1] foo #-}
318 {-# INLINE [1] bar #-}
321 {-# RULES "foo" [~1] forall x. foo x = bar x #-}
323 Here the RULE makes bar recursive; but it's INLINE pragma remains
324 non-recursive. It's tempting to then say that 'bar' should not be
325 a loop breaker, but an attempt to do so goes wrong in two ways:
329 [INLINE $cfoo = ...no-$df...]
330 But we want $cfoo to depend on $df explicitly so that we
331 put the bindings in the right order to inline $df in $cfoo
332 and perhaps break the loop altogether. (Maybe this
339 Example (from GHC.Enum):
341 eftInt :: Int# -> Int# -> [Int]
342 eftInt x y = ...(non-recursive)...
344 {-# INLINE [0] eftIntFB #-}
345 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
346 eftIntFB c n x y = ...(non-recursive)...
349 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
350 "eftIntList" [1] eftIntFB (:) [] = eftInt
353 Example [Specialisation rules]
354 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
355 Consider this group, which is typical of what SpecConstr builds:
357 fs a = ....f (C a)....
358 f x = ....f (C a)....
359 {-# RULE f (C a) = fs a #-}
361 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
363 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
364 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
365 - fs is inlined (say it's small)
366 - now there's another opportunity to apply the RULE
368 This showed up when compiling Control.Concurrent.Chan.getChanContents.
372 occAnalBind _ env (Rec pairs) body_usage
373 = foldr (occAnalRec env) (body_usage, []) sccs
374 -- For a recursive group, we
375 -- * occ-analyse all the RHSs
376 -- * compute strongly-connected components
377 -- * feed those components to occAnalRec
379 -------------Dependency analysis ------------------------------
380 bndr_set = mkVarSet (map fst pairs)
382 sccs :: [SCC (Node Details)]
383 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges
385 rec_edges :: [Node Details]
386 rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
388 make_node (bndr, rhs)
389 = (details, varUnique bndr, keysUFM out_edges)
391 details = ND { nd_bndr = bndr, nd_rhs = rhs'
392 , nd_uds = rhs_usage3, nd_inl = inl_fvs}
394 (rhs_usage1, rhs') = occAnalRhs env Nothing rhs
395 rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs]
396 rhs_usage3 = addIdOccs rhs_usage2 unf_fvs
397 unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag
398 unf_fvs = stableUnfoldingVars unf
399 rule_fvs = idRuleVars bndr -- See Note [Rule dependency info]
401 inl_fvs = rhs_fvs `unionVarSet` unf_fvs
402 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1
403 out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3
404 -- (a -> b) means a mentions b
405 -- Given the usage details (a UFM that gives occ info for each free var of
406 -- the RHS) we can get the list of free vars -- or rather their Int keys --
407 -- by just extracting the keys from the finite map. Grimy, but fast.
408 -- Previously we had this:
409 -- [ bndr | bndr <- bndrs,
410 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
411 -- which has n**2 cost, and this meant that edges_from alone
412 -- consumed 10% of total runtime!
414 -----------------------------
415 occAnalRec :: OccEnv -> SCC (Node Details)
416 -> (UsageDetails, [CoreBind])
417 -> (UsageDetails, [CoreBind])
419 -- The NonRec case is just like a Let (NonRec ...) above
420 occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _))
422 | not (bndr `usedIn` body_usage)
423 = (body_usage, binds)
425 | otherwise -- It's mentioned in the body
426 = (body_usage' +++ rhs_usage,
427 NonRec tagged_bndr rhs : binds)
429 (body_usage', tagged_bndr) = tagBinder body_usage bndr
432 -- The Rec case is the interesting one
433 -- See Note [Loop breaking]
434 occAnalRec env (CyclicSCC nodes) (body_usage, binds)
435 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
436 = (body_usage, binds) -- Dead code
438 | otherwise -- At this point we always build a single Rec
439 = (final_usage, Rec pairs : binds)
442 bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes]
443 bndr_set = mkVarSet bndrs
444 non_boring bndr = isId bndr &&
445 (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr)
447 ----------------------------
448 -- Tag the binders with their occurrence info
449 total_usage = foldl add_usage body_usage nodes
450 add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage
451 (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
453 tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
454 -- (a) Tag the binders in the details with occ info
455 -- (b) Mark the binder with "weak loop-breaker" OccInfo
456 -- saying "no preInlineUnconditionally" if it is used
457 -- in any rule (lhs or rhs) of the recursive group
458 -- See Note [Weak loop breakers]
459 tag_node usage (details@ND { nd_bndr = bndr }, k, ks)
460 = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks))
462 bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
464 bndr1 = setBinderOcc usage bndr
465 all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
468 ----------------------------
469 -- Now reconstruct the cycle
470 pairs | any non_boring bndrs
471 = foldr (reOrderRec 0) [] $
472 stronglyConnCompFromEdgedVerticesR loop_breaker_edges
474 = reOrderCycle 0 tagged_nodes []
476 -- See Note [Choosing loop breakers] for loop_breaker_edges
477 loop_breaker_edges = map mk_node tagged_nodes
478 mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks)
480 new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs))
482 ------------------------------------
483 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
484 -- Domain is *subset* of bound vars (others have no rule fvs)
485 rule_fv_env = transClosureFV init_rule_fvs
487 | Just is_active <- occ_rule_act env -- See Note [Finding rule RHS free vars]
491 , let rule_fvs = idRuleRhsVars is_active b
492 `intersectVarSet` bndr_set
493 , not (isEmptyVarSet rule_fvs)]
498 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
499 strongly connected component (there's guaranteed to be a cycle). It returns the
501 a) in a better order,
502 b) with some of the Ids having a IAmALoopBreaker pragma
504 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
505 that the simplifier can guarantee not to loop provided it never records an inlining
506 for these no-inline guys.
508 Furthermore, the order of the binds is such that if we neglect dependencies
509 on the no-inline Ids then the binds are topologically sorted. This means
510 that the simplifier will generally do a good job if it works from top bottom,
511 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
514 [June 98: I don't understand the following paragraphs, and I've
515 changed the a=b case again so that it isn't a special case any more.]
517 Here's a case that bit me:
525 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
527 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
528 Perhaps something cleverer would suffice.
533 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
534 -- which is gotten from the Id.
536 = ND { nd_bndr :: Id -- Binder
537 , nd_rhs :: CoreExpr -- RHS
539 , nd_uds :: UsageDetails -- Usage from RHS,
540 -- including RULES and InlineRule unfolding
542 , nd_inl :: IdSet -- Other binders *from this Rec group* mentioned in
543 } -- its InlineRule unfolding (if present)
545 -- but *excluding* any RULES
546 -- This is the IdSet that may be used if the Id is inlined
548 reOrderRec :: Int -> SCC (Node Details)
549 -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
550 -- Sorted into a plausible order. Enough of the Ids have
551 -- IAmALoopBreaker pragmas that there are no loops left.
552 reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _))
553 pairs = (bndr, rhs) : pairs
554 reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
556 reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
558 = panic "reOrderCycle"
559 reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs
560 = -- Common case of simple self-recursion
561 (makeLoopBreaker False bndr, rhs) : pairs
563 reOrderCycle depth (bind : binds) pairs
564 = -- Choose a loop breaker, mark it no-inline,
565 -- do SCC analysis on the rest, and recursively sort them out
566 -- pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $
567 foldr (reOrderRec new_depth)
568 ([ (makeLoopBreaker False bndr, rhs)
569 | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs)
570 (stronglyConnCompFromEdgedVerticesR unchosen)
572 (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds
574 approximate_loop_breaker = depth >= 2
575 new_depth | approximate_loop_breaker = 0
576 | otherwise = depth+1
577 -- After two iterations (d=0, d=1) give up
578 -- and approximate, returning to d=0
580 -- This loop looks for the bind with the lowest score
581 -- to pick as the loop breaker. The rest accumulate in
582 choose_loop_breaker loop_binds _loop_sc acc []
583 = (loop_binds, acc) -- Done
585 -- If approximate_loop_breaker is True, we pick *all*
586 -- nodes with lowest score, else just one
587 -- See Note [Complexity of loop breaking]
588 choose_loop_breaker loop_binds loop_sc acc (bind : binds)
589 | sc < loop_sc -- Lower score so pick this new one
590 = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds
592 | approximate_loop_breaker && sc == loop_sc
593 = choose_loop_breaker (bind : loop_binds) loop_sc acc binds
595 | otherwise -- Higher score so don't pick it
596 = choose_loop_breaker loop_binds loop_sc (bind : acc) binds
600 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
601 score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)
602 | not (isId bndr) = 100 -- A type or cercion variable is never a loop breaker
604 | isDFunId bndr = 9 -- Never choose a DFun as a loop breaker
605 -- Note [DFuns should not be loop breakers]
607 | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
609 InlineWrapper {} -> 10 -- Note [INLINE pragmas]
610 _other -> 3 -- Data structures are more important than this
611 -- so that dictionary/method recursion unravels
612 -- Note that this case hits all InlineRule things, so we
613 -- never look at 'rhs for InlineRule stuff. That's right, because
614 -- 'rhs' is irrelevant for inlining things with an InlineRule
616 | is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications]
618 | exprIsTrivial rhs = 10 -- Practically certain to be inlined
619 -- Used to have also: && not (isExportedId bndr)
620 -- But I found this sometimes cost an extra iteration when we have
621 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
622 -- where df is the exported dictionary. Then df makes a really
623 -- bad choice for loop breaker
626 -- If an Id is marked "never inline" then it makes a great loop breaker
627 -- The only reason for not checking that here is that it is rare
628 -- and I've never seen a situation where it makes a difference,
629 -- so it probably isn't worth the time to test on every binder
630 -- | isNeverActive (idInlinePragma bndr) = -10
632 | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined
634 | canUnfold (realIdUnfolding bndr) = 1
635 -- The Id has some kind of unfolding
636 -- Ignore loop-breaker-ness here because that is what we are setting!
640 -- Checking for a constructor application
641 -- Cheap and cheerful; the simplifer moves casts out of the way
642 -- The lambda case is important to spot x = /\a. C (f a)
643 -- which comes up when C is a dictionary constructor and
644 -- f is a default method.
645 -- Example: the instance for Show (ST s a) in GHC.ST
647 -- However we *also* treat (\x. C p q) as a con-app-like thing,
648 -- Note [Closure conversion]
649 is_con_app (Var v) = isConLikeId v
650 is_con_app (App f _) = is_con_app f
651 is_con_app (Lam _ e) = is_con_app e
652 is_con_app (Note _ e) = is_con_app e
655 makeLoopBreaker :: Bool -> Id -> Id
656 -- Set the loop-breaker flag: see Note [Weak loop breakers]
657 makeLoopBreaker weak bndr
658 = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak)
661 Note [Complexity of loop breaking]
662 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
663 The loop-breaking algorithm knocks out one binder at a time, and
664 performs a new SCC analysis on the remaining binders. That can
665 behave very badly in tightly-coupled groups of bindings; in the
666 worst case it can be (N**2)*log N, because it does a full SCC
667 on N, then N-1, then N-2 and so on.
669 To avoid this, we switch plans after 2 (or whatever) attempts:
670 Plan A: pick one binder with the lowest score, make it
671 a loop breaker, and try again
672 Plan B: pick *all* binders with the lowest score, make them
673 all loop breakers, and try again
674 Since there are only a small finite number of scores, this will
675 terminate in a constant number of iterations, rather than O(N)
678 You might thing that it's very unlikely, but RULES make it much
679 more likely. Here's a real example from Trac #1969:
680 Rec { $dm = \d.\x. op d
681 {-# RULES forall d. $dm Int d = $s$dm1
682 forall d. $dm Bool d = $s$dm2 #-}
684 dInt = MkD .... opInt ...
685 dInt = MkD .... opBool ...
690 $s$dm2 = \x. op dBool }
691 The RULES stuff means that we can't choose $dm as a loop breaker
692 (Note [Choosing loop breakers]), so we must choose at least (say)
693 opInt *and* opBool, and so on. The number of loop breakders is
694 linear in the number of instance declarations.
696 Note [INLINE pragmas]
697 ~~~~~~~~~~~~~~~~~~~~~
698 Avoid choosing a function with an INLINE pramga as the loop breaker!
699 If such a function is mutually-recursive with a non-INLINE thing,
700 then the latter should be the loop-breaker.
702 Usually this is just a question of optimisation. But a particularly
703 bad case is wrappers generated by the demand analyser: if you make
704 then into a loop breaker you may get an infinite inlining loop. For
707 $wfoo x = ....foo x....
709 {-loop brk-} foo x = ...$wfoo x...
711 The interface file sees the unfolding for $wfoo, and sees that foo is
712 strict (and hence it gets an auto-generated wrapper). Result: an
713 infinite inlining in the importing scope. So be a bit careful if you
714 change this. A good example is Tree.repTree in
715 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
716 breaker then compiling Game.hs goes into an infinite loop. This
717 happened when we gave is_con_app a lower score than inline candidates:
720 = __inline_me (/\a. \w w1 w2 ->
721 case Tree.$wrepTree @ a w w1 w2 of
722 { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
725 (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
727 Here we do *not* want to choose 'repTree' as the loop breaker.
729 Note [DFuns should not be loop breakers]
730 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
731 It's particularly bad to make a DFun into a loop breaker. See
732 Note [How instance declarations are translated] in TcInstDcls
734 We give DFuns a higher score than ordinary CONLIKE things because
735 if there's a choice we want the DFun to be the non-looop breker. Eg
737 rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)
739 $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)
741 $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)
744 Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it
745 if we can't unravel the DFun first.
747 Note [Constructor applications]
748 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
749 It's really really important to inline dictionaries. Real
750 example (the Enum Ordering instance from GHC.Base):
752 rec f = \ x -> case d of (p,q,r) -> p x
753 g = \ x -> case d of (p,q,r) -> q x
756 Here, f and g occur just once; but we can't inline them into d.
757 On the other hand we *could* simplify those case expressions if
758 we didn't stupidly choose d as the loop breaker.
759 But we won't because constructor args are marked "Many".
760 Inlining dictionaries is really essential to unravelling
761 the loops in static numeric dictionaries, see GHC.Float.
763 Note [Closure conversion]
764 ~~~~~~~~~~~~~~~~~~~~~~~~~
765 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
766 The immediate motivation came from the result of a closure-conversion transformation
767 which generated code like this:
769 data Clo a b = forall c. Clo (c -> a -> b) c
771 ($:) :: Clo a b -> a -> b
772 Clo f env $: x = f env x
774 rec { plus = Clo plus1 ()
776 ; plus1 _ n = Clo plus2 n
779 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
781 If we inline 'plus' and 'plus1', everything unravels nicely. But if
782 we choose 'plus1' as the loop breaker (which is entirely possible
783 otherwise), the loop does not unravel nicely.
786 @occAnalRhs@ deals with the question of bindings where the Id is marked
787 by an INLINE pragma. For these we record that anything which occurs
788 in its RHS occurs many times. This pessimistically assumes that ths
789 inlined binder also occurs many times in its scope, but if it doesn't
790 we'll catch it next time round. At worst this costs an extra simplifier pass.
791 ToDo: try using the occurrence info for the inline'd binder.
793 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
794 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
799 -> Maybe Id -> CoreExpr -- Binder and rhs
800 -- Just b => non-rec, and alrady tagged with occurrence info
801 -- Nothing => Rec, no occ info
802 -> (UsageDetails, CoreExpr)
803 -- Returned usage details covers only the RHS,
804 -- and *not* the RULE or INLINE template for the Id
805 occAnalRhs env mb_bndr rhs
808 -- See Note [Cascading inlines]
809 ctxt = case mb_bndr of
810 Just b | certainly_inline b -> env
811 _other -> rhsCtxt env
813 certainly_inline bndr -- See Note [Cascading inlines]
814 = case idOccInfo bndr of
815 OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable
818 active = isAlwaysActive (idInlineActivation bndr)
819 not_stable = not (isStableUnfolding (idUnfolding bndr))
821 addIdOccs :: UsageDetails -> VarSet -> UsageDetails
822 addIdOccs usage id_set = foldVarSet add usage id_set
824 add v u | isId v = addOneOcc u v NoOccInfo
826 -- Give a non-committal binder info (i.e NoOccInfo) because
827 -- a) Many copies of the specialised thing can appear
828 -- b) We don't want to substitute a BIG expression inside a RULE
829 -- even if that's the only occurrence of the thing
830 -- (Same goes for INLINE.)
833 Note [Cascading inlines]
834 ~~~~~~~~~~~~~~~~~~~~~~~~
835 By default we use an rhsCtxt for the RHS of a binding. This tells the
836 occ anal n that it's looking at an RHS, which has an effect in
837 occAnalApp. In particular, for constructor applications, it makes
838 the arguments appear to have NoOccInfo, so that we don't inline into
841 we do not want to inline x.
843 But there's a problem. Consider
848 First time round, it looks as if x1 and x2 occur as an arg of a
849 let-bound constructor ==> give them a many-occurrence.
850 But then x3 is inlined (unconditionally as it happens) and
851 next time round, x2 will be, and the next time round x1 will be
852 Result: multiple simplifier iterations. Sigh.
854 So, when analysing the RHS of x3 we notice that x3 will itself
855 definitely inline the next time round, and so we analyse x3's rhs in
856 an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff.
858 Annoyingly, we have to approximiate SimplUtils.preInlineUnconditionally.
859 If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates
869 This is worse than the slow cascade, so we only want to say "certainly_inline"
870 if it really is certain. Look at the note with preInlineUnconditionally
871 for the various clauses.
878 -> (UsageDetails, -- Gives info only about the "interesting" Ids
881 occAnal _ expr@(Type _) = (emptyDetails, expr)
882 occAnal _ expr@(Lit _) = (emptyDetails, expr)
883 occAnal env expr@(Var v) = (mkOneOcc env v False, expr)
884 -- At one stage, I gathered the idRuleVars for v here too,
885 -- which in a way is the right thing to do.
886 -- But that went wrong right after specialisation, when
887 -- the *occurrences* of the overloaded function didn't have any
888 -- rules in them, so the *specialised* versions looked as if they
889 -- weren't used at all.
891 occAnal _ (Coercion co)
892 = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
893 -- See Note [Gather occurrences of coercion veriables]
896 Note [Gather occurrences of coercion veriables]
897 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
898 We need to gather info about what coercion variables appear, so that
899 we can sort them into the right place when doing dependency analysis.
905 occAnal env (Note note@(SCC _) body)
906 = case occAnal env body of { (usage, body') ->
907 (mapVarEnv markInsideSCC usage, Note note body')
910 occAnal env (Note note body)
911 = case occAnal env body of { (usage, body') ->
912 (usage, Note note body')
915 occAnal env (Cast expr co)
916 = case occAnal env expr of { (usage, expr') ->
917 let usage1 = markManyIf (isRhsEnv env) usage
918 usage2 = addIdOccs usage1 (coVarsOfCo co)
919 -- See Note [Gather occurrences of coercion veriables]
920 in (usage2, Cast expr' co)
921 -- If we see let x = y `cast` co
922 -- then mark y as 'Many' so that we don't
923 -- immediately inline y again.
928 occAnal env app@(App _ _)
929 = occAnalApp env (collectArgs app)
931 -- Ignore type variables altogether
932 -- (a) occurrences inside type lambdas only not marked as InsideLam
933 -- (b) type variables not in environment
935 occAnal env (Lam x body) | isTyVar x
936 = case occAnal env body of { (body_usage, body') ->
937 (body_usage, Lam x body')
940 -- For value lambdas we do a special hack. Consider
942 -- If we did nothing, x is used inside the \y, so would be marked
943 -- as dangerous to dup. But in the common case where the abstraction
944 -- is applied to two arguments this is over-pessimistic.
945 -- So instead, we just mark each binder with its occurrence
946 -- info in the *body* of the multiple lambda.
947 -- Then, the simplifier is careful when partially applying lambdas.
949 occAnal env expr@(Lam _ _)
950 = case occAnal env_body body of { (body_usage, body') ->
952 (final_usage, tagged_binders) = tagLamBinders body_usage binders'
953 -- Use binders' to put one-shot info on the lambdas
955 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
956 -- we get linear-typed things in the resulting program that we can't handle yet.
957 -- (e.g. PrelShow) TODO
959 really_final_usage = if linear then
962 mapVarEnv markInsideLam final_usage
965 mkLams tagged_binders body') }
967 env_body = vanillaCtxt (trimOccEnv env binders)
968 -- Body is (no longer) an RhsContext
969 (binders, body) = collectBinders expr
970 binders' = oneShotGroup env binders
971 linear = all is_one_shot binders'
972 is_one_shot b = isId b && isOneShotBndr b
974 occAnal env (Case scrut bndr ty alts)
975 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
976 case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
978 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
979 (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
980 total_usage = scrut_usage +++ alts_usage1
982 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
984 -- Note [Case binder usage]
985 -- ~~~~~~~~~~~~~~~~~~~~~~~~
986 -- The case binder gets a usage of either "many" or "dead", never "one".
987 -- Reason: we like to inline single occurrences, to eliminate a binding,
988 -- but inlining a case binder *doesn't* eliminate a binding.
989 -- We *don't* want to transform
990 -- case x of w { (p,q) -> f w }
992 -- case x of w { (p,q) -> f (p,q) }
993 tag_case_bndr usage bndr
994 = case lookupVarEnv usage bndr of
995 Nothing -> (usage, setIdOccInfo bndr IAmDead)
996 Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)
998 alt_env = mkAltEnv env scrut bndr
999 occ_anal_alt = occAnalAlt alt_env bndr
1001 occ_anal_scrut (Var v) (alt1 : other_alts)
1002 | not (null other_alts) || not (isDefaultAlt alt1)
1003 = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs
1004 -- in an interesting context; the case has
1005 -- at least one non-default alternative
1006 occ_anal_scrut scrut _alts
1007 = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt
1009 occAnal env (Let bind body)
1010 = case occAnal env_body body of { (body_usage, body') ->
1011 case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) ->
1012 (final_usage, mkLets new_binds body') }}
1014 env_body = trimOccEnv env (bindersOf bind)
1016 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
1017 occAnalArgs env args
1018 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
1019 (foldr (+++) emptyDetails arg_uds_s, args')}
1021 arg_env = vanillaCtxt env
1024 Applications are dealt with specially because we want
1025 the "build hack" to work.
1027 Note [Arguments of let-bound constructors]
1028 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1030 f x = let y = expensive x in
1032 (case z of {(p,q)->q}, case z of {(p,q)->q})
1033 We feel free to duplicate the WHNF (True,y), but that means
1034 that y may be duplicated thereby.
1036 If we aren't careful we duplicate the (expensive x) call!
1037 Constructors are rather like lambdas in this way.
1040 occAnalApp :: OccEnv
1041 -> (Expr CoreBndr, [Arg CoreBndr])
1042 -> (UsageDetails, Expr CoreBndr)
1043 occAnalApp env (Var fun, args)
1044 = case args_stuff of { (args_uds, args') ->
1046 final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
1047 -- We mark the free vars of the argument of a constructor or PAP
1048 -- as "many", if it is the RHS of a let(rec).
1049 -- This means that nothing gets inlined into a constructor argument
1050 -- position, which is what we want. Typically those constructor
1051 -- arguments are just variables, or trivial expressions.
1053 -- This is the *whole point* of the isRhsEnv predicate
1054 -- See Note [Arguments of let-bound constructors]
1056 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
1058 fun_uniq = idUnique fun
1059 fun_uds = mkOneOcc env fun (valArgCount args > 0)
1060 is_exp = isExpandableApp fun (valArgCount args)
1061 -- See Note [CONLIKE pragma] in BasicTypes
1062 -- The definition of is_exp should match that in
1063 -- Simplify.prepareRhs
1065 -- Hack for build, fold, runST
1066 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
1067 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
1068 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
1069 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
1070 -- (foldr k z xs) may call k many times, but it never
1071 -- shares a partial application of k; hence [False,True]
1072 -- This means we can optimise
1073 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
1074 -- by floating in the v
1076 | otherwise = occAnalArgs env args
1079 occAnalApp env (fun, args)
1080 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
1081 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
1082 -- often leaves behind beta redexs like
1083 -- (\x y -> e) a1 a2
1084 -- Here we would like to mark x,y as one-shot, and treat the whole
1085 -- thing much like a let. We do this by pushing some True items
1086 -- onto the context stack.
1088 case occAnalArgs env args of { (args_uds, args') ->
1090 final_uds = fun_uds +++ args_uds
1092 (final_uds, mkApps fun' args') }}
1095 markManyIf :: Bool -- If this is true
1096 -> UsageDetails -- Then do markMany on this
1098 markManyIf True uds = mapVarEnv markMany uds
1099 markManyIf False uds = uds
1101 appSpecial :: OccEnv
1102 -> Int -> CtxtTy -- Argument number, and context to use for it
1104 -> (UsageDetails, [CoreExpr])
1105 appSpecial env n ctxt args
1108 arg_env = vanillaCtxt env
1110 go _ [] = (emptyDetails, []) -- Too few args
1112 go 1 (arg:args) -- The magic arg
1113 = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') ->
1114 case occAnalArgs env args of { (args_uds, args') ->
1115 (arg_uds +++ args_uds, arg':args') }}
1118 = case occAnal arg_env arg of { (arg_uds, arg') ->
1119 case go (n-1) args of { (args_uds, args') ->
1120 (arg_uds +++ args_uds, arg':args') }}
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.) It really helps to know when
1131 binders are unused. See esp the call to isDeadBinder in
1132 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
1142 -> (UsageDetails, Alt IdWithOccInfo)
1143 occAnalAlt env case_bndr (con, bndrs, rhs)
1145 env' = trimOccEnv env bndrs
1147 case occAnal env' rhs of { (rhs_usage1, rhs1) ->
1149 proxies = getProxies env' case_bndr
1150 (rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies
1151 (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
1152 bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
1154 (alt_usg, (con, bndrs', rhs2)) }
1156 wrapProxy :: ProxyBind -> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
1157 wrapProxy (bndr, rhs_var, co) (body_usg, body)
1158 | not (bndr `usedIn` body_usg)
1161 = (body_usg' +++ rhs_usg, Let (NonRec tagged_bndr rhs) body)
1163 (body_usg', tagged_bndr) = tagBinder body_usg bndr
1164 rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
1165 rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
1169 %************************************************************************
1173 %************************************************************************
1177 = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
1178 , occ_ctxt :: !CtxtTy -- Tells about linearity
1179 , occ_proxy :: ProxyEnv
1180 , occ_rule_fvs :: ImpRuleUsage
1181 , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive
1182 -- See Note [Finding rule RHS free vars]
1186 -----------------------------
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 instance Outputable OccEncl where
1202 ppr OccRhs = ptext (sLit "occRhs")
1203 ppr OccVanilla = ptext (sLit "occVanilla")
1205 type CtxtTy = [Bool]
1208 -- True:ctxt Analysing a function-valued expression that will be
1209 -- applied just once
1211 -- False:ctxt Analysing a function-valued expression that may
1212 -- be applied many times; but when it is,
1213 -- the CtxtTy inside applies
1215 initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule]
1217 initOccEnv active_rule imp_rules
1218 = OccEnv { occ_encl = OccVanilla
1220 , occ_proxy = PE emptyVarEnv emptyVarSet
1221 , occ_rule_fvs = findImpRuleUsage active_rule imp_rules
1222 , occ_rule_act = active_rule }
1224 vanillaCtxt :: OccEnv -> OccEnv
1225 vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }
1227 rhsCtxt :: OccEnv -> OccEnv
1228 rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] }
1230 setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
1231 setCtxtTy env ctxt = env { occ_ctxt = ctxt }
1233 isRhsEnv :: OccEnv -> Bool
1234 isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
1235 isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
1237 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
1238 -- The result binders have one-shot-ness set that they might not have had originally.
1239 -- This happens in (build (\cn -> e)). Here the occurrence analyser
1240 -- linearity context knows that c,n are one-shot, and it records that fact in
1241 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
1243 oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs
1246 go _ [] rev_bndrs = reverse rev_bndrs
1248 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
1249 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
1251 bndr' | lin_ctxt = setOneShotLambda bndr
1254 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1256 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1257 addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
1258 = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }
1261 %************************************************************************
1265 %************************************************************************
1268 type ImpRuleUsage = NameEnv UsageDetails
1269 -- Maps an *imported* Id f to the UsageDetails for *local* Ids
1270 -- used on the RHS for a *local* rule for f.
1275 Consider this, where A.g is an imported Id
1278 {-# RULE "foo" forall x. A.g x = f x #-}
1280 Obviously there's a loop, but the danger is that the occurrence analyser
1281 will say that 'f' is not a loop breaker. Then the simplifier will
1284 and then gaily inline 'f'. Result infinite loop. More realistically,
1285 these kind of rules are generated when specialising imported INLINABLE Ids.
1287 Solution: treat an occurrence of A.g as an occurrence of all the local Ids
1288 that occur on the RULE's RHS. This mapping from imported Id to local Ids
1289 is held in occ_rule_fvs.
1292 findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage
1293 -- Find the *local* Ids that can be reached transitively,
1294 -- via local rules, from each *imported* Id.
1295 -- Sigh: this function seems more complicated than it is really worth
1296 findImpRuleUsage Nothing _ = emptyNameEnv
1297 findImpRuleUsage (Just is_active) rules
1298 = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
1300 , let ls = find_lcl_deps f
1301 , not (isEmptyVarSet ls) ]
1303 rule_names = map ru_fn rules
1304 rule_name_set = mkNameSet rule_names
1306 imp_deps :: NameEnv VarSet
1307 -- (f,g) means imported Id 'g' appears in RHS of
1308 -- rule for imported Id 'f', *or* does so transitively
1309 imp_deps = foldr add_imp emptyNameEnv rules
1311 | is_active (ruleActivation rule)
1312 = extendNameEnv_C unionVarSet acc (ru_fn rule)
1313 (exprSomeFreeVars keep_imp (ru_rhs rule))
1315 keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
1316 full_imp_deps = transClosureFV (ufmToList imp_deps)
1318 lcl_deps :: NameEnv VarSet
1319 -- (f, l) means localId 'l' appears immediately
1320 -- in the RHS of a rule for imported Id 'f'
1321 -- Remember, many rules might have the same ru_fn
1322 -- so we do need to fold
1323 lcl_deps = foldr add_lcl emptyNameEnv rules
1324 add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule)
1325 (exprFreeIds (ru_rhs rule))
1327 find_lcl_deps :: Name -> VarSet
1329 = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f)
1330 (lookupNameEnv full_imp_deps f `orElse` emptyVarSet)
1331 lookup_lcl :: Name -> VarSet
1332 lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet
1335 transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet
1336 -- If (f,g), (g,h) are in the input, then (f,h) is in the output
1337 transClosureFV fv_list
1339 | otherwise = transClosureFV new_fv_list
1341 env = listToUFM fv_list
1342 (no_change, new_fv_list) = mapAccumL bump True fv_list
1343 bump no_change (b,fvs)
1344 | no_change_here = (no_change, (b,fvs))
1345 | otherwise = (False, (b,new_fvs))
1347 (new_fvs, no_change_here) = extendFvs env fvs
1350 extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
1351 -- (extendFVs env s) returns
1352 -- (s `union` env(s), env(s) `subset` s)
1354 = foldVarSet add (s, True) s
1356 add v (vs, no_change_so_far)
1357 = case lookupUFM env v of
1358 Just fvs | not (fvs `subVarSet` s)
1359 -> (vs `unionVarSet` fvs, False)
1360 _ -> (vs, no_change_so_far)
1364 %************************************************************************
1368 %************************************************************************
1371 data ProxyEnv -- See Note [ProxyEnv]
1372 = PE (IdEnv -- Domain = scrutinee variables
1373 (Id, -- The scrutinee variable again
1374 [(Id,Coercion)])) -- The case binders that it maps to
1375 VarSet -- Free variables of both range and domain
1380 The ProxyEnv keeps track of the connection between case binders and
1381 scrutinee. Specifically, if
1382 sc |-> (sc, [...(cb, co)...])
1383 is a binding in the ProxyEnv, then
1385 Typically we add such a binding when encountering the case expression
1386 case (sc |> coi) of cb { ... }
1389 * The domain of the ProxyEnv is the variable (or casted variable)
1390 scrutinees of enclosing cases. This is additionally used
1391 to ensure we gather occurrence info even for GlobalId scrutinees;
1392 see Note [Binder swap for GlobalId scrutinee]
1394 * The ProxyEnv is just an optimisation; you can throw away any
1395 element without losing correctness. And we do so when pushing
1396 it inside a binding (see trimProxyEnv).
1398 * One scrutinee might map to many case binders: Eg
1399 case sc of cb1 { DEFAULT -> ....case sc of cb2 { ... } .. }
1402 * If sc1 |-> (sc2, [...(cb, co)...]), then sc1==sc2
1403 It's a UniqFM and we sometimes need the domain Id
1405 * Any particular case binder 'cb' occurs only once in entire range
1409 The Main Reason for having a ProxyEnv is so that when we encounter
1410 case e of cb { pi -> ri }
1411 we can find all the in-scope variables derivable from 'cb',
1412 and effectively add let-bindings for them (or at least for the
1413 ones *mentioned* in ri) thus:
1414 case e of cb { pi -> let { x = ..cb..; y = ...cb.. }
1416 In this way we'll replace occurrences of 'x', 'y' with 'cb',
1417 which implements the Binder-swap idea (see Note [Binder swap])
1419 The function getProxies finds these bindings; then we
1420 add just the necessary ones, using wrapProxy.
1424 We do these two transformations right here:
1426 (1) case x of b { pi -> ri }
1428 case x of b { pi -> let x=b in ri }
1430 (2) case (x |> co) of b { pi -> ri }
1432 case (x |> co) of b { pi -> let x = b |> sym co in ri }
1434 Why (2)? See Note [Case of cast]
1436 In both cases, in a particular alternative (pi -> ri), we only
1438 (a) x occurs free in (pi -> ri)
1439 (ie it occurs in ri, but is not bound in pi)
1440 (b) the pi does not bind b (or the free vars of co)
1441 We need (a) and (b) for the inserted binding to be correct.
1443 For the alternatives where we inject the binding, we can transfer
1444 all x's OccInfo to b. And that is the point.
1447 * The deliberate shadowing of 'x'.
1448 * That (a) rapidly becomes false, so no bindings are injected.
1450 The reason for doing these transformations here is because it allows
1451 us to adjust the OccInfo for 'x' and 'b' as we go.
1453 * Suppose the only occurrences of 'x' are the scrutinee and in the
1454 ri; then this transformation makes it occur just once, and hence
1455 get inlined right away.
1457 * If we do this in the Simplifier, we don't know whether 'x' is used
1458 in ri, so we are forced to pessimistically zap b's OccInfo even
1459 though it is typically dead (ie neither it nor x appear in the
1460 ri). There's nothing actually wrong with zapping it, except that
1461 it's kind of nice to know which variables are dead. My nose
1462 tells me to keep this information as robustly as possible.
1464 The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
1465 {x=b}; it's Nothing if the binder-swap doesn't happen.
1467 There is a danger though. Consider
1469 in case (f v) of w -> ...v...v...
1470 And suppose that (f v) expands to just v. Then we'd like to
1471 use 'w' instead of 'v' in the alternative. But it may be too
1472 late; we may have substituted the (cheap) x+#y for v in the
1473 same simplifier pass that reduced (f v) to v.
1475 I think this is just too bad. CSE will recover some of it.
1479 Consider case (x `cast` co) of b { I# ->
1480 ... (case (x `cast` co) of {...}) ...
1481 We'd like to eliminate the inner case. That is the motivation for
1482 equation (2) in Note [Binder swap]. When we get to the inner case, we
1483 inline x, cancel the casts, and away we go.
1485 Note [Binder swap on GlobalId scrutinees]
1486 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1487 When the scrutinee is a GlobalId we must take care in two ways
1489 i) In order to *know* whether 'x' occurs free in the RHS, we need its
1490 occurrence info. BUT, we don't gather occurrence info for
1491 GlobalIds. That's one use for the (small) occ_proxy env in OccEnv is
1492 for: it says "gather occurrence info for these.
1494 ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
1495 has an External Name. See, for example, SimplEnv Note [Global Ids in
1498 Note [getProxies is subtle]
1499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1500 The code for getProxies isn't all that obvious. Consider
1502 case v |> cov of x { DEFAULT ->
1503 case x |> cox1 of y { DEFAULT ->
1504 case x |> cox2 of z { DEFAULT -> r
1506 These will give us a ProxyEnv looking like:
1507 x |-> (x, [(y, cox1), (z, cox2)])
1508 v |-> (v, [(x, cov)])
1510 From this we want to extract the bindings
1515 Notice that later bindings may mention earlier ones, and that
1516 we need to go "both ways".
1518 Note [Zap case binders in proxy bindings]
1519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1521 case x of cb(dead) { p -> ...x... }
1523 case x of cb(live) { p -> let x = cb in ...x... }
1525 Core Lint never expects to find an *occurence* of an Id marked
1526 as Dead, so we must zap the OccInfo on cb before making the
1527 binding x = cb. See Trac #5028.
1529 Historical note [no-case-of-case]
1530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1531 We *used* to suppress the binder-swap in case expressions when
1532 -fno-case-of-case is on. Old remarks:
1533 "This happens in the first simplifier pass,
1534 and enhances full laziness. Here's the bad case:
1535 f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1536 If we eliminate the inner case, we trap it inside the I# v -> arm,
1537 which might prevent some full laziness happening. I've seen this
1538 in action in spectral/cichelli/Prog.hs:
1539 [(m,n) | m <- [1..max], n <- [1..max]]
1540 Hence the check for NoCaseOfCase."
1541 However, now the full-laziness pass itself reverses the binder-swap, so this
1542 check is no longer necessary.
1544 Historical note [Suppressing the case binder-swap]
1545 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1546 This old note describes a problem that is also fixed by doing the
1547 binder-swap in OccAnal:
1549 There is another situation when it might make sense to suppress the
1550 case-expression binde-swap. If we have
1552 case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1553 ...other cases .... }
1555 We'll perform the binder-swap for the outer case, giving
1557 case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1558 ...other cases .... }
1560 But there is no point in doing it for the inner case, because w1 can't
1561 be inlined anyway. Furthermore, doing the case-swapping involves
1562 zapping w2's occurrence info (see paragraphs that follow), and that
1563 forces us to bind w2 when doing case merging. So we get
1565 case x of w1 { A -> let w2 = w1 in e1
1566 B -> let w2 = w1 in e2
1567 ...other cases .... }
1569 This is plain silly in the common case where w2 is dead.
1571 Even so, I can't see a good way to implement this idea. I tried
1572 not doing the binder-swap if the scrutinee was already evaluated
1573 but that failed big-time:
1577 case v of w { MkT x ->
1578 case x of x1 { I# y1 ->
1579 case x of x2 { I# y2 -> ...
1581 Notice that because MkT is strict, x is marked "evaluated". But to
1582 eliminate the last case, we must either make sure that x (as well as
1583 x1) has unfolding MkT y1. THe straightforward thing to do is to do
1584 the binder-swap. So this whole note is a no-op.
1586 It's fixed by doing the binder-swap in OccAnal because we can do the
1587 binder-swap unconditionally and still get occurrence analysis
1591 extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv
1592 -- (extendPE x co y) typically arises from
1593 -- case (x |> co) of y { ... }
1594 -- It extends the proxy env with the binding
1596 extendProxyEnv pe scrut co case_bndr
1597 | scrut == case_bndr = PE env1 fvs1 -- If case_bndr shadows scrut,
1598 | otherwise = PE env2 fvs2 -- don't extend
1600 PE env1 fvs1 = trimProxyEnv pe [case_bndr]
1601 env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
1602 single cb_co = (scrut1, [cb_co])
1603 add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
1604 fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co
1605 `extendVarSet` case_bndr
1606 `extendVarSet` scrut1
1608 scrut1 = mkLocalId (localiseName (idName scrut)) (idType scrut)
1609 -- Localise the scrut_var before shadowing it; we're making a
1610 -- new binding for it, and it might have an External Name, or
1611 -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
1612 -- Also we don't want any INLINE or NOINLINE pragmas!
1615 type ProxyBind = (Id, Id, Coercion)
1616 -- (scrut variable, case-binder variable, coercion)
1618 getProxies :: OccEnv -> Id -> Bag ProxyBind
1619 -- Return a bunch of bindings [...(xi,ei)...]
1620 -- such that let { ...; xi=ei; ... } binds the xi using y alone
1621 -- See Note [getProxies is subtle]
1622 getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
1623 = -- pprTrace "wrapProxies" (ppr case_bndr) $
1626 fwd_pe :: IdEnv (Id, Coercion)
1627 fwd_pe = foldVarEnv add1 emptyVarEnv pe
1629 add1 (x,ycos) env = foldr (add2 x) env ycos
1630 add2 x (y,co) env = extendVarEnv env y (x,co)
1632 go_fwd :: Id -> Bag ProxyBind
1633 -- Return bindings derivable from case_bndr
1634 go_fwd case_bndr = -- pprTrace "go_fwd" (vcat [ppr case_bndr, text "fwd_pe =" <+> ppr fwd_pe,
1635 -- text "pe =" <+> ppr pe]) $
1639 | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
1640 = unitBag (scrut, case_bndr, mkSymCo co)
1641 `unionBags` go_fwd scrut
1642 `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
1647 lookup_bwd :: Id -> [(Id, Coercion)]
1648 -- Return case_bndrs that are connected to scrut
1649 lookup_bwd scrut = case lookupVarEnv pe scrut of
1651 Just (_, cb_cos) -> cb_cos
1653 go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind
1654 go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
1656 go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind
1657 go_bwd1 scrut (case_bndr, co)
1658 = -- pprTrace "go_bwd1" (ppr case_bndr) $
1659 unitBag (case_bndr, scrut, co)
1660 `unionBags` go_bwd case_bndr (lookup_bwd case_bndr)
1663 mkAltEnv :: OccEnv -> CoreExpr -> Id -> OccEnv
1664 -- Does two things: a) makes the occ_ctxt = OccVanilla
1665 -- b) extends the ProxyEnv if possible
1666 mkAltEnv env scrut cb
1667 = env { occ_encl = OccVanilla, occ_proxy = pe' }
1671 Var v -> extendProxyEnv pe v (mkReflCo (idType v)) cb
1672 Cast (Var v) co -> extendProxyEnv pe v co cb
1673 _other -> trimProxyEnv pe [cb]
1676 trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
1677 trimOccEnv env bndrs = env { occ_proxy = trimProxyEnv (occ_proxy env) bndrs }
1680 trimProxyEnv :: ProxyEnv -> [CoreBndr] -> ProxyEnv
1681 -- We are about to push this ProxyEnv inside a binding for 'bndrs'
1682 -- So dump any ProxyEnv bindings which mention any of the bndrs
1683 trimProxyEnv (PE pe fvs) bndrs
1684 | not (bndr_set `intersectsVarSet` fvs)
1687 = PE pe' (fvs `minusVarSet` bndr_set)
1689 pe' = mapVarEnv trim pe
1690 bndr_set = mkVarSet bndrs
1691 trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
1692 | otherwise = (scrut, filterOut discard cb_cos)
1693 discard (cb,co) = bndr_set `intersectsVarSet`
1694 extendVarSet (tyCoVarsOfCo co) cb
1698 %************************************************************************
1700 \subsection[OccurAnal-types]{OccEnv}
1702 %************************************************************************
1705 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
1706 -- INVARIANT: never IAmDead
1707 -- (Deadness is signalled by not being in the map at all)
1709 (+++), combineAltsUsageDetails
1710 :: UsageDetails -> UsageDetails -> UsageDetails
1713 = plusVarEnv_C addOccInfo usage1 usage2
1715 combineAltsUsageDetails usage1 usage2
1716 = plusVarEnv_C orOccInfo usage1 usage2
1718 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1719 addOneOcc usage id info
1720 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1721 -- ToDo: make this more efficient
1723 emptyDetails :: UsageDetails
1724 emptyDetails = (emptyVarEnv :: UsageDetails)
1726 usedIn :: Id -> UsageDetails -> Bool
1727 v `usedIn` details = isExportedId v || v `elemVarEnv` details
1729 type IdWithOccInfo = Id
1731 tagLamBinders :: UsageDetails -- Of scope
1733 -> (UsageDetails, -- Details with binders removed
1734 [IdWithOccInfo]) -- Tagged binders
1735 -- Used for lambda and case binders
1736 -- It copes with the fact that lambda bindings can have InlineRule
1737 -- unfoldings, used for join points
1738 tagLamBinders usage binders = usage' `seq` (usage', bndrs')
1740 (usage', bndrs') = mapAccumR tag_lam usage binders
1741 tag_lam usage bndr = (usage2, setBinderOcc usage bndr)
1743 usage1 = usage `delVarEnv` bndr
1744 usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr)
1745 | otherwise = usage1
1747 tagBinder :: UsageDetails -- Of scope
1749 -> (UsageDetails, -- Details with binders removed
1750 IdWithOccInfo) -- Tagged binders
1752 tagBinder usage binder
1754 usage' = usage `delVarEnv` binder
1755 binder' = setBinderOcc usage binder
1757 usage' `seq` (usage', binder')
1759 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1760 setBinderOcc usage bndr
1761 | isTyVar bndr = bndr
1762 | isExportedId bndr = case idOccInfo bndr of
1764 _ -> setIdOccInfo bndr NoOccInfo
1765 -- Don't use local usage info for visible-elsewhere things
1766 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1767 -- about to re-generate it and it shouldn't be "sticky"
1769 | otherwise = setIdOccInfo bndr occ_info
1771 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1775 %************************************************************************
1777 \subsection{Operations over OccInfo}
1779 %************************************************************************
1782 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1783 mkOneOcc env id int_cxt
1784 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1785 | PE env _ <- occ_proxy env
1786 , id `elemVarEnv` env = unitVarEnv id NoOccInfo
1787 | Just uds <- lookupNameEnv (occ_rule_fvs env) (idName id)
1789 | otherwise = emptyDetails
1791 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1793 markMany _ = NoOccInfo
1795 markInsideSCC occ = markMany occ
1797 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1798 markInsideLam occ = occ
1800 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1802 addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
1803 NoOccInfo -- Both branches are at least One
1804 -- (Argument is never IAmDead)
1806 -- (orOccInfo orig new) is used
1807 -- when combining occurrence info from branches of a case
1809 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1810 (OneOcc in_lam2 _ int_cxt2)
1811 = OneOcc (in_lam1 || in_lam2)
1812 False -- False, because it occurs in both branches
1813 (int_cxt1 && int_cxt2)
1814 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )