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 | not (binder `usedIn` body_usage) -- It's not mentioned
90 | otherwise -- It's mentioned in the body
91 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
92 [NonRec tagged_binder rhs'])
94 (body_usage', tagged_binder) = tagBinder body_usage binder
95 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
100 Dropping dead code for recursive bindings is done in a very simple way:
102 the entire set of bindings is dropped if none of its binders are
103 mentioned in its body; otherwise none are.
105 This seems to miss an obvious improvement.
117 Now 'f' is unused! But it's OK! Dependency analysis will sort this
118 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
119 dropped. It isn't easy to do a perfect job in one blow. Consider
130 Note [Loop breaking and RULES]
131 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
132 Loop breaking is surprisingly subtle. First read the section 4 of
133 "Secrets of the GHC inliner". This describes our basic plan.
135 However things are made quite a bit more complicated by RULES. Remember
137 * Note [Rules are extra RHSs]
138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
139 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
140 keeps the specialised "children" alive. If the parent dies
141 (because it isn't referenced any more), then the children will die
142 too (unless they are already referenced directly).
144 To that end, we build a Rec group for each cyclic strongly
146 *treating f's rules as extra RHSs for 'f'*.
148 When we make the Rec groups we include variables free in *either*
149 LHS *or* RHS of the rule. The former might seems silly, but see
150 Note [Rule dependency info].
152 So in Example [eftInt], eftInt and eftIntFB will be put in the
153 same Rec, even though their 'main' RHSs are both non-recursive.
155 * Note [Rules are visible in their own rec group]
156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
157 We want the rules for 'f' to be visible in f's right-hand side.
158 And we'd like them to be visible in other functions in f's Rec
159 group. E.g. in Example [Specialisation rules] we want f' rule
160 to be visible in both f's RHS, and fs's RHS.
162 This means that we must simplify the RULEs first, before looking
163 at any of the definitions. This is done by Simplify.simplRecBind,
164 when it calls addLetIdInfo.
166 * Note [Choosing loop breakers]
167 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168 We avoid infinite inlinings by choosing loop breakers, and
169 ensuring that a loop breaker cuts each loop. But what is a
170 "loop"? In particular, a RULES is like an equation for 'f' that
171 is *always* inlined if it are applicable. We do *not* disable
172 rules for loop-breakers. It's up to whoever makes the rules to
173 make sure that the rules themselves alwasys terminate. See Note
174 [Rules for recursive functions] in Simplify.lhs
177 f's RHS mentions g, and
178 g has a RULE that mentions h, and
179 h has a RULE that mentions f
181 then we *must* choose f to be a loop breaker. In general, take the
182 free variables of f's RHS, and augment it with all the variables
183 reachable by RULES from those starting points. That is the whole
184 reason for computing rule_fv_env in occAnalBind. (Of course we
185 only consider free vars that are also binders in this Rec group.)
187 Note that when we compute this rule_fv_env, we only consider variables
188 free in the *RHS* of the rule, in contrast to the way we build the
189 Rec group in the first place (Note [Rule dependency info])
191 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
192 chosen as a loop breaker, because their RHSs don't mention each other.
193 And indeed both can be inlined safely.
195 Note that the edges of the graph we use for computing loop breakers
196 are not the same as the edges we use for computing the Rec blocks.
197 That's why we compute
198 rec_edges for the Rec block analysis
199 loop_breaker_edges for the loop breaker analysis
202 * Note [Weak loop breakers]
203 ~~~~~~~~~~~~~~~~~~~~~~~~~
204 There is a last nasty wrinkle. Suppose we have
214 Remmber that we simplify the RULES before any RHS (see Note
215 [Rules are visible in their own rec group] above).
217 So we must *not* postInlineUnconditionally 'g', even though
218 its RHS turns out to be trivial. (I'm assuming that 'g' is
219 not choosen as a loop breaker.)
221 We "solve" this by making g a "weak" or "rules-only" loop breaker,
222 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
223 has IAmLoopBreaker False. So
225 Inline postInlineUnconditinoally
226 IAmLoopBreaker False no no
227 IAmLoopBreaker True yes no
230 The **sole** reason for this kind of loop breaker is so that
231 postInlineUnconditionally does not fire. Ugh.
233 * Note [Rule dependency info]
234 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
235 The VarSet in a SpecInfo is used for dependency analysis in the
236 occurrence analyser. We must track free vars in *both* lhs and rhs. Why both?
240 Then if we substitute y for x, we'd better do so in the
241 rule's LHS too, so we'd better ensure the dependency is respected
246 Example (from GHC.Enum):
248 eftInt :: Int# -> Int# -> [Int]
249 eftInt x y = ...(non-recursive)...
251 {-# INLINE [0] eftIntFB #-}
252 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
253 eftIntFB c n x y = ...(non-recursive)...
256 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
257 "eftIntList" [1] eftIntFB (:) [] = eftInt
260 Example [Specialisation rules]
261 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
262 Consider this group, which is typical of what SpecConstr builds:
264 fs a = ....f (C a)....
265 f x = ....f (C a)....
266 {-# RULE f (C a) = fs a #-}
268 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
270 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
271 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
272 - fs is inlined (say it's small)
273 - now there's another opportunity to apply the RULE
275 This showed up when compiling Control.Concurrent.Chan.getChanContents.
279 occAnalBind env (Rec pairs) body_usage
280 = foldr occAnalRec (body_usage, []) sccs
281 -- For a recursive group, we
282 -- * occ-analyse all the RHSs
283 -- * compute strongly-connected components
284 -- * feed those components to occAnalRec
286 -------------Dependency analysis ------------------------------
287 bndr_set = mkVarSet (map fst pairs)
289 sccs :: [SCC (Node Details)]
290 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges
292 rec_edges :: [Node Details]
293 rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
295 make_node (bndr, rhs)
296 = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
298 (rhs_usage, rhs') = occAnalRhs env bndr rhs
299 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
300 out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
301 -- (a -> b) means a mentions b
302 -- Given the usage details (a UFM that gives occ info for each free var of
303 -- the RHS) we can get the list of free vars -- or rather their Int keys --
304 -- by just extracting the keys from the finite map. Grimy, but fast.
305 -- Previously we had this:
306 -- [ bndr | bndr <- bndrs,
307 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
308 -- which has n**2 cost, and this meant that edges_from alone
309 -- consumed 10% of total runtime!
311 -----------------------------
312 occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
313 -> (UsageDetails, [CoreBind])
315 -- The NonRec case is just like a Let (NonRec ...) above
316 occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
317 | not (bndr `usedIn` body_usage)
318 = (body_usage, binds)
320 | otherwise -- It's mentioned in the body
321 = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs]
322 NonRec tagged_bndr rhs : binds)
324 (body_usage', tagged_bndr) = tagBinder body_usage bndr
327 -- The Rec case is the interesting one
328 -- See Note [Loop breaking]
329 occAnalRec (CyclicSCC nodes) (body_usage, binds)
330 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
331 = (body_usage, binds) -- Dead code
333 | otherwise -- At this point we always build a single Rec
334 = (final_usage, Rec pairs : binds)
337 bndrs = [b | (ND b _ _ _, _, _) <- nodes]
338 bndr_set = mkVarSet bndrs
340 ----------------------------
341 -- Tag the binders with their occurrence info
342 total_usage = foldl add_usage body_usage nodes
343 add_usage body_usage (ND bndr _ rhs_usage _, _, _)
344 = body_usage +++ addRuleUsage rhs_usage bndr
345 (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
347 tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
348 -- (a) Tag the binders in the details with occ info
349 -- (b) Mark the binder with "weak loop-breaker" OccInfo
350 -- saying "no preInlineUnconditionally" if it is used
351 -- in any rule (lhs or rhs) of the recursive group
352 -- See Note [Weak loop breakers]
353 tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
354 = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
356 bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
358 bndr1 = setBinderOcc usage bndr
359 all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
362 ----------------------------
363 -- Now reconstruct the cycle
364 pairs | no_rules = reOrderCycle tagged_nodes
365 | otherwise = concatMap reOrderRec (stronglyConnCompR loop_breaker_edges)
367 -- See Note [Choosing loop breakers] for looop_breaker_edges
368 loop_breaker_edges = map mk_node tagged_nodes
369 mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
371 new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
373 ------------------------------------
374 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
375 -- Domain is *subset* of bound vars (others have no rule fvs)
376 rule_fv_env = rule_loop init_rule_fvs
378 no_rules = null init_rule_fvs
379 init_rule_fvs = [(b, rule_fvs)
381 , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
382 , not (isEmptyVarSet rule_fvs)]
384 rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
387 | otherwise = rule_loop new_fv_list
389 env = mkVarEnv init_rule_fvs
390 (no_change, new_fv_list) = mapAccumL bump True fv_list
391 bump no_change (b,fvs)
392 | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
393 | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
395 new_fvs = extendFvs env emptyVarSet fvs
397 idRuleRhsVars :: Id -> VarSet
398 -- Just the variables free on the *rhs* of a rule
399 -- See Note [Choosing loop breakers]
400 idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
402 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
403 -- (extendFVs env fvs s) returns (fvs `union` env(s))
404 extendFvs env fvs id_set
405 = foldUFM_Directly add fvs id_set
408 = case lookupVarEnv_Directly env uniq of
409 Just fvs' -> fvs' `unionVarSet` fvs
413 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
414 strongly connected component (there's guaranteed to be a cycle). It returns the
416 a) in a better order,
417 b) with some of the Ids having a IAmALoopBreaker pragma
419 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
420 that the simplifier can guarantee not to loop provided it never records an inlining
421 for these no-inline guys.
423 Furthermore, the order of the binds is such that if we neglect dependencies
424 on the no-inline Ids then the binds are topologically sorted. This means
425 that the simplifier will generally do a good job if it works from top bottom,
426 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
429 [June 98: I don't understand the following paragraphs, and I've
430 changed the a=b case again so that it isn't a special case any more.]
432 Here's a case that bit me:
440 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
442 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
443 Perhaps something cleverer would suffice.
448 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
449 -- which is gotten from the Id.
450 data Details = ND Id -- Binder
452 UsageDetails -- Full usage from RHS (*not* including rules)
453 IdSet -- Other binders from this Rec group mentioned on RHS
454 -- (derivable from UsageDetails but cached here)
456 reOrderRec :: SCC (Node Details)
458 -- Sorted into a plausible order. Enough of the Ids have
459 -- IAmALoopBreaker pragmas that there are no loops left.
460 reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)]
461 reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
463 reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
465 = panic "reOrderCycle"
466 reOrderCycle [bind] -- Common case of simple self-recursion
467 = [(makeLoopBreaker False bndr, rhs)]
469 (ND bndr rhs _ _, _, _) = bind
471 reOrderCycle (bind : binds)
472 = -- Choose a loop breaker, mark it no-inline,
473 -- do SCC analysis on the rest, and recursively sort them out
474 concatMap reOrderRec (stronglyConnCompR unchosen) ++
475 [(makeLoopBreaker False bndr, rhs)]
478 (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
479 ND bndr rhs _ _ = chosen_bind
481 -- This loop looks for the bind with the lowest score
482 -- to pick as the loop breaker. The rest accumulate in
483 choose_loop_breaker (details,_,_) _loop_sc acc []
484 = (details, acc) -- Done
486 choose_loop_breaker loop_bind loop_sc acc (bind : binds)
487 | sc < loop_sc -- Lower score so pick this new one
488 = choose_loop_breaker bind sc (loop_bind : acc) binds
490 | otherwise -- No lower so don't pick it
491 = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
495 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
496 score (ND bndr rhs _ _, _, _)
497 | workerExists (idWorkerInfo bndr) = 10
498 -- Note [Worker inline loop]
500 | exprIsTrivial rhs = 4 -- Practically certain to be inlined
501 -- Used to have also: && not (isExportedId bndr)
502 -- But I found this sometimes cost an extra iteration when we have
503 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
504 -- where df is the exported dictionary. Then df makes a really
505 -- bad choice for loop breaker
507 | is_con_app rhs = 2 -- Data types help with cases
510 -- If an Id is marked "never inline" then it makes a great loop breaker
511 -- The only reason for not checking that here is that it is rare
512 -- and I've never seen a situation where it makes a difference,
513 -- so it probably isn't worth the time to test on every binder
514 -- | isNeverActive (idInlinePragma bndr) = -10
516 | inlineCandidate bndr rhs = 1 -- Likely to be inlined
517 -- Note [Inline candidates]
521 inlineCandidate :: Id -> CoreExpr -> Bool
522 inlineCandidate _ (Note InlineMe _) = True
523 inlineCandidate id _ = isOneOcc (idOccInfo id)
527 -- It's really really important to inline dictionaries. Real
528 -- example (the Enum Ordering instance from GHC.Base):
530 -- rec f = \ x -> case d of (p,q,r) -> p x
531 -- g = \ x -> case d of (p,q,r) -> q x
534 -- Here, f and g occur just once; but we can't inline them into d.
535 -- On the other hand we *could* simplify those case expressions if
536 -- we didn't stupidly choose d as the loop breaker.
537 -- But we won't because constructor args are marked "Many".
538 -- Inlining dictionaries is really essential to unravelling
539 -- the loops in static numeric dictionaries, see GHC.Float.
541 -- Cheap and cheerful; the simplifer moves casts out of the way
542 -- The lambda case is important to spot x = /\a. C (f a)
543 -- which comes up when C is a dictionary constructor and
544 -- f is a default method.
545 -- Example: the instance for Show (ST s a) in GHC.ST
547 -- However we *also* treat (\x. C p q) as a con-app-like thing,
548 -- Note [Closure conversion]
549 is_con_app (Var v) = isDataConWorkId v
550 is_con_app (App f _) = is_con_app f
551 is_con_app (Lam _ e) = is_con_app e
552 is_con_app (Note _ e) = is_con_app e
555 makeLoopBreaker :: Bool -> Id -> Id
556 -- Set the loop-breaker flag
557 -- See Note [Weak loop breakers]
558 makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
561 Note [Worker inline loop]
562 ~~~~~~~~~~~~~~~~~~~~~~~~
563 Never choose a wrapper as the loop breaker! Because
564 wrappers get auto-generated inlinings when importing, and
565 that can lead to an infinite inlining loop. For example:
567 $wfoo x = ....foo x....
569 {-loop brk-} foo x = ...$wfoo x...
572 The interface file sees the unfolding for $wfoo, and sees that foo is
573 strict (and hence it gets an auto-generated wrapper). Result: an
574 infinite inlining in the importing scope. So be a bit careful if you
575 change this. A good example is Tree.repTree in
576 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
577 breaker then compiling Game.hs goes into an infinite loop (this
578 happened when we gave is_con_app a lower score than inline candidates).
580 Note [Closure conversion]
581 ~~~~~~~~~~~~~~~~~~~~~~~~~
582 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
583 The immediate motivation came from the result of a closure-conversion transformation
584 which generated code like this:
586 data Clo a b = forall c. Clo (c -> a -> b) c
588 ($:) :: Clo a b -> a -> b
589 Clo f env $: x = f env x
591 rec { plus = Clo plus1 ()
593 ; plus1 _ n = Clo plus2 n
596 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
598 If we inline 'plus' and 'plus1', everything unravels nicely. But if
599 we choose 'plus1' as the loop breaker (which is entirely possible
600 otherwise), the loop does not unravel nicely.
603 @occAnalRhs@ deals with the question of bindings where the Id is marked
604 by an INLINE pragma. For these we record that anything which occurs
605 in its RHS occurs many times. This pessimistically assumes that ths
606 inlined binder also occurs many times in its scope, but if it doesn't
607 we'll catch it next time round. At worst this costs an extra simplifier pass.
608 ToDo: try using the occurrence info for the inline'd binder.
610 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
611 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
616 -> Id -> CoreExpr -- Binder and rhs
617 -- For non-recs the binder is alrady tagged
618 -- with occurrence info
619 -> (UsageDetails, CoreExpr)
621 occAnalRhs env id rhs
624 ctxt | certainly_inline id = env
625 | otherwise = rhsCtxt
626 -- Note that we generally use an rhsCtxt. This tells the occ anal n
627 -- that it's looking at an RHS, which has an effect in occAnalApp
629 -- But there's a problem. Consider
634 -- First time round, it looks as if x1 and x2 occur as an arg of a
635 -- let-bound constructor ==> give them a many-occurrence.
636 -- But then x3 is inlined (unconditionally as it happens) and
637 -- next time round, x2 will be, and the next time round x1 will be
638 -- Result: multiple simplifier iterations. Sigh.
639 -- Crude solution: use rhsCtxt for things that occur just once...
641 certainly_inline id = case idOccInfo id of
642 OneOcc in_lam one_br _ -> not in_lam && one_br
649 addRuleUsage :: UsageDetails -> Id -> UsageDetails
650 -- Add the usage from RULES in Id to the usage
651 addRuleUsage usage id
652 = foldVarSet add usage (idRuleVars id)
654 add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info
655 -- (i.e manyOcc) because many copies
656 -- of the specialised thing can appear
664 -> (UsageDetails, -- Gives info only about the "interesting" Ids
667 occAnal _ (Type t) = (emptyDetails, Type t)
668 occAnal env (Var v) = (mkOneOcc env v False, Var v)
669 -- At one stage, I gathered the idRuleVars for v here too,
670 -- which in a way is the right thing to do.
671 -- But that went wrong right after specialisation, when
672 -- the *occurrences* of the overloaded function didn't have any
673 -- rules in them, so the *specialised* versions looked as if they
674 -- weren't used at all.
677 We regard variables that occur as constructor arguments as "dangerousToDup":
681 f x = let y = expensive x in
683 (case z of {(p,q)->q}, case z of {(p,q)->q})
686 We feel free to duplicate the WHNF (True,y), but that means
687 that y may be duplicated thereby.
689 If we aren't careful we duplicate the (expensive x) call!
690 Constructors are rather like lambdas in this way.
693 occAnal _ expr@(Lit _) = (emptyDetails, expr)
697 occAnal env (Note InlineMe body)
698 = case occAnal env body of { (usage, body') ->
699 (mapVarEnv markMany usage, Note InlineMe body')
702 occAnal env (Note note@(SCC _) body)
703 = case occAnal env body of { (usage, body') ->
704 (mapVarEnv markInsideSCC usage, Note note body')
707 occAnal env (Note note body)
708 = case occAnal env body of { (usage, body') ->
709 (usage, Note note body')
712 occAnal env (Cast expr co)
713 = case occAnal env expr of { (usage, expr') ->
714 (markRhsUds env True usage, Cast expr' co)
715 -- If we see let x = y `cast` co
716 -- then mark y as 'Many' so that we don't
717 -- immediately inline y again.
722 occAnal env app@(App _ _)
723 = occAnalApp env (collectArgs app)
725 -- Ignore type variables altogether
726 -- (a) occurrences inside type lambdas only not marked as InsideLam
727 -- (b) type variables not in environment
729 occAnal env (Lam x body) | isTyVar x
730 = case occAnal env body of { (body_usage, body') ->
731 (body_usage, Lam x body')
734 -- For value lambdas we do a special hack. Consider
736 -- If we did nothing, x is used inside the \y, so would be marked
737 -- as dangerous to dup. But in the common case where the abstraction
738 -- is applied to two arguments this is over-pessimistic.
739 -- So instead, we just mark each binder with its occurrence
740 -- info in the *body* of the multiple lambda.
741 -- Then, the simplifier is careful when partially applying lambdas.
743 occAnal env expr@(Lam _ _)
744 = case occAnal env_body body of { (body_usage, body') ->
746 (final_usage, tagged_binders) = tagBinders body_usage binders
747 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
748 -- we get linear-typed things in the resulting program that we can't handle yet.
749 -- (e.g. PrelShow) TODO
751 really_final_usage = if linear then
754 mapVarEnv markInsideLam final_usage
757 mkLams tagged_binders body') }
759 env_body = vanillaCtxt -- Body is (no longer) an RhsContext
760 (binders, body) = collectBinders expr
761 binders' = oneShotGroup env binders
762 linear = all is_one_shot binders'
763 is_one_shot b = isId b && isOneShotBndr b
765 occAnal env (Case scrut bndr ty alts)
766 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
767 case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
769 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
770 alts_usage' = addCaseBndrUsage alts_usage
771 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
772 total_usage = scrut_usage +++ alts_usage1
774 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
776 -- The case binder gets a usage of either "many" or "dead", never "one".
777 -- Reason: we like to inline single occurrences, to eliminate a binding,
778 -- but inlining a case binder *doesn't* eliminate a binding.
779 -- We *don't* want to transform
780 -- case x of w { (p,q) -> f w }
782 -- case x of w { (p,q) -> f (p,q) }
783 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
785 Just occ -> extendVarEnv usage bndr (markMany occ)
787 alt_env = setVanillaCtxt env
788 -- Consider x = case v of { True -> (p,q); ... }
789 -- Then it's fine to inline p and q
791 occ_anal_scrut (Var v) (alt1 : other_alts)
792 | not (null other_alts) || not (isDefaultAlt alt1)
793 = (mkOneOcc env v True, Var v)
794 occ_anal_scrut scrut _alts = occAnal vanillaCtxt scrut
795 -- No need for rhsCtxt
797 occAnal env (Let bind body)
798 = case occAnal env body of { (body_usage, body') ->
799 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
800 (final_usage, mkLets new_binds body') }}
802 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
803 occAnalArgs _env args
804 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
805 (foldr (+++) emptyDetails arg_uds_s, args')}
807 arg_env = vanillaCtxt
810 Applications are dealt with specially because we want
811 the "build hack" to work.
815 -> (Expr CoreBndr, [Arg CoreBndr])
816 -> (UsageDetails, Expr CoreBndr)
817 occAnalApp env (Var fun, args)
818 = case args_stuff of { (args_uds, args') ->
820 final_args_uds = markRhsUds env is_pap args_uds
822 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
824 fun_uniq = idUnique fun
825 fun_uds = mkOneOcc env fun (valArgCount args > 0)
826 is_pap = isDataConWorkId fun || valArgCount args < idArity fun
828 -- Hack for build, fold, runST
829 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
830 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
831 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
832 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
833 -- (foldr k z xs) may call k many times, but it never
834 -- shares a partial application of k; hence [False,True]
835 -- This means we can optimise
836 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
837 -- by floating in the v
839 | otherwise = occAnalArgs env args
842 occAnalApp env (fun, args)
843 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
844 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
845 -- often leaves behind beta redexs like
847 -- Here we would like to mark x,y as one-shot, and treat the whole
848 -- thing much like a let. We do this by pushing some True items
849 -- onto the context stack.
851 case occAnalArgs env args of { (args_uds, args') ->
853 final_uds = fun_uds +++ args_uds
855 (final_uds, mkApps fun' args') }}
858 markRhsUds :: OccEnv -- Check if this is a RhsEnv
859 -> Bool -- and this is true
860 -> UsageDetails -- The do markMany on this
862 -- We mark the free vars of the argument of a constructor or PAP
863 -- as "many", if it is the RHS of a let(rec).
864 -- This means that nothing gets inlined into a constructor argument
865 -- position, which is what we want. Typically those constructor
866 -- arguments are just variables, or trivial expressions.
868 -- This is the *whole point* of the isRhsEnv predicate
869 markRhsUds env is_pap arg_uds
870 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
871 | otherwise = arg_uds
875 -> Int -> CtxtTy -- Argument number, and context to use for it
877 -> (UsageDetails, [CoreExpr])
878 appSpecial env n ctxt args
881 arg_env = vanillaCtxt
883 go _ [] = (emptyDetails, []) -- Too few args
885 go 1 (arg:args) -- The magic arg
886 = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
887 case occAnalArgs env args of { (args_uds, args') ->
888 (arg_uds +++ args_uds, arg':args') }}
891 = case occAnal arg_env arg of { (arg_uds, arg') ->
892 case go (n-1) args of { (args_uds, args') ->
893 (arg_uds +++ args_uds, arg':args') }}
899 If the case binder occurs at all, the other binders effectively do too.
901 case e of x { (a,b) -> rhs }
904 If e turns out to be (e1,e2) we indeed get something like
905 let a = e1; b = e2; x = (a,b) in rhs
907 Note [Aug 06]: I don't think this is necessary any more, and it helpe
908 to know when binders are unused. See esp the call to
909 isDeadBinder in Simplify.mkDupableAlt
915 -> (UsageDetails, Alt IdWithOccInfo)
916 occAnalAlt env _case_bndr (con, bndrs, rhs)
917 = case occAnal env rhs of { (rhs_usage, rhs') ->
919 (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
920 final_bndrs = tagged_bndrs -- See Note [Aug06] above
922 final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
923 | otherwise = tagged_bndrs
924 -- Leave the binders untagged if the case
925 -- binder occurs at all; see note above
928 (final_usage, (con, final_bndrs, rhs')) }
932 %************************************************************************
934 \subsection[OccurAnal-types]{OccEnv}
936 %************************************************************************
940 = OccEnv OccEncl -- Enclosing context information
941 CtxtTy -- Tells about linearity
943 -- OccEncl is used to control whether to inline into constructor arguments
945 -- x = (p,q) -- Don't inline p or q
946 -- y = /\a -> (p a, q a) -- Still don't inline p or q
947 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
948 -- So OccEncl tells enought about the context to know what to do when
949 -- we encounter a contructor application or PAP.
952 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
953 -- Don't inline into constructor args here
954 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
955 -- Do inline into constructor args here
960 -- True:ctxt Analysing a function-valued expression that will be
963 -- False:ctxt Analysing a function-valued expression that may
964 -- be applied many times; but when it is,
965 -- the CtxtTy inside applies
968 initOccEnv = OccEnv OccRhs []
970 vanillaCtxt :: OccEnv
971 vanillaCtxt = OccEnv OccVanilla []
974 rhsCtxt = OccEnv OccRhs []
976 isRhsEnv :: OccEnv -> Bool
977 isRhsEnv (OccEnv OccRhs _) = True
978 isRhsEnv (OccEnv OccVanilla _) = False
980 setVanillaCtxt :: OccEnv -> OccEnv
981 setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
982 setVanillaCtxt other_env = other_env
984 setCtxt :: OccEnv -> CtxtTy -> OccEnv
985 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
987 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
988 -- The result binders have one-shot-ness set that they might not have had originally.
989 -- This happens in (build (\cn -> e)). Here the occurrence analyser
990 -- linearity context knows that c,n are one-shot, and it records that fact in
991 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
993 oneShotGroup (OccEnv _encl ctxt) bndrs
996 go _ [] rev_bndrs = reverse rev_bndrs
998 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
999 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
1001 bndr' | lin_ctxt = setOneShotLambda bndr
1004 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1006 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1007 addAppCtxt (OccEnv encl ctxt) args
1008 = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
1011 %************************************************************************
1013 \subsection[OccurAnal-types]{OccEnv}
1015 %************************************************************************
1018 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
1020 (+++), combineAltsUsageDetails
1021 :: UsageDetails -> UsageDetails -> UsageDetails
1024 = plusVarEnv_C addOccInfo usage1 usage2
1026 combineAltsUsageDetails usage1 usage2
1027 = plusVarEnv_C orOccInfo usage1 usage2
1029 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1030 addOneOcc usage id info
1031 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1032 -- ToDo: make this more efficient
1034 emptyDetails :: UsageDetails
1035 emptyDetails = (emptyVarEnv :: UsageDetails)
1037 usedIn :: Id -> UsageDetails -> Bool
1038 v `usedIn` details = isExportedId v || v `elemVarEnv` details
1040 type IdWithOccInfo = Id
1042 tagBinders :: UsageDetails -- Of scope
1044 -> (UsageDetails, -- Details with binders removed
1045 [IdWithOccInfo]) -- Tagged binders
1047 tagBinders usage binders
1049 usage' = usage `delVarEnvList` binders
1050 uss = map (setBinderOcc usage) binders
1052 usage' `seq` (usage', uss)
1054 tagBinder :: UsageDetails -- Of scope
1056 -> (UsageDetails, -- Details with binders removed
1057 IdWithOccInfo) -- Tagged binders
1059 tagBinder usage binder
1061 usage' = usage `delVarEnv` binder
1062 binder' = setBinderOcc usage binder
1064 usage' `seq` (usage', binder')
1066 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1067 setBinderOcc usage bndr
1068 | isTyVar bndr = bndr
1069 | isExportedId bndr = case idOccInfo bndr of
1071 _ -> setIdOccInfo bndr NoOccInfo
1072 -- Don't use local usage info for visible-elsewhere things
1073 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1074 -- about to re-generate it and it shouldn't be "sticky"
1076 | otherwise = setIdOccInfo bndr occ_info
1078 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1082 %************************************************************************
1084 \subsection{Operations over OccInfo}
1086 %************************************************************************
1089 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1090 mkOneOcc _env id int_cxt
1091 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1092 | otherwise = emptyDetails
1094 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1096 markMany IAmDead = IAmDead
1097 markMany _ = NoOccInfo
1099 markInsideSCC occ = markMany occ
1101 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1102 markInsideLam occ = occ
1104 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1106 addOccInfo IAmDead info2 = info2
1107 addOccInfo info1 IAmDead = info1
1108 addOccInfo _ _ = NoOccInfo
1110 -- (orOccInfo orig new) is used
1111 -- when combining occurrence info from branches of a case
1113 orOccInfo IAmDead info2 = info2
1114 orOccInfo info1 IAmDead = info1
1115 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1116 (OneOcc in_lam2 _ int_cxt2)
1117 = OneOcc (in_lam1 || in_lam2)
1118 False -- False, because it occurs in both branches
1119 (int_cxt1 && int_cxt2)
1120 orOccInfo _ _ = NoOccInfo