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 -- The above warning supression flag is a temporary kludge.
16 -- While working on this module you are encouraged to remove it and fix
17 -- any warnings in the module. See
18 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 occurAnalysePgm, occurAnalyseExpr
25 #include "HsVersions.h"
28 import CoreFVs ( idRuleVars )
29 import CoreUtils ( exprIsTrivial, isDefaultAlt )
32 import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
37 import Maybes ( orElse )
38 import Digraph ( stronglyConnCompR, SCC(..) )
39 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
40 import Unique ( Unique )
41 import UniqFM ( keysUFM, intersectsUFM, intersectUFM_C, foldUFM_Directly )
42 import Util ( mapAndUnzip )
49 %************************************************************************
51 \subsection[OccurAnal-main]{Counting occurrences: main function}
53 %************************************************************************
55 Here's the externally-callable interface:
58 occurAnalysePgm :: [CoreBind] -> [CoreBind]
60 = snd (go initOccEnv binds)
62 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
66 = (final_usage, bind' ++ binds')
68 (bs_usage, binds') = go env binds
69 (final_usage, bind') = occAnalBind env bind bs_usage
71 occurAnalyseExpr :: CoreExpr -> CoreExpr
72 -- Do occurrence analysis, and discard occurence info returned
73 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
77 %************************************************************************
79 \subsection[OccurAnal-main]{Counting occurrences: main function}
81 %************************************************************************
89 -> UsageDetails -- Usage details of scope
90 -> (UsageDetails, -- Of the whole let(rec)
93 occAnalBind env (NonRec binder rhs) body_usage
94 | not (binder `usedIn` body_usage) -- It's not mentioned
97 | otherwise -- It's mentioned in the body
98 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
99 [NonRec tagged_binder rhs'])
101 (body_usage', tagged_binder) = tagBinder body_usage binder
102 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
107 Dropping dead code for recursive bindings is done in a very simple way:
109 the entire set of bindings is dropped if none of its binders are
110 mentioned in its body; otherwise none are.
112 This seems to miss an obvious improvement.
124 Now 'f' is unused! But it's OK! Dependency analysis will sort this
125 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
126 dropped. It isn't easy to do a perfect job in one blow. Consider
137 Note [Loop breaking and RULES]
138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
139 Loop breaking is surprisingly subtle. First read the section 4 of
140 "Secrets of the GHC inliner". This describes our basic plan.
142 However things are made quite a bit more complicated by RULES. Remember
144 * Note [Rules are extra RHSs]
145 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
147 keeps the specialised "children" alive. If the parent dies
148 (because it isn't referenced any more), then the children will die
149 too (unless they are already referenced directly).
151 To that end, we build a Rec group for each cyclic strongly
153 *treating f's rules as extra RHSs for 'f'*.
155 So in Example [eftInt], eftInt and eftIntFB will be put in the
156 same Rec, even though their 'main' RHSs are both non-recursive.
158 * Note [Rules are visible in their own rec group]
159 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
160 We want the rules for 'f' to be visible in f's right-hand side.
161 And we'd like them to be visible in other function in f's Rec
162 group. E.g. in Example [Specialisation rules] we want f' rule
163 to be visible in both f's RHS, and fs's RHS.
165 This means that we must simplify the RULEs first, before looking
166 at any of the definitions. This is done by Simplify.simplRecBind,
167 when it calls addLetIdInfo.
169 * Note [Choosing loop breakers]
170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
171 We avoid infinite inlinings by choosing loop breakers, and
172 ensuring that a loop breaker cuts each loop. But what is a
173 "loop"? In particular, a RULES is like an equation for 'f' that
174 is *always* inlined if it are applicable. We do *not* disable
175 rules for loop-breakers. It's up to whoever makes the rules to
176 make sure that the rules themselves alwasys terminate. See Note
177 [Rules for recursive functions] in Simplify.lhs
180 f's RHS mentions g, and
181 g has a RULE that mentions h, and
182 h has a RULE that mentions f
184 then we *must* choose f to be a loop breaker. In general, take the
185 free variables of f's RHS, and augment it with all the variables
186 reachable by RULES from those starting points. That is the whole
187 reason for computing rule_fv_env in occAnalBind. (Of course we
188 only consider free vars that are also binders in this Rec group.)
190 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
191 chosen as a loop breaker, because their RHSs don't mention each other.
192 And indeed both can be inlined safely.
194 Note that the edges of the graph we use for computing loop breakers
195 are not the same as the edges we use for computing the Rec blocks.
196 That's why we compute
197 rec_edges for the Rec block analysis
198 loop_breaker_edges for the loop breaker analysis
201 * Note [Weak loop breakers]
202 ~~~~~~~~~~~~~~~~~~~~~~~~~
203 There is a last nasty wrinkle. Suppose we have
213 Remmber that we simplify the RULES before any RHS (see Note
214 [Rules are visible in their own rec group] above).
216 So we must *not* postInlineUnconditinoally 'g', even though
217 its RHS turns out to be trivial. (I'm assuming that 'g' is
218 not choosen as a loop breaker.)
220 We "solve" this by making g a "weak" or "rules-only" loop breaker,
221 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
222 has IAmLoopBreaker False. So
224 Inline postInlineUnconditinoally
225 IAmLoopBreaker False no no
226 IAmLoopBreaker True yes no
229 The **sole** reason for this kind of loop breaker is so that
230 postInlineUnconditioanlly does not fire. Ugh.
235 Example (from GHC.Enum):
237 eftInt :: Int# -> Int# -> [Int]
238 eftInt x y = ...(non-recursive)...
240 {-# INLINE [0] eftIntFB #-}
241 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
242 eftIntFB c n x y = ...(non-recursive)...
245 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
246 "eftIntList" [1] eftIntFB (:) [] = eftInt
249 Example [Specialisation rules]
250 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
251 Consider this group, which is typical of what SpecConstr builds:
253 fs a = ....f (C a)....
254 f x = ....f (C a)....
255 {-# RULE f (C a) = fs a #-}
257 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
259 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
260 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
261 - fs is inlined (say it's small)
262 - now there's another opportunity to apply the RULE
264 This showed up when compiling Control.Concurrent.Chan.getChanContents.
268 occAnalBind env (Rec pairs) body_usage
269 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
270 = (body_usage, []) -- Dead code
272 = (final_usage, map ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) sccs)
274 bndrs = map fst pairs
275 bndr_set = mkVarSet bndrs
277 ---------------------------------------
278 -- See Note [Loop breaking]
279 ---------------------------------------
281 -------------Dependency analysis ------------------------------
282 occ_anald :: [(Id, (UsageDetails, CoreExpr))]
283 -- The UsageDetails here are strictly those arising from the RHS
284 -- *not* from any rules in the Id
285 occ_anald = [(bndr, occAnalRhs env bndr rhs) | (bndr,rhs) <- pairs]
287 total_usage = foldl add_usage body_usage occ_anald
288 add_usage body_usage (bndr, (rhs_usage, _))
289 = body_usage +++ addRuleUsage rhs_usage bndr
291 (final_usage, tagged_bndrs) = tagBinders total_usage bndrs
292 final_bndrs | no_rules = tagged_bndrs
293 | otherwise = map tag_rule_var tagged_bndrs
294 tag_rule_var bndr | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr
297 ---- stuff for dependency analysis of binds -------------------------------
298 sccs :: [SCC (Node Details)]
299 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges
301 rec_edges :: [Node Details] -- The binders are tagged with correct occ-info
302 rec_edges = {-# SCC "occAnalBind.assoc" #-} zipWith make_node final_bndrs occ_anald
303 make_node tagged_bndr (_bndr, (rhs_usage, rhs))
304 = ((tagged_bndr, rhs, rhs_fvs), idUnique tagged_bndr, out_edges)
306 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
307 out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars tagged_bndr)
310 -- (a -> b) means a mentions b
311 -- Given the usage details (a UFM that gives occ info for each free var of
312 -- the RHS) we can get the list of free vars -- or rather their Int keys --
313 -- by just extracting the keys from the finite map. Grimy, but fast.
314 -- Previously we had this:
315 -- [ bndr | bndr <- bndrs,
316 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
317 -- which has n**2 cost, and this meant that edges_from alone
318 -- consumed 10% of total runtime!
320 ---- Stuff to "re-constitute" bindings from dependency-analysis info ------
321 do_final_bind (AcyclicSCC ((bndr, rhs, _), _, _)) = NonRec bndr rhs
322 do_final_bind (CyclicSCC cycle)
323 | no_rules = Rec (reOrderCycle cycle)
324 | otherwise = Rec (concatMap reOrderRec (stronglyConnCompR loop_breaker_edges))
325 where -- See Note [Loop breaking for reason for looop_breker_edges]
326 loop_breaker_edges = map mk_node cycle
327 mk_node (details@(bndr, rhs, rhs_fvs), k, _) = (details, k, new_ks)
329 new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
332 ------------------------------------
333 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
334 -- Domain is *subset* of bound vars (others have no rule fvs)
335 rule_fv_env = rule_loop init_rule_fvs
337 no_rules = null init_rule_fvs
338 all_rule_fvs = foldr (unionVarSet . snd) emptyVarSet init_rule_fvs
339 init_rule_fvs = [(b, rule_fvs)
341 , let rule_fvs = idRuleVars b `intersectVarSet` bndr_set
342 , not (isEmptyVarSet rule_fvs)]
344 rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
347 | otherwise = rule_loop new_fv_list
349 env = mkVarEnv init_rule_fvs
350 (no_change, new_fv_list) = mapAccumL bump True fv_list
351 bump no_change (b,fvs)
352 | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
353 | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
355 new_fvs = extendFvs env emptyVarSet fvs
357 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
358 -- (extendFVs env fvs s) returns (fvs `union` env(s))
359 extendFvs env fvs id_set
360 = foldUFM_Directly add fvs id_set
363 = case lookupVarEnv_Directly env uniq of
364 Just fvs' -> fvs' `unionVarSet` fvs
368 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
369 strongly connected component (there's guaranteed to be a cycle). It returns the
371 a) in a better order,
372 b) with some of the Ids having a IAmALoopBreaker pragma
374 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
375 that the simplifier can guarantee not to loop provided it never records an inlining
376 for these no-inline guys.
378 Furthermore, the order of the binds is such that if we neglect dependencies
379 on the no-inline Ids then the binds are topologically sorted. This means
380 that the simplifier will generally do a good job if it works from top bottom,
381 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
384 [June 98: I don't understand the following paragraphs, and I've
385 changed the a=b case again so that it isn't a special case any more.]
387 Here's a case that bit me:
395 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
397 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
398 Perhaps something cleverer would suffice.
403 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
404 -- which is gotten from the Id.
405 type Details = (Id, -- Binder
407 IdSet) -- RHS free vars (*not* include rules)
409 reOrderRec :: SCC (Node Details)
411 -- Sorted into a plausible order. Enough of the Ids have
412 -- IAmALoopBreaker pragmas that there are no loops left.
413 reOrderRec (AcyclicSCC ((bndr, rhs, _), _, _)) = [(bndr, rhs)]
414 reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
416 reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
418 = panic "reOrderCycle"
419 reOrderCycle [bind] -- Common case of simple self-recursion
420 = [(makeLoopBreaker False bndr, rhs)]
422 ((bndr, rhs, _), _, _) = bind
424 reOrderCycle (bind : binds)
425 = -- Choose a loop breaker, mark it no-inline,
426 -- do SCC analysis on the rest, and recursively sort them out
427 concatMap reOrderRec (stronglyConnCompR unchosen) ++
428 [(makeLoopBreaker False bndr, rhs)]
431 (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
432 (bndr, rhs, _) = chosen_bind
434 -- This loop looks for the bind with the lowest score
435 -- to pick as the loop breaker. The rest accumulate in
436 choose_loop_breaker (details,_,_) loop_sc acc []
437 = (details, acc) -- Done
439 choose_loop_breaker loop_bind loop_sc acc (bind : binds)
440 | sc < loop_sc -- Lower score so pick this new one
441 = choose_loop_breaker bind sc (loop_bind : acc) binds
443 | otherwise -- No lower so don't pick it
444 = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
448 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
449 score ((bndr, rhs, _), _, _)
450 | workerExists (idWorkerInfo bndr) = 10
451 -- Note [Worker inline loop]
453 | exprIsTrivial rhs = 4 -- Practically certain to be inlined
454 -- Used to have also: && not (isExportedId bndr)
455 -- But I found this sometimes cost an extra iteration when we have
456 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
457 -- where df is the exported dictionary. Then df makes a really
458 -- bad choice for loop breaker
460 | is_con_app rhs = 2 -- Data types help with cases
463 | inlineCandidate bndr rhs = 1 -- Likely to be inlined
464 -- Note [Inline candidates]
468 inlineCandidate :: Id -> CoreExpr -> Bool
469 inlineCandidate id (Note InlineMe _) = True
470 inlineCandidate id rhs = isOneOcc (idOccInfo id)
474 -- It's really really important to inline dictionaries. Real
475 -- example (the Enum Ordering instance from GHC.Base):
477 -- rec f = \ x -> case d of (p,q,r) -> p x
478 -- g = \ x -> case d of (p,q,r) -> q x
481 -- Here, f and g occur just once; but we can't inline them into d.
482 -- On the other hand we *could* simplify those case expressions if
483 -- we didn't stupidly choose d as the loop breaker.
484 -- But we won't because constructor args are marked "Many".
485 -- Inlining dictionaries is really essential to unravelling
486 -- the loops in static numeric dictionaries, see GHC.Float.
488 -- Cheap and cheerful; the simplifer moves casts out of the way
489 -- The lambda case is important to spot x = /\a. C (f a)
490 -- which comes up when C is a dictionary constructor and
491 -- f is a default method.
492 -- Example: the instance for Show (ST s a) in GHC.ST
494 -- However we *also* treat (\x. C p q) as a con-app-like thing,
495 -- Note [Closure conversion]
496 is_con_app (Var v) = isDataConWorkId v
497 is_con_app (App f _) = is_con_app f
498 is_con_app (Lam b e) = is_con_app e
499 is_con_app (Note _ e) = is_con_app e
500 is_con_app other = False
502 makeLoopBreaker :: Bool -> Id -> Id
503 -- Set the loop-breaker flag
504 -- See Note [Weak loop breakers]
505 makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
508 Note [Worker inline loop]
509 ~~~~~~~~~~~~~~~~~~~~~~~~
510 Never choose a wrapper as the loop breaker! Because
511 wrappers get auto-generated inlinings when importing, and
512 that can lead to an infinite inlining loop. For example:
514 $wfoo x = ....foo x....
516 {-loop brk-} foo x = ...$wfoo x...
519 The interface file sees the unfolding for $wfoo, and sees that foo is
520 strict (and hence it gets an auto-generated wrapper). Result: an
521 infinite inlining in the importing scope. So be a bit careful if you
522 change this. A good example is Tree.repTree in
523 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
524 breaker then compiling Game.hs goes into an infinite loop (this
525 happened when we gave is_con_app a lower score than inline candidates).
527 Note [Closure conversion]
528 ~~~~~~~~~~~~~~~~~~~~~~~~~
529 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
530 The immediate motivation came from the result of a closure-conversion transformation
531 which generated code like this:
533 data Clo a b = forall c. Clo (c -> a -> b) c
535 ($:) :: Clo a b -> a -> b
536 Clo f env $: x = f env x
538 rec { plus = Clo plus1 ()
540 ; plus1 _ n = Clo plus2 n
543 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
545 If we inline 'plus' and 'plus1', everything unravels nicely. But if
546 we choose 'plus1' as the loop breaker (which is entirely possible
547 otherwise), the loop does not unravel nicely.
550 @occAnalRhs@ deals with the question of bindings where the Id is marked
551 by an INLINE pragma. For these we record that anything which occurs
552 in its RHS occurs many times. This pessimistically assumes that ths
553 inlined binder also occurs many times in its scope, but if it doesn't
554 we'll catch it next time round. At worst this costs an extra simplifier pass.
555 ToDo: try using the occurrence info for the inline'd binder.
557 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
558 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
563 -> Id -> CoreExpr -- Binder and rhs
564 -- For non-recs the binder is alrady tagged
565 -- with occurrence info
566 -> (UsageDetails, CoreExpr)
568 occAnalRhs env id rhs
571 ctxt | certainly_inline id = env
572 | otherwise = rhsCtxt
573 -- Note that we generally use an rhsCtxt. This tells the occ anal n
574 -- that it's looking at an RHS, which has an effect in occAnalApp
576 -- But there's a problem. Consider
581 -- First time round, it looks as if x1 and x2 occur as an arg of a
582 -- let-bound constructor ==> give them a many-occurrence.
583 -- But then x3 is inlined (unconditionally as it happens) and
584 -- next time round, x2 will be, and the next time round x1 will be
585 -- Result: multiple simplifier iterations. Sigh.
586 -- Crude solution: use rhsCtxt for things that occur just once...
588 certainly_inline id = case idOccInfo id of
589 OneOcc in_lam one_br _ -> not in_lam && one_br
596 addRuleUsage :: UsageDetails -> Id -> UsageDetails
597 -- Add the usage from RULES in Id to the usage
598 addRuleUsage usage id
599 = foldVarSet add usage (idRuleVars id)
601 add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info
602 -- (i.e manyOcc) because many copies
603 -- of the specialised thing can appear
611 -> (UsageDetails, -- Gives info only about the "interesting" Ids
614 occAnal env (Type t) = (emptyDetails, Type t)
615 occAnal env (Var v) = (mkOneOcc env v False, Var v)
616 -- At one stage, I gathered the idRuleVars for v here too,
617 -- which in a way is the right thing to do.
618 -- Btu that went wrong right after specialisation, when
619 -- the *occurrences* of the overloaded function didn't have any
620 -- rules in them, so the *specialised* versions looked as if they
621 -- weren't used at all.
624 We regard variables that occur as constructor arguments as "dangerousToDup":
628 f x = let y = expensive x in
630 (case z of {(p,q)->q}, case z of {(p,q)->q})
633 We feel free to duplicate the WHNF (True,y), but that means
634 that y may be duplicated thereby.
636 If we aren't careful we duplicate the (expensive x) call!
637 Constructors are rather like lambdas in this way.
640 occAnal env expr@(Lit lit) = (emptyDetails, expr)
644 occAnal env (Note InlineMe body)
645 = case occAnal env body of { (usage, body') ->
646 (mapVarEnv markMany usage, Note InlineMe body')
649 occAnal env (Note note@(SCC cc) body)
650 = case occAnal env body of { (usage, body') ->
651 (mapVarEnv markInsideSCC usage, Note note body')
654 occAnal env (Note note body)
655 = case occAnal env body of { (usage, body') ->
656 (usage, Note note body')
659 occAnal env (Cast expr co)
660 = case occAnal env expr of { (usage, expr') ->
661 (markRhsUds env True usage, Cast expr' co)
662 -- If we see let x = y `cast` co
663 -- then mark y as 'Many' so that we don't
664 -- immediately inline y again.
669 occAnal env app@(App fun arg)
670 = occAnalApp env (collectArgs app) False
672 -- Ignore type variables altogether
673 -- (a) occurrences inside type lambdas only not marked as InsideLam
674 -- (b) type variables not in environment
676 occAnal env expr@(Lam x body) | isTyVar x
677 = case occAnal env body of { (body_usage, body') ->
678 (body_usage, Lam x body')
681 -- For value lambdas we do a special hack. Consider
683 -- If we did nothing, x is used inside the \y, so would be marked
684 -- as dangerous to dup. But in the common case where the abstraction
685 -- is applied to two arguments this is over-pessimistic.
686 -- So instead, we just mark each binder with its occurrence
687 -- info in the *body* of the multiple lambda.
688 -- Then, the simplifier is careful when partially applying lambdas.
690 occAnal env expr@(Lam _ _)
691 = case occAnal env_body body of { (body_usage, body') ->
693 (final_usage, tagged_binders) = tagBinders body_usage binders
694 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
695 -- we get linear-typed things in the resulting program that we can't handle yet.
696 -- (e.g. PrelShow) TODO
698 really_final_usage = if linear then
701 mapVarEnv markInsideLam final_usage
704 mkLams tagged_binders body') }
706 env_body = vanillaCtxt -- Body is (no longer) an RhsContext
707 (binders, body) = collectBinders expr
708 binders' = oneShotGroup env binders
709 linear = all is_one_shot binders'
710 is_one_shot b = isId b && isOneShotBndr b
712 occAnal env (Case scrut bndr ty alts)
713 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
714 case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
716 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
717 alts_usage' = addCaseBndrUsage alts_usage
718 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
719 total_usage = scrut_usage +++ alts_usage1
721 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
723 -- The case binder gets a usage of either "many" or "dead", never "one".
724 -- Reason: we like to inline single occurrences, to eliminate a binding,
725 -- but inlining a case binder *doesn't* eliminate a binding.
726 -- We *don't* want to transform
727 -- case x of w { (p,q) -> f w }
729 -- case x of w { (p,q) -> f (p,q) }
730 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
732 Just occ -> extendVarEnv usage bndr (markMany occ)
734 alt_env = setVanillaCtxt env
735 -- Consider x = case v of { True -> (p,q); ... }
736 -- Then it's fine to inline p and q
738 occ_anal_scrut (Var v) (alt1 : other_alts)
739 | not (null other_alts) || not (isDefaultAlt alt1)
740 = (mkOneOcc env v True, Var v)
741 occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut
742 -- No need for rhsCtxt
744 occAnal env (Let bind body)
745 = case occAnal env body of { (body_usage, body') ->
746 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
747 (final_usage, mkLets new_binds body') }}
750 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
751 (foldr (+++) emptyDetails arg_uds_s, args')}
753 arg_env = vanillaCtxt
756 Applications are dealt with specially because we want
757 the "build hack" to work.
760 occAnalApp env (Var fun, args) is_rhs
761 = case args_stuff of { (args_uds, args') ->
763 final_args_uds = markRhsUds env is_pap args_uds
765 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
767 fun_uniq = idUnique fun
768 fun_uds = mkOneOcc env fun (valArgCount args > 0)
769 is_pap = isDataConWorkId fun || valArgCount args < idArity fun
771 -- Hack for build, fold, runST
772 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
773 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
774 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
775 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
776 -- (foldr k z xs) may call k many times, but it never
777 -- shares a partial application of k; hence [False,True]
778 -- This means we can optimise
779 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
780 -- by floating in the v
782 | otherwise = occAnalArgs env args
785 occAnalApp env (fun, args) is_rhs
786 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
787 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
788 -- often leaves behind beta redexs like
790 -- Here we would like to mark x,y as one-shot, and treat the whole
791 -- thing much like a let. We do this by pushing some True items
792 -- onto the context stack.
794 case occAnalArgs env args of { (args_uds, args') ->
796 final_uds = fun_uds +++ args_uds
798 (final_uds, mkApps fun' args') }}
801 markRhsUds :: OccEnv -- Check if this is a RhsEnv
802 -> Bool -- and this is true
803 -> UsageDetails -- The do markMany on this
805 -- We mark the free vars of the argument of a constructor or PAP
806 -- as "many", if it is the RHS of a let(rec).
807 -- This means that nothing gets inlined into a constructor argument
808 -- position, which is what we want. Typically those constructor
809 -- arguments are just variables, or trivial expressions.
811 -- This is the *whole point* of the isRhsEnv predicate
812 markRhsUds env is_pap arg_uds
813 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
814 | otherwise = arg_uds
818 -> Int -> CtxtTy -- Argument number, and context to use for it
820 -> (UsageDetails, [CoreExpr])
821 appSpecial env n ctxt args
824 arg_env = vanillaCtxt
826 go n [] = (emptyDetails, []) -- Too few args
828 go 1 (arg:args) -- The magic arg
829 = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
830 case occAnalArgs env args of { (args_uds, args') ->
831 (arg_uds +++ args_uds, arg':args') }}
834 = case occAnal arg_env arg of { (arg_uds, arg') ->
835 case go (n-1) args of { (args_uds, args') ->
836 (arg_uds +++ args_uds, arg':args') }}
842 If the case binder occurs at all, the other binders effectively do too.
844 case e of x { (a,b) -> rhs }
847 If e turns out to be (e1,e2) we indeed get something like
848 let a = e1; b = e2; x = (a,b) in rhs
850 Note [Aug 06]: I don't think this is necessary any more, and it helpe
851 to know when binders are unused. See esp the call to
852 isDeadBinder in Simplify.mkDupableAlt
855 occAnalAlt env case_bndr (con, bndrs, rhs)
856 = case occAnal env rhs of { (rhs_usage, rhs') ->
858 (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
859 final_bndrs = tagged_bndrs -- See Note [Aug06] above
861 final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
862 | otherwise = tagged_bndrs
863 -- Leave the binders untagged if the case
864 -- binder occurs at all; see note above
867 (final_usage, (con, final_bndrs, rhs')) }
871 %************************************************************************
873 \subsection[OccurAnal-types]{OccEnv}
875 %************************************************************************
879 = OccEnv OccEncl -- Enclosing context information
880 CtxtTy -- Tells about linearity
882 -- OccEncl is used to control whether to inline into constructor arguments
884 -- x = (p,q) -- Don't inline p or q
885 -- y = /\a -> (p a, q a) -- Still don't inline p or q
886 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
887 -- So OccEncl tells enought about the context to know what to do when
888 -- we encounter a contructor application or PAP.
891 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
892 -- Don't inline into constructor args here
893 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
894 -- Do inline into constructor args here
899 -- True:ctxt Analysing a function-valued expression that will be
902 -- False:ctxt Analysing a function-valued expression that may
903 -- be applied many times; but when it is,
904 -- the CtxtTy inside applies
907 initOccEnv = OccEnv OccRhs []
909 vanillaCtxt = OccEnv OccVanilla []
910 rhsCtxt = OccEnv OccRhs []
912 isRhsEnv (OccEnv OccRhs _) = True
913 isRhsEnv (OccEnv OccVanilla _) = False
915 setVanillaCtxt :: OccEnv -> OccEnv
916 setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
917 setVanillaCtxt other_env = other_env
919 setCtxt :: OccEnv -> CtxtTy -> OccEnv
920 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
922 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
923 -- The result binders have one-shot-ness set that they might not have had originally.
924 -- This happens in (build (\cn -> e)). Here the occurrence analyser
925 -- linearity context knows that c,n are one-shot, and it records that fact in
926 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
928 oneShotGroup (OccEnv encl ctxt) bndrs
931 go ctxt [] rev_bndrs = reverse rev_bndrs
933 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
934 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
936 bndr' | lin_ctxt = setOneShotLambda bndr
939 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
941 addAppCtxt (OccEnv encl ctxt) args
942 = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
945 %************************************************************************
947 \subsection[OccurAnal-types]{OccEnv}
949 %************************************************************************
952 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
954 (+++), combineAltsUsageDetails
955 :: UsageDetails -> UsageDetails -> UsageDetails
958 = plusVarEnv_C addOccInfo usage1 usage2
960 combineAltsUsageDetails usage1 usage2
961 = plusVarEnv_C orOccInfo usage1 usage2
963 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
964 addOneOcc usage id info
965 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
966 -- ToDo: make this more efficient
968 emptyDetails = (emptyVarEnv :: UsageDetails)
970 usedIn :: Id -> UsageDetails -> Bool
971 v `usedIn` details = isExportedId v || v `elemVarEnv` details
973 type IdWithOccInfo = Id
975 tagBinders :: UsageDetails -- Of scope
977 -> (UsageDetails, -- Details with binders removed
978 [IdWithOccInfo]) -- Tagged binders
980 tagBinders usage binders
982 usage' = usage `delVarEnvList` binders
983 uss = map (setBinderOcc usage) binders
985 usage' `seq` (usage', uss)
987 tagBinder :: UsageDetails -- Of scope
989 -> (UsageDetails, -- Details with binders removed
990 IdWithOccInfo) -- Tagged binders
992 tagBinder usage binder
994 usage' = usage `delVarEnv` binder
995 binder' = setBinderOcc usage binder
997 usage' `seq` (usage', binder')
999 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1000 setBinderOcc usage bndr
1001 | isTyVar bndr = bndr
1002 | isExportedId bndr = case idOccInfo bndr of
1004 other -> setIdOccInfo bndr NoOccInfo
1005 -- Don't use local usage info for visible-elsewhere things
1006 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1007 -- about to re-generate it and it shouldn't be "sticky"
1009 | otherwise = setIdOccInfo bndr occ_info
1011 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1015 %************************************************************************
1017 \subsection{Operations over OccInfo}
1019 %************************************************************************
1022 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1023 mkOneOcc env id int_cxt
1024 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1025 | otherwise = emptyDetails
1027 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1029 markMany IAmDead = IAmDead
1030 markMany other = NoOccInfo
1032 markInsideSCC occ = markMany occ
1034 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1035 markInsideLam occ = occ
1037 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1039 addOccInfo IAmDead info2 = info2
1040 addOccInfo info1 IAmDead = info1
1041 addOccInfo info1 info2 = NoOccInfo
1043 -- (orOccInfo orig new) is used
1044 -- when combining occurrence info from branches of a case
1046 orOccInfo IAmDead info2 = info2
1047 orOccInfo info1 IAmDead = info1
1048 orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
1049 (OneOcc in_lam2 one_branch2 int_cxt2)
1050 = OneOcc (in_lam1 || in_lam2)
1051 False -- False, because it occurs in both branches
1052 (int_cxt1 && int_cxt2)
1053 orOccInfo info1 info2 = NoOccInfo