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 )
30 import Maybes ( orElse )
31 import Digraph ( stronglyConnCompR, SCC(..) )
32 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
33 import Unique ( Unique )
34 import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
35 import Util ( mapAndUnzip )
42 %************************************************************************
44 \subsection[OccurAnal-main]{Counting occurrences: main function}
46 %************************************************************************
48 Here's the externally-callable interface:
51 occurAnalysePgm :: [CoreBind] -> [CoreBind]
53 = snd (go initOccEnv binds)
55 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
59 = (final_usage, bind' ++ binds')
61 (bs_usage, binds') = go env binds
62 (final_usage, bind') = occAnalBind env bind bs_usage
64 occurAnalyseExpr :: CoreExpr -> CoreExpr
65 -- Do occurrence analysis, and discard occurence info returned
66 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
70 %************************************************************************
72 \subsection[OccurAnal-main]{Counting occurrences: main function}
74 %************************************************************************
82 -> UsageDetails -- Usage details of scope
83 -> (UsageDetails, -- Of the whole let(rec)
86 occAnalBind env (NonRec binder rhs) body_usage
87 | isTyVar binder -- A type let; we don't gather usage info
88 = (body_usage, [NonRec binder rhs])
90 | not (binder `usedIn` body_usage) -- It's not mentioned
93 | otherwise -- It's mentioned in the body
94 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
95 [NonRec tagged_binder rhs'])
97 (body_usage', tagged_binder) = tagBinder body_usage binder
98 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
103 Dropping dead code for recursive bindings is done in a very simple way:
105 the entire set of bindings is dropped if none of its binders are
106 mentioned in its body; otherwise none are.
108 This seems to miss an obvious improvement.
120 Now 'f' is unused! But it's OK! Dependency analysis will sort this
121 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
122 dropped. It isn't easy to do a perfect job in one blow. Consider
133 Note [Loop breaking and RULES]
134 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
135 Loop breaking is surprisingly subtle. First read the section 4 of
136 "Secrets of the GHC inliner". This describes our basic plan.
138 However things are made quite a bit more complicated by RULES. Remember
140 * Note [Rules are extra RHSs]
141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
142 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
143 keeps the specialised "children" alive. If the parent dies
144 (because it isn't referenced any more), then the children will die
145 too (unless they are already referenced directly).
147 To that end, we build a Rec group for each cyclic strongly
149 *treating f's rules as extra RHSs for 'f'*.
151 When we make the Rec groups we include variables free in *either*
152 LHS *or* RHS of the rule. The former might seems silly, but see
153 Note [Rule dependency info].
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 functions 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 when we compute this rule_fv_env, we only consider variables
191 free in the *RHS* of the rule, in contrast to the way we build the
192 Rec group in the first place (Note [Rule dependency info])
194 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
195 chosen as a loop breaker, because their RHSs don't mention each other.
196 And indeed both can be inlined safely.
198 Note that the edges of the graph we use for computing loop breakers
199 are not the same as the edges we use for computing the Rec blocks.
200 That's why we compute
201 rec_edges for the Rec block analysis
202 loop_breaker_edges for the loop breaker analysis
205 * Note [Weak loop breakers]
206 ~~~~~~~~~~~~~~~~~~~~~~~~~
207 There is a last nasty wrinkle. Suppose we have
217 Remmber that we simplify the RULES before any RHS (see Note
218 [Rules are visible in their own rec group] above).
220 So we must *not* postInlineUnconditionally 'g', even though
221 its RHS turns out to be trivial. (I'm assuming that 'g' is
222 not choosen as a loop breaker.)
224 We "solve" this by making g a "weak" or "rules-only" loop breaker,
225 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
226 has IAmLoopBreaker False. So
228 Inline postInlineUnconditinoally
229 IAmLoopBreaker False no no
230 IAmLoopBreaker True yes no
233 The **sole** reason for this kind of loop breaker is so that
234 postInlineUnconditionally does not fire. Ugh.
236 * Note [Rule dependency info]
237 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
238 The VarSet in a SpecInfo is used for dependency analysis in the
239 occurrence analyser. We must track free vars in *both* lhs and rhs. Why both?
243 Then if we substitute y for x, we'd better do so in the
244 rule's LHS too, so we'd better ensure the dependency is respected
249 Example (from GHC.Enum):
251 eftInt :: Int# -> Int# -> [Int]
252 eftInt x y = ...(non-recursive)...
254 {-# INLINE [0] eftIntFB #-}
255 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
256 eftIntFB c n x y = ...(non-recursive)...
259 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
260 "eftIntList" [1] eftIntFB (:) [] = eftInt
263 Example [Specialisation rules]
264 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
265 Consider this group, which is typical of what SpecConstr builds:
267 fs a = ....f (C a)....
268 f x = ....f (C a)....
269 {-# RULE f (C a) = fs a #-}
271 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
273 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
274 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
275 - fs is inlined (say it's small)
276 - now there's another opportunity to apply the RULE
278 This showed up when compiling Control.Concurrent.Chan.getChanContents.
282 occAnalBind env (Rec pairs) body_usage
283 = foldr occAnalRec (body_usage, []) sccs
284 -- For a recursive group, we
285 -- * occ-analyse all the RHSs
286 -- * compute strongly-connected components
287 -- * feed those components to occAnalRec
289 -------------Dependency analysis ------------------------------
290 bndr_set = mkVarSet (map fst pairs)
292 sccs :: [SCC (Node Details)]
293 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges
295 rec_edges :: [Node Details]
296 rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
298 make_node (bndr, rhs)
299 = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
301 (rhs_usage, rhs') = occAnalRhs env bndr rhs
302 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
303 out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
304 -- (a -> b) means a mentions b
305 -- Given the usage details (a UFM that gives occ info for each free var of
306 -- the RHS) we can get the list of free vars -- or rather their Int keys --
307 -- by just extracting the keys from the finite map. Grimy, but fast.
308 -- Previously we had this:
309 -- [ bndr | bndr <- bndrs,
310 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
311 -- which has n**2 cost, and this meant that edges_from alone
312 -- consumed 10% of total runtime!
314 -----------------------------
315 occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
316 -> (UsageDetails, [CoreBind])
318 -- The NonRec case is just like a Let (NonRec ...) above
319 occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
320 | not (bndr `usedIn` body_usage)
321 = (body_usage, binds)
323 | otherwise -- It's mentioned in the body
324 = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs]
325 NonRec tagged_bndr rhs : binds)
327 (body_usage', tagged_bndr) = tagBinder body_usage bndr
330 -- The Rec case is the interesting one
331 -- See Note [Loop breaking]
332 occAnalRec (CyclicSCC nodes) (body_usage, binds)
333 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
334 = (body_usage, binds) -- Dead code
336 | otherwise -- At this point we always build a single Rec
337 = (final_usage, Rec pairs : binds)
340 bndrs = [b | (ND b _ _ _, _, _) <- nodes]
341 bndr_set = mkVarSet bndrs
343 ----------------------------
344 -- Tag the binders with their occurrence info
345 total_usage = foldl add_usage body_usage nodes
346 add_usage body_usage (ND bndr _ rhs_usage _, _, _)
347 = body_usage +++ addRuleUsage rhs_usage bndr
348 (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
350 tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
351 -- (a) Tag the binders in the details with occ info
352 -- (b) Mark the binder with "weak loop-breaker" OccInfo
353 -- saying "no preInlineUnconditionally" if it is used
354 -- in any rule (lhs or rhs) of the recursive group
355 -- See Note [Weak loop breakers]
356 tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
357 = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
359 bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
361 bndr1 = setBinderOcc usage bndr
362 all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
365 ----------------------------
366 -- Now reconstruct the cycle
367 pairs | no_rules = reOrderCycle tagged_nodes
368 | otherwise = concatMap reOrderRec (stronglyConnCompR loop_breaker_edges)
370 -- See Note [Choosing loop breakers] for looop_breaker_edges
371 loop_breaker_edges = map mk_node tagged_nodes
372 mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
374 new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
376 ------------------------------------
377 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
378 -- Domain is *subset* of bound vars (others have no rule fvs)
379 rule_fv_env = rule_loop init_rule_fvs
381 no_rules = null init_rule_fvs
382 init_rule_fvs = [(b, rule_fvs)
384 , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
385 , not (isEmptyVarSet rule_fvs)]
387 rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
390 | otherwise = rule_loop new_fv_list
392 env = mkVarEnv init_rule_fvs
393 (no_change, new_fv_list) = mapAccumL bump True fv_list
394 bump no_change (b,fvs)
395 | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
396 | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
398 new_fvs = extendFvs env emptyVarSet fvs
400 idRuleRhsVars :: Id -> VarSet
401 -- Just the variables free on the *rhs* of a rule
402 -- See Note [Choosing loop breakers]
403 idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
405 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
406 -- (extendFVs env fvs s) returns (fvs `union` env(s))
407 extendFvs env fvs id_set
408 = foldUFM_Directly add fvs id_set
411 = case lookupVarEnv_Directly env uniq of
412 Just fvs' -> fvs' `unionVarSet` fvs
416 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
417 strongly connected component (there's guaranteed to be a cycle). It returns the
419 a) in a better order,
420 b) with some of the Ids having a IAmALoopBreaker pragma
422 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
423 that the simplifier can guarantee not to loop provided it never records an inlining
424 for these no-inline guys.
426 Furthermore, the order of the binds is such that if we neglect dependencies
427 on the no-inline Ids then the binds are topologically sorted. This means
428 that the simplifier will generally do a good job if it works from top bottom,
429 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
432 [June 98: I don't understand the following paragraphs, and I've
433 changed the a=b case again so that it isn't a special case any more.]
435 Here's a case that bit me:
443 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
445 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
446 Perhaps something cleverer would suffice.
451 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
452 -- which is gotten from the Id.
453 data Details = ND Id -- Binder
455 UsageDetails -- Full usage from RHS (*not* including rules)
456 IdSet -- Other binders from this Rec group mentioned on RHS
457 -- (derivable from UsageDetails but cached here)
459 reOrderRec :: SCC (Node Details)
461 -- Sorted into a plausible order. Enough of the Ids have
462 -- IAmALoopBreaker pragmas that there are no loops left.
463 reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)]
464 reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
466 reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
468 = panic "reOrderCycle"
469 reOrderCycle [bind] -- Common case of simple self-recursion
470 = [(makeLoopBreaker False bndr, rhs)]
472 (ND bndr rhs _ _, _, _) = bind
474 reOrderCycle (bind : binds)
475 = -- Choose a loop breaker, mark it no-inline,
476 -- do SCC analysis on the rest, and recursively sort them out
477 concatMap reOrderRec (stronglyConnCompR unchosen) ++
478 [(makeLoopBreaker False bndr, rhs)]
481 (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
482 ND bndr rhs _ _ = chosen_bind
484 -- This loop looks for the bind with the lowest score
485 -- to pick as the loop breaker. The rest accumulate in
486 choose_loop_breaker (details,_,_) _loop_sc acc []
487 = (details, acc) -- Done
489 choose_loop_breaker loop_bind loop_sc acc (bind : binds)
490 | sc < loop_sc -- Lower score so pick this new one
491 = choose_loop_breaker bind sc (loop_bind : acc) binds
493 | otherwise -- No lower so don't pick it
494 = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
498 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
499 score (ND bndr rhs _ _, _, _)
500 | workerExists (idWorkerInfo bndr) = 10
501 -- Note [Worker inline loop]
503 | exprIsTrivial rhs = 5 -- Practically certain to be inlined
504 -- Used to have also: && not (isExportedId bndr)
505 -- But I found this sometimes cost an extra iteration when we have
506 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
507 -- where df is the exported dictionary. Then df makes a really
508 -- bad choice for loop breaker
510 | is_con_app rhs = 3 -- Data types help with cases
513 -- If an Id is marked "never inline" then it makes a great loop breaker
514 -- The only reason for not checking that here is that it is rare
515 -- and I've never seen a situation where it makes a difference,
516 -- so it probably isn't worth the time to test on every binder
517 -- | isNeverActive (idInlinePragma bndr) = -10
519 | inlineCandidate bndr rhs = 2 -- Likely to be inlined
520 -- Note [Inline candidates]
522 | not (neverUnfold (idUnfolding bndr)) = 1
523 -- the Id has some kind of unfolding
527 inlineCandidate :: Id -> CoreExpr -> Bool
528 inlineCandidate _ (Note InlineMe _) = True
529 inlineCandidate id _ = isOneOcc (idOccInfo id)
533 -- It's really really important to inline dictionaries. Real
534 -- example (the Enum Ordering instance from GHC.Base):
536 -- rec f = \ x -> case d of (p,q,r) -> p x
537 -- g = \ x -> case d of (p,q,r) -> q x
540 -- Here, f and g occur just once; but we can't inline them into d.
541 -- On the other hand we *could* simplify those case expressions if
542 -- we didn't stupidly choose d as the loop breaker.
543 -- But we won't because constructor args are marked "Many".
544 -- Inlining dictionaries is really essential to unravelling
545 -- the loops in static numeric dictionaries, see GHC.Float.
547 -- Cheap and cheerful; the simplifer moves casts out of the way
548 -- The lambda case is important to spot x = /\a. C (f a)
549 -- which comes up when C is a dictionary constructor and
550 -- f is a default method.
551 -- Example: the instance for Show (ST s a) in GHC.ST
553 -- However we *also* treat (\x. C p q) as a con-app-like thing,
554 -- Note [Closure conversion]
555 is_con_app (Var v) = isDataConWorkId v
556 is_con_app (App f _) = is_con_app f
557 is_con_app (Lam _ e) = is_con_app e
558 is_con_app (Note _ e) = is_con_app e
561 makeLoopBreaker :: Bool -> Id -> Id
562 -- Set the loop-breaker flag
563 -- See Note [Weak loop breakers]
564 makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
567 Note [Worker inline loop]
568 ~~~~~~~~~~~~~~~~~~~~~~~~
569 Never choose a wrapper as the loop breaker! Because
570 wrappers get auto-generated inlinings when importing, and
571 that can lead to an infinite inlining loop. For example:
573 $wfoo x = ....foo x....
575 {-loop brk-} foo x = ...$wfoo x...
578 The interface file sees the unfolding for $wfoo, and sees that foo is
579 strict (and hence it gets an auto-generated wrapper). Result: an
580 infinite inlining in the importing scope. So be a bit careful if you
581 change this. A good example is Tree.repTree in
582 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
583 breaker then compiling Game.hs goes into an infinite loop (this
584 happened when we gave is_con_app a lower score than inline candidates).
586 Note [Closure conversion]
587 ~~~~~~~~~~~~~~~~~~~~~~~~~
588 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
589 The immediate motivation came from the result of a closure-conversion transformation
590 which generated code like this:
592 data Clo a b = forall c. Clo (c -> a -> b) c
594 ($:) :: Clo a b -> a -> b
595 Clo f env $: x = f env x
597 rec { plus = Clo plus1 ()
599 ; plus1 _ n = Clo plus2 n
602 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
604 If we inline 'plus' and 'plus1', everything unravels nicely. But if
605 we choose 'plus1' as the loop breaker (which is entirely possible
606 otherwise), the loop does not unravel nicely.
609 @occAnalRhs@ deals with the question of bindings where the Id is marked
610 by an INLINE pragma. For these we record that anything which occurs
611 in its RHS occurs many times. This pessimistically assumes that ths
612 inlined binder also occurs many times in its scope, but if it doesn't
613 we'll catch it next time round. At worst this costs an extra simplifier pass.
614 ToDo: try using the occurrence info for the inline'd binder.
616 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
617 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
622 -> Id -> CoreExpr -- Binder and rhs
623 -- For non-recs the binder is alrady tagged
624 -- with occurrence info
625 -> (UsageDetails, CoreExpr)
627 occAnalRhs env id rhs
630 ctxt | certainly_inline id = env
631 | otherwise = rhsCtxt
632 -- Note that we generally use an rhsCtxt. This tells the occ anal n
633 -- that it's looking at an RHS, which has an effect in occAnalApp
635 -- But there's a problem. Consider
640 -- First time round, it looks as if x1 and x2 occur as an arg of a
641 -- let-bound constructor ==> give them a many-occurrence.
642 -- But then x3 is inlined (unconditionally as it happens) and
643 -- next time round, x2 will be, and the next time round x1 will be
644 -- Result: multiple simplifier iterations. Sigh.
645 -- Crude solution: use rhsCtxt for things that occur just once...
647 certainly_inline id = case idOccInfo id of
648 OneOcc in_lam one_br _ -> not in_lam && one_br
655 addRuleUsage :: UsageDetails -> Id -> UsageDetails
656 -- Add the usage from RULES in Id to the usage
657 addRuleUsage usage id
658 = foldVarSet add usage (idRuleVars id)
660 add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info
661 -- (i.e manyOcc) because many copies
662 -- of the specialised thing can appear
670 -> (UsageDetails, -- Gives info only about the "interesting" Ids
673 occAnal _ (Type t) = (emptyDetails, Type t)
674 occAnal env (Var v) = (mkOneOcc env v False, Var v)
675 -- At one stage, I gathered the idRuleVars for v here too,
676 -- which in a way is the right thing to do.
677 -- But that went wrong right after specialisation, when
678 -- the *occurrences* of the overloaded function didn't have any
679 -- rules in them, so the *specialised* versions looked as if they
680 -- weren't used at all.
683 We regard variables that occur as constructor arguments as "dangerousToDup":
687 f x = let y = expensive x in
689 (case z of {(p,q)->q}, case z of {(p,q)->q})
692 We feel free to duplicate the WHNF (True,y), but that means
693 that y may be duplicated thereby.
695 If we aren't careful we duplicate the (expensive x) call!
696 Constructors are rather like lambdas in this way.
699 occAnal _ expr@(Lit _) = (emptyDetails, expr)
703 occAnal env (Note InlineMe body)
704 = case occAnal env body of { (usage, body') ->
705 (mapVarEnv markMany usage, Note InlineMe body')
708 occAnal env (Note note@(SCC _) body)
709 = case occAnal env body of { (usage, body') ->
710 (mapVarEnv markInsideSCC usage, Note note body')
713 occAnal env (Note note body)
714 = case occAnal env body of { (usage, body') ->
715 (usage, Note note body')
718 occAnal env (Cast expr co)
719 = case occAnal env expr of { (usage, expr') ->
720 (markRhsUds env True usage, Cast expr' co)
721 -- If we see let x = y `cast` co
722 -- then mark y as 'Many' so that we don't
723 -- immediately inline y again.
728 occAnal env app@(App _ _)
729 = occAnalApp env (collectArgs app)
731 -- Ignore type variables altogether
732 -- (a) occurrences inside type lambdas only not marked as InsideLam
733 -- (b) type variables not in environment
735 occAnal env (Lam x body) | isTyVar x
736 = case occAnal env body of { (body_usage, body') ->
737 (body_usage, Lam x body')
740 -- For value lambdas we do a special hack. Consider
742 -- If we did nothing, x is used inside the \y, so would be marked
743 -- as dangerous to dup. But in the common case where the abstraction
744 -- is applied to two arguments this is over-pessimistic.
745 -- So instead, we just mark each binder with its occurrence
746 -- info in the *body* of the multiple lambda.
747 -- Then, the simplifier is careful when partially applying lambdas.
749 occAnal env expr@(Lam _ _)
750 = case occAnal env_body body of { (body_usage, body') ->
752 (final_usage, tagged_binders) = tagBinders body_usage binders
753 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
754 -- we get linear-typed things in the resulting program that we can't handle yet.
755 -- (e.g. PrelShow) TODO
757 really_final_usage = if linear then
760 mapVarEnv markInsideLam final_usage
763 mkLams tagged_binders body') }
765 env_body = vanillaCtxt -- Body is (no longer) an RhsContext
766 (binders, body) = collectBinders expr
767 binders' = oneShotGroup env binders
768 linear = all is_one_shot binders'
769 is_one_shot b = isId b && isOneShotBndr b
771 occAnal env (Case scrut bndr ty alts)
772 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
773 case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
775 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
776 alts_usage' = addCaseBndrUsage alts_usage
777 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
778 total_usage = scrut_usage +++ alts_usage1
780 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
782 -- The case binder gets a usage of either "many" or "dead", never "one".
783 -- Reason: we like to inline single occurrences, to eliminate a binding,
784 -- but inlining a case binder *doesn't* eliminate a binding.
785 -- We *don't* want to transform
786 -- case x of w { (p,q) -> f w }
788 -- case x of w { (p,q) -> f (p,q) }
789 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
791 Just occ -> extendVarEnv usage bndr (markMany occ)
793 alt_env = setVanillaCtxt env
794 -- Consider x = case v of { True -> (p,q); ... }
795 -- Then it's fine to inline p and q
797 occ_anal_scrut (Var v) (alt1 : other_alts)
798 | not (null other_alts) || not (isDefaultAlt alt1)
799 = (mkOneOcc env v True, Var v)
800 occ_anal_scrut scrut _alts = occAnal vanillaCtxt scrut
801 -- No need for rhsCtxt
803 occAnal env (Let bind body)
804 = case occAnal env body of { (body_usage, body') ->
805 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
806 (final_usage, mkLets new_binds body') }}
808 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
809 occAnalArgs _env args
810 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
811 (foldr (+++) emptyDetails arg_uds_s, args')}
813 arg_env = vanillaCtxt
816 Applications are dealt with specially because we want
817 the "build hack" to work.
821 -> (Expr CoreBndr, [Arg CoreBndr])
822 -> (UsageDetails, Expr CoreBndr)
823 occAnalApp env (Var fun, args)
824 = case args_stuff of { (args_uds, args') ->
826 final_args_uds = markRhsUds env is_pap args_uds
828 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
830 fun_uniq = idUnique fun
831 fun_uds = mkOneOcc env fun (valArgCount args > 0)
832 is_pap = isDataConWorkId fun || valArgCount args < idArity fun
834 -- Hack for build, fold, runST
835 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
836 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
837 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
838 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
839 -- (foldr k z xs) may call k many times, but it never
840 -- shares a partial application of k; hence [False,True]
841 -- This means we can optimise
842 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
843 -- by floating in the v
845 | otherwise = occAnalArgs env args
848 occAnalApp env (fun, args)
849 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
850 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
851 -- often leaves behind beta redexs like
853 -- Here we would like to mark x,y as one-shot, and treat the whole
854 -- thing much like a let. We do this by pushing some True items
855 -- onto the context stack.
857 case occAnalArgs env args of { (args_uds, args') ->
859 final_uds = fun_uds +++ args_uds
861 (final_uds, mkApps fun' args') }}
864 markRhsUds :: OccEnv -- Check if this is a RhsEnv
865 -> Bool -- and this is true
866 -> UsageDetails -- The do markMany on this
868 -- We mark the free vars of the argument of a constructor or PAP
869 -- as "many", if it is the RHS of a let(rec).
870 -- This means that nothing gets inlined into a constructor argument
871 -- position, which is what we want. Typically those constructor
872 -- arguments are just variables, or trivial expressions.
874 -- This is the *whole point* of the isRhsEnv predicate
875 markRhsUds env is_pap arg_uds
876 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
877 | otherwise = arg_uds
881 -> Int -> CtxtTy -- Argument number, and context to use for it
883 -> (UsageDetails, [CoreExpr])
884 appSpecial env n ctxt args
887 arg_env = vanillaCtxt
889 go _ [] = (emptyDetails, []) -- Too few args
891 go 1 (arg:args) -- The magic arg
892 = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
893 case occAnalArgs env args of { (args_uds, args') ->
894 (arg_uds +++ args_uds, arg':args') }}
897 = case occAnal arg_env arg of { (arg_uds, arg') ->
898 case go (n-1) args of { (args_uds, args') ->
899 (arg_uds +++ args_uds, arg':args') }}
905 If the case binder occurs at all, the other binders effectively do too.
907 case e of x { (a,b) -> rhs }
910 If e turns out to be (e1,e2) we indeed get something like
911 let a = e1; b = e2; x = (a,b) in rhs
913 Note [Aug 06]: I don't think this is necessary any more, and it helpe
914 to know when binders are unused. See esp the call to
915 isDeadBinder in Simplify.mkDupableAlt
921 -> (UsageDetails, Alt IdWithOccInfo)
922 occAnalAlt env _case_bndr (con, bndrs, rhs)
923 = case occAnal env rhs of { (rhs_usage, rhs') ->
925 (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
926 final_bndrs = tagged_bndrs -- See Note [Aug06] above
928 final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
929 | otherwise = tagged_bndrs
930 -- Leave the binders untagged if the case
931 -- binder occurs at all; see note above
934 (final_usage, (con, final_bndrs, rhs')) }
938 %************************************************************************
940 \subsection[OccurAnal-types]{OccEnv}
942 %************************************************************************
946 = OccEnv OccEncl -- Enclosing context information
947 CtxtTy -- Tells about linearity
949 -- OccEncl is used to control whether to inline into constructor arguments
951 -- x = (p,q) -- Don't inline p or q
952 -- y = /\a -> (p a, q a) -- Still don't inline p or q
953 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
954 -- So OccEncl tells enought about the context to know what to do when
955 -- we encounter a contructor application or PAP.
958 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
959 -- Don't inline into constructor args here
960 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
961 -- Do inline into constructor args here
966 -- True:ctxt Analysing a function-valued expression that will be
969 -- False:ctxt Analysing a function-valued expression that may
970 -- be applied many times; but when it is,
971 -- the CtxtTy inside applies
974 initOccEnv = OccEnv OccRhs []
976 vanillaCtxt :: OccEnv
977 vanillaCtxt = OccEnv OccVanilla []
980 rhsCtxt = OccEnv OccRhs []
982 isRhsEnv :: OccEnv -> Bool
983 isRhsEnv (OccEnv OccRhs _) = True
984 isRhsEnv (OccEnv OccVanilla _) = False
986 setVanillaCtxt :: OccEnv -> OccEnv
987 setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
988 setVanillaCtxt other_env = other_env
990 setCtxt :: OccEnv -> CtxtTy -> OccEnv
991 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
993 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
994 -- The result binders have one-shot-ness set that they might not have had originally.
995 -- This happens in (build (\cn -> e)). Here the occurrence analyser
996 -- linearity context knows that c,n are one-shot, and it records that fact in
997 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
999 oneShotGroup (OccEnv _encl ctxt) bndrs
1002 go _ [] rev_bndrs = reverse rev_bndrs
1004 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
1005 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
1007 bndr' | lin_ctxt = setOneShotLambda bndr
1010 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1012 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1013 addAppCtxt (OccEnv encl ctxt) args
1014 = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
1017 %************************************************************************
1019 \subsection[OccurAnal-types]{OccEnv}
1021 %************************************************************************
1024 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
1026 (+++), combineAltsUsageDetails
1027 :: UsageDetails -> UsageDetails -> UsageDetails
1030 = plusVarEnv_C addOccInfo usage1 usage2
1032 combineAltsUsageDetails usage1 usage2
1033 = plusVarEnv_C orOccInfo usage1 usage2
1035 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1036 addOneOcc usage id info
1037 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1038 -- ToDo: make this more efficient
1040 emptyDetails :: UsageDetails
1041 emptyDetails = (emptyVarEnv :: UsageDetails)
1043 usedIn :: Id -> UsageDetails -> Bool
1044 v `usedIn` details = isExportedId v || v `elemVarEnv` details
1046 type IdWithOccInfo = Id
1048 tagBinders :: UsageDetails -- Of scope
1050 -> (UsageDetails, -- Details with binders removed
1051 [IdWithOccInfo]) -- Tagged binders
1053 tagBinders usage binders
1055 usage' = usage `delVarEnvList` binders
1056 uss = map (setBinderOcc usage) binders
1058 usage' `seq` (usage', uss)
1060 tagBinder :: UsageDetails -- Of scope
1062 -> (UsageDetails, -- Details with binders removed
1063 IdWithOccInfo) -- Tagged binders
1065 tagBinder usage binder
1067 usage' = usage `delVarEnv` binder
1068 binder' = setBinderOcc usage binder
1070 usage' `seq` (usage', binder')
1072 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1073 setBinderOcc usage bndr
1074 | isTyVar bndr = bndr
1075 | isExportedId bndr = case idOccInfo bndr of
1077 _ -> setIdOccInfo bndr NoOccInfo
1078 -- Don't use local usage info for visible-elsewhere things
1079 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1080 -- about to re-generate it and it shouldn't be "sticky"
1082 | otherwise = setIdOccInfo bndr occ_info
1084 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1088 %************************************************************************
1090 \subsection{Operations over OccInfo}
1092 %************************************************************************
1095 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1096 mkOneOcc _env id int_cxt
1097 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1098 | otherwise = emptyDetails
1100 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1102 markMany IAmDead = IAmDead
1103 markMany _ = NoOccInfo
1105 markInsideSCC occ = markMany occ
1107 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1108 markInsideLam occ = occ
1110 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1112 addOccInfo IAmDead info2 = info2
1113 addOccInfo info1 IAmDead = info1
1114 addOccInfo _ _ = NoOccInfo
1116 -- (orOccInfo orig new) is used
1117 -- when combining occurrence info from branches of a case
1119 orOccInfo IAmDead info2 = info2
1120 orOccInfo info1 IAmDead = info1
1121 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1122 (OneOcc in_lam2 _ int_cxt2)
1123 = OneOcc (in_lam1 || in_lam2)
1124 False -- False, because it occurs in both branches
1125 (int_cxt1 && int_cxt2)
1126 orOccInfo _ _ = NoOccInfo