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 -- XXX This define is a bit of a hack, and should be done more nicely
19 #define FAST_STRING_NOT_NEEDED 1
20 #include "HsVersions.h"
24 import CoreUtils ( exprIsTrivial, isDefaultAlt )
32 import Maybes ( orElse )
33 import Digraph ( stronglyConnCompR, SCC(..) )
34 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
35 import Unique ( Unique )
36 import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
37 import Util ( mapAndUnzip )
44 %************************************************************************
46 \subsection[OccurAnal-main]{Counting occurrences: main function}
48 %************************************************************************
50 Here's the externally-callable interface:
53 occurAnalysePgm :: [CoreBind] -> [CoreBind]
55 = snd (go initOccEnv binds)
57 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
61 = (final_usage, bind' ++ binds')
63 (bs_usage, binds') = go env binds
64 (final_usage, bind') = occAnalBind env bind bs_usage
66 occurAnalyseExpr :: CoreExpr -> CoreExpr
67 -- Do occurrence analysis, and discard occurence info returned
68 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
72 %************************************************************************
74 \subsection[OccurAnal-main]{Counting occurrences: main function}
76 %************************************************************************
84 -> UsageDetails -- Usage details of scope
85 -> (UsageDetails, -- Of the whole let(rec)
88 occAnalBind env (NonRec binder rhs) body_usage
89 | not (binder `usedIn` body_usage) -- It's not mentioned
92 | otherwise -- It's mentioned in the body
93 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
94 [NonRec tagged_binder rhs'])
96 (body_usage', tagged_binder) = tagBinder body_usage binder
97 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
102 Dropping dead code for recursive bindings is done in a very simple way:
104 the entire set of bindings is dropped if none of its binders are
105 mentioned in its body; otherwise none are.
107 This seems to miss an obvious improvement.
119 Now 'f' is unused! But it's OK! Dependency analysis will sort this
120 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
121 dropped. It isn't easy to do a perfect job in one blow. Consider
132 Note [Loop breaking and RULES]
133 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
134 Loop breaking is surprisingly subtle. First read the section 4 of
135 "Secrets of the GHC inliner". This describes our basic plan.
137 However things are made quite a bit more complicated by RULES. Remember
139 * Note [Rules are extra RHSs]
140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
141 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
142 keeps the specialised "children" alive. If the parent dies
143 (because it isn't referenced any more), then the children will die
144 too (unless they are already referenced directly).
146 To that end, we build a Rec group for each cyclic strongly
148 *treating f's rules as extra RHSs for 'f'*.
150 When we make the Rec groups we include variables free in *either*
151 LHS *or* RHS of the rule. The former might seems silly, but see
152 Note [Rule dependency info].
154 So in Example [eftInt], eftInt and eftIntFB will be put in the
155 same Rec, even though their 'main' RHSs are both non-recursive.
157 * Note [Rules are visible in their own rec group]
158 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
159 We want the rules for 'f' to be visible in f's right-hand side.
160 And we'd like them to be visible in other functions in f's Rec
161 group. E.g. in Example [Specialisation rules] we want f' rule
162 to be visible in both f's RHS, and fs's RHS.
164 This means that we must simplify the RULEs first, before looking
165 at any of the definitions. This is done by Simplify.simplRecBind,
166 when it calls addLetIdInfo.
168 * Note [Choosing loop breakers]
169 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
170 We avoid infinite inlinings by choosing loop breakers, and
171 ensuring that a loop breaker cuts each loop. But what is a
172 "loop"? In particular, a RULES is like an equation for 'f' that
173 is *always* inlined if it are applicable. We do *not* disable
174 rules for loop-breakers. It's up to whoever makes the rules to
175 make sure that the rules themselves alwasys terminate. See Note
176 [Rules for recursive functions] in Simplify.lhs
179 f's RHS mentions g, and
180 g has a RULE that mentions h, and
181 h has a RULE that mentions f
183 then we *must* choose f to be a loop breaker. In general, take the
184 free variables of f's RHS, and augment it with all the variables
185 reachable by RULES from those starting points. That is the whole
186 reason for computing rule_fv_env in occAnalBind. (Of course we
187 only consider free vars that are also binders in this Rec group.)
189 Note that when we compute this rule_fv_env, we only consider variables
190 free in the *RHS* of the rule, in contrast to the way we build the
191 Rec group in the first place (Note [Rule dependency info])
193 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
194 chosen as a loop breaker, because their RHSs don't mention each other.
195 And indeed both can be inlined safely.
197 Note that the edges of the graph we use for computing loop breakers
198 are not the same as the edges we use for computing the Rec blocks.
199 That's why we compute
200 rec_edges for the Rec block analysis
201 loop_breaker_edges for the loop breaker analysis
204 * Note [Weak loop breakers]
205 ~~~~~~~~~~~~~~~~~~~~~~~~~
206 There is a last nasty wrinkle. Suppose we have
216 Remmber that we simplify the RULES before any RHS (see Note
217 [Rules are visible in their own rec group] above).
219 So we must *not* postInlineUnconditionally 'g', even though
220 its RHS turns out to be trivial. (I'm assuming that 'g' is
221 not choosen as a loop breaker.)
223 We "solve" this by making g a "weak" or "rules-only" loop breaker,
224 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
225 has IAmLoopBreaker False. So
227 Inline postInlineUnconditinoally
228 IAmLoopBreaker False no no
229 IAmLoopBreaker True yes no
232 The **sole** reason for this kind of loop breaker is so that
233 postInlineUnconditionally does not fire. Ugh.
235 * Note [Rule dependency info]
236 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
237 The VarSet in a SpecInfo is used for dependency analysis in the
238 occurrence analyser. We must track free vars in *both* lhs and rhs. Why both?
242 Then if we substitute y for x, we'd better do so in the
243 rule's LHS too, so we'd better ensure the dependency is respected
248 Example (from GHC.Enum):
250 eftInt :: Int# -> Int# -> [Int]
251 eftInt x y = ...(non-recursive)...
253 {-# INLINE [0] eftIntFB #-}
254 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
255 eftIntFB c n x y = ...(non-recursive)...
258 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
259 "eftIntList" [1] eftIntFB (:) [] = eftInt
262 Example [Specialisation rules]
263 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
264 Consider this group, which is typical of what SpecConstr builds:
266 fs a = ....f (C a)....
267 f x = ....f (C a)....
268 {-# RULE f (C a) = fs a #-}
270 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
272 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
273 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
274 - fs is inlined (say it's small)
275 - now there's another opportunity to apply the RULE
277 This showed up when compiling Control.Concurrent.Chan.getChanContents.
281 occAnalBind env (Rec pairs) body_usage
282 = foldr occAnalRec (body_usage, []) sccs
283 -- For a recursive group, we
284 -- * occ-analyse all the RHSs
285 -- * compute strongly-connected components
286 -- * feed those components to occAnalRec
288 -------------Dependency analysis ------------------------------
289 bndr_set = mkVarSet (map fst pairs)
291 sccs :: [SCC (Node Details)]
292 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges
294 rec_edges :: [Node Details]
295 rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
297 make_node (bndr, rhs)
298 = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
300 (rhs_usage, rhs') = occAnalRhs env bndr rhs
301 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
302 out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
303 -- (a -> b) means a mentions b
304 -- Given the usage details (a UFM that gives occ info for each free var of
305 -- the RHS) we can get the list of free vars -- or rather their Int keys --
306 -- by just extracting the keys from the finite map. Grimy, but fast.
307 -- Previously we had this:
308 -- [ bndr | bndr <- bndrs,
309 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
310 -- which has n**2 cost, and this meant that edges_from alone
311 -- consumed 10% of total runtime!
313 -----------------------------
314 occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
315 -> (UsageDetails, [CoreBind])
317 -- The NonRec case is just like a Let (NonRec ...) above
318 occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
319 | not (bndr `usedIn` body_usage)
320 = (body_usage, binds)
322 | otherwise -- It's mentioned in the body
323 = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs]
324 NonRec tagged_bndr rhs : binds)
326 (body_usage', tagged_bndr) = tagBinder body_usage bndr
329 -- The Rec case is the interesting one
330 -- See Note [Loop breaking]
331 occAnalRec (CyclicSCC nodes) (body_usage, binds)
332 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
333 = (body_usage, binds) -- Dead code
335 | otherwise -- At this point we always build a single Rec
336 = (final_usage, Rec pairs : binds)
339 bndrs = [b | (ND b _ _ _, _, _) <- nodes]
340 bndr_set = mkVarSet bndrs
342 ----------------------------
343 -- Tag the binders with their occurrence info
344 total_usage = foldl add_usage body_usage nodes
345 add_usage body_usage (ND bndr _ rhs_usage _, _, _)
346 = body_usage +++ addRuleUsage rhs_usage bndr
347 (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
349 tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
350 -- (a) Tag the binders in the details with occ info
351 -- (b) Mark the binder with OccInfo saying "no preInlineUnconditionally" if
352 -- it is used in any rule (lhs or rhs) of the recursive group
353 -- See Note [Weak loop breakers]
354 tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
355 = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
357 bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
359 bndr1 = setBinderOcc usage bndr
360 all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
363 ----------------------------
364 -- Now reconstruct the cycle
365 pairs | no_rules = reOrderCycle tagged_nodes
366 | otherwise = concatMap reOrderRec (stronglyConnCompR loop_breaker_edges)
368 -- See Note [Choosing loop breakers] for looop_breaker_edges
369 loop_breaker_edges = map mk_node tagged_nodes
370 mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
372 new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
374 ------------------------------------
375 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
376 -- Domain is *subset* of bound vars (others have no rule fvs)
377 rule_fv_env = rule_loop init_rule_fvs
379 no_rules = null init_rule_fvs
380 init_rule_fvs = [(b, rule_fvs)
382 , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
383 , not (isEmptyVarSet rule_fvs)]
385 rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
388 | otherwise = rule_loop new_fv_list
390 env = mkVarEnv init_rule_fvs
391 (no_change, new_fv_list) = mapAccumL bump True fv_list
392 bump no_change (b,fvs)
393 | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
394 | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
396 new_fvs = extendFvs env emptyVarSet fvs
398 idRuleRhsVars :: Id -> VarSet
399 -- Just the variables free on the *rhs* of a rule
400 -- See Note [Choosing loop breakers]
401 idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id)
403 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
404 -- (extendFVs env fvs s) returns (fvs `union` env(s))
405 extendFvs env fvs id_set
406 = foldUFM_Directly add fvs id_set
409 = case lookupVarEnv_Directly env uniq of
410 Just fvs' -> fvs' `unionVarSet` fvs
414 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
415 strongly connected component (there's guaranteed to be a cycle). It returns the
417 a) in a better order,
418 b) with some of the Ids having a IAmALoopBreaker pragma
420 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
421 that the simplifier can guarantee not to loop provided it never records an inlining
422 for these no-inline guys.
424 Furthermore, the order of the binds is such that if we neglect dependencies
425 on the no-inline Ids then the binds are topologically sorted. This means
426 that the simplifier will generally do a good job if it works from top bottom,
427 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
430 [June 98: I don't understand the following paragraphs, and I've
431 changed the a=b case again so that it isn't a special case any more.]
433 Here's a case that bit me:
441 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
443 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
444 Perhaps something cleverer would suffice.
449 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
450 -- which is gotten from the Id.
451 data Details = ND Id -- Binder
453 UsageDetails -- Full usage from RHS (*not* including rules)
454 IdSet -- Other binders from this Rec group mentioned on RHS
455 -- (derivable from UsageDetails but cached here)
457 reOrderRec :: SCC (Node Details)
459 -- Sorted into a plausible order. Enough of the Ids have
460 -- IAmALoopBreaker pragmas that there are no loops left.
461 reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)]
462 reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
464 reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
466 = panic "reOrderCycle"
467 reOrderCycle [bind] -- Common case of simple self-recursion
468 = [(makeLoopBreaker False bndr, rhs)]
470 (ND bndr rhs _ _, _, _) = bind
472 reOrderCycle (bind : binds)
473 = -- Choose a loop breaker, mark it no-inline,
474 -- do SCC analysis on the rest, and recursively sort them out
475 concatMap reOrderRec (stronglyConnCompR unchosen) ++
476 [(makeLoopBreaker False bndr, rhs)]
479 (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
480 ND bndr rhs _ _ = chosen_bind
482 -- This loop looks for the bind with the lowest score
483 -- to pick as the loop breaker. The rest accumulate in
484 choose_loop_breaker (details,_,_) _loop_sc acc []
485 = (details, acc) -- Done
487 choose_loop_breaker loop_bind loop_sc acc (bind : binds)
488 | sc < loop_sc -- Lower score so pick this new one
489 = choose_loop_breaker bind sc (loop_bind : acc) binds
491 | otherwise -- No lower so don't pick it
492 = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
496 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
497 score (ND bndr rhs _ _, _, _)
498 | workerExists (idWorkerInfo bndr) = 10
499 -- Note [Worker inline loop]
501 | exprIsTrivial rhs = 4 -- Practically certain to be inlined
502 -- Used to have also: && not (isExportedId bndr)
503 -- But I found this sometimes cost an extra iteration when we have
504 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
505 -- where df is the exported dictionary. Then df makes a really
506 -- bad choice for loop breaker
508 | is_con_app rhs = 2 -- Data types help with cases
511 | inlineCandidate bndr rhs = 1 -- Likely to be inlined
512 -- Note [Inline candidates]
516 inlineCandidate :: Id -> CoreExpr -> Bool
517 inlineCandidate _ (Note InlineMe _) = True
518 inlineCandidate id _ = isOneOcc (idOccInfo id)
522 -- It's really really important to inline dictionaries. Real
523 -- example (the Enum Ordering instance from GHC.Base):
525 -- rec f = \ x -> case d of (p,q,r) -> p x
526 -- g = \ x -> case d of (p,q,r) -> q x
529 -- Here, f and g occur just once; but we can't inline them into d.
530 -- On the other hand we *could* simplify those case expressions if
531 -- we didn't stupidly choose d as the loop breaker.
532 -- But we won't because constructor args are marked "Many".
533 -- Inlining dictionaries is really essential to unravelling
534 -- the loops in static numeric dictionaries, see GHC.Float.
536 -- Cheap and cheerful; the simplifer moves casts out of the way
537 -- The lambda case is important to spot x = /\a. C (f a)
538 -- which comes up when C is a dictionary constructor and
539 -- f is a default method.
540 -- Example: the instance for Show (ST s a) in GHC.ST
542 -- However we *also* treat (\x. C p q) as a con-app-like thing,
543 -- Note [Closure conversion]
544 is_con_app (Var v) = isDataConWorkId v
545 is_con_app (App f _) = is_con_app f
546 is_con_app (Lam _ e) = is_con_app e
547 is_con_app (Note _ e) = is_con_app e
550 makeLoopBreaker :: Bool -> Id -> Id
551 -- Set the loop-breaker flag
552 -- See Note [Weak loop breakers]
553 makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
556 Note [Worker inline loop]
557 ~~~~~~~~~~~~~~~~~~~~~~~~
558 Never choose a wrapper as the loop breaker! Because
559 wrappers get auto-generated inlinings when importing, and
560 that can lead to an infinite inlining loop. For example:
562 $wfoo x = ....foo x....
564 {-loop brk-} foo x = ...$wfoo x...
567 The interface file sees the unfolding for $wfoo, and sees that foo is
568 strict (and hence it gets an auto-generated wrapper). Result: an
569 infinite inlining in the importing scope. So be a bit careful if you
570 change this. A good example is Tree.repTree in
571 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
572 breaker then compiling Game.hs goes into an infinite loop (this
573 happened when we gave is_con_app a lower score than inline candidates).
575 Note [Closure conversion]
576 ~~~~~~~~~~~~~~~~~~~~~~~~~
577 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
578 The immediate motivation came from the result of a closure-conversion transformation
579 which generated code like this:
581 data Clo a b = forall c. Clo (c -> a -> b) c
583 ($:) :: Clo a b -> a -> b
584 Clo f env $: x = f env x
586 rec { plus = Clo plus1 ()
588 ; plus1 _ n = Clo plus2 n
591 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
593 If we inline 'plus' and 'plus1', everything unravels nicely. But if
594 we choose 'plus1' as the loop breaker (which is entirely possible
595 otherwise), the loop does not unravel nicely.
598 @occAnalRhs@ deals with the question of bindings where the Id is marked
599 by an INLINE pragma. For these we record that anything which occurs
600 in its RHS occurs many times. This pessimistically assumes that ths
601 inlined binder also occurs many times in its scope, but if it doesn't
602 we'll catch it next time round. At worst this costs an extra simplifier pass.
603 ToDo: try using the occurrence info for the inline'd binder.
605 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
606 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
611 -> Id -> CoreExpr -- Binder and rhs
612 -- For non-recs the binder is alrady tagged
613 -- with occurrence info
614 -> (UsageDetails, CoreExpr)
616 occAnalRhs env id rhs
619 ctxt | certainly_inline id = env
620 | otherwise = rhsCtxt
621 -- Note that we generally use an rhsCtxt. This tells the occ anal n
622 -- that it's looking at an RHS, which has an effect in occAnalApp
624 -- But there's a problem. Consider
629 -- First time round, it looks as if x1 and x2 occur as an arg of a
630 -- let-bound constructor ==> give them a many-occurrence.
631 -- But then x3 is inlined (unconditionally as it happens) and
632 -- next time round, x2 will be, and the next time round x1 will be
633 -- Result: multiple simplifier iterations. Sigh.
634 -- Crude solution: use rhsCtxt for things that occur just once...
636 certainly_inline id = case idOccInfo id of
637 OneOcc in_lam one_br _ -> not in_lam && one_br
644 addRuleUsage :: UsageDetails -> Id -> UsageDetails
645 -- Add the usage from RULES in Id to the usage
646 addRuleUsage usage id
647 = foldVarSet add usage (idRuleVars id)
649 add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info
650 -- (i.e manyOcc) because many copies
651 -- of the specialised thing can appear
659 -> (UsageDetails, -- Gives info only about the "interesting" Ids
662 occAnal _ (Type t) = (emptyDetails, Type t)
663 occAnal env (Var v) = (mkOneOcc env v False, Var v)
664 -- At one stage, I gathered the idRuleVars for v here too,
665 -- which in a way is the right thing to do.
666 -- But that went wrong right after specialisation, when
667 -- the *occurrences* of the overloaded function didn't have any
668 -- rules in them, so the *specialised* versions looked as if they
669 -- weren't used at all.
672 We regard variables that occur as constructor arguments as "dangerousToDup":
676 f x = let y = expensive x in
678 (case z of {(p,q)->q}, case z of {(p,q)->q})
681 We feel free to duplicate the WHNF (True,y), but that means
682 that y may be duplicated thereby.
684 If we aren't careful we duplicate the (expensive x) call!
685 Constructors are rather like lambdas in this way.
688 occAnal _ expr@(Lit _) = (emptyDetails, expr)
692 occAnal env (Note InlineMe body)
693 = case occAnal env body of { (usage, body') ->
694 (mapVarEnv markMany usage, Note InlineMe body')
697 occAnal env (Note note@(SCC _) body)
698 = case occAnal env body of { (usage, body') ->
699 (mapVarEnv markInsideSCC usage, Note note body')
702 occAnal env (Note note body)
703 = case occAnal env body of { (usage, body') ->
704 (usage, Note note body')
707 occAnal env (Cast expr co)
708 = case occAnal env expr of { (usage, expr') ->
709 (markRhsUds env True usage, Cast expr' co)
710 -- If we see let x = y `cast` co
711 -- then mark y as 'Many' so that we don't
712 -- immediately inline y again.
717 occAnal env app@(App _ _)
718 = occAnalApp env (collectArgs app)
720 -- Ignore type variables altogether
721 -- (a) occurrences inside type lambdas only not marked as InsideLam
722 -- (b) type variables not in environment
724 occAnal env (Lam x body) | isTyVar x
725 = case occAnal env body of { (body_usage, body') ->
726 (body_usage, Lam x body')
729 -- For value lambdas we do a special hack. Consider
731 -- If we did nothing, x is used inside the \y, so would be marked
732 -- as dangerous to dup. But in the common case where the abstraction
733 -- is applied to two arguments this is over-pessimistic.
734 -- So instead, we just mark each binder with its occurrence
735 -- info in the *body* of the multiple lambda.
736 -- Then, the simplifier is careful when partially applying lambdas.
738 occAnal env expr@(Lam _ _)
739 = case occAnal env_body body of { (body_usage, body') ->
741 (final_usage, tagged_binders) = tagBinders body_usage binders
742 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
743 -- we get linear-typed things in the resulting program that we can't handle yet.
744 -- (e.g. PrelShow) TODO
746 really_final_usage = if linear then
749 mapVarEnv markInsideLam final_usage
752 mkLams tagged_binders body') }
754 env_body = vanillaCtxt -- Body is (no longer) an RhsContext
755 (binders, body) = collectBinders expr
756 binders' = oneShotGroup env binders
757 linear = all is_one_shot binders'
758 is_one_shot b = isId b && isOneShotBndr b
760 occAnal env (Case scrut bndr ty alts)
761 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
762 case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
764 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
765 alts_usage' = addCaseBndrUsage alts_usage
766 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
767 total_usage = scrut_usage +++ alts_usage1
769 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
771 -- The case binder gets a usage of either "many" or "dead", never "one".
772 -- Reason: we like to inline single occurrences, to eliminate a binding,
773 -- but inlining a case binder *doesn't* eliminate a binding.
774 -- We *don't* want to transform
775 -- case x of w { (p,q) -> f w }
777 -- case x of w { (p,q) -> f (p,q) }
778 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
780 Just occ -> extendVarEnv usage bndr (markMany occ)
782 alt_env = setVanillaCtxt env
783 -- Consider x = case v of { True -> (p,q); ... }
784 -- Then it's fine to inline p and q
786 occ_anal_scrut (Var v) (alt1 : other_alts)
787 | not (null other_alts) || not (isDefaultAlt alt1)
788 = (mkOneOcc env v True, Var v)
789 occ_anal_scrut scrut _alts = occAnal vanillaCtxt scrut
790 -- No need for rhsCtxt
792 occAnal env (Let bind body)
793 = case occAnal env body of { (body_usage, body') ->
794 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
795 (final_usage, mkLets new_binds body') }}
797 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
798 occAnalArgs _env args
799 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
800 (foldr (+++) emptyDetails arg_uds_s, args')}
802 arg_env = vanillaCtxt
805 Applications are dealt with specially because we want
806 the "build hack" to work.
810 -> (Expr CoreBndr, [Arg CoreBndr])
811 -> (UsageDetails, Expr CoreBndr)
812 occAnalApp env (Var fun, args)
813 = case args_stuff of { (args_uds, args') ->
815 final_args_uds = markRhsUds env is_pap args_uds
817 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
819 fun_uniq = idUnique fun
820 fun_uds = mkOneOcc env fun (valArgCount args > 0)
821 is_pap = isDataConWorkId fun || valArgCount args < idArity fun
823 -- Hack for build, fold, runST
824 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
825 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
826 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
827 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
828 -- (foldr k z xs) may call k many times, but it never
829 -- shares a partial application of k; hence [False,True]
830 -- This means we can optimise
831 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
832 -- by floating in the v
834 | otherwise = occAnalArgs env args
837 occAnalApp env (fun, args)
838 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
839 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
840 -- often leaves behind beta redexs like
842 -- Here we would like to mark x,y as one-shot, and treat the whole
843 -- thing much like a let. We do this by pushing some True items
844 -- onto the context stack.
846 case occAnalArgs env args of { (args_uds, args') ->
848 final_uds = fun_uds +++ args_uds
850 (final_uds, mkApps fun' args') }}
853 markRhsUds :: OccEnv -- Check if this is a RhsEnv
854 -> Bool -- and this is true
855 -> UsageDetails -- The do markMany on this
857 -- We mark the free vars of the argument of a constructor or PAP
858 -- as "many", if it is the RHS of a let(rec).
859 -- This means that nothing gets inlined into a constructor argument
860 -- position, which is what we want. Typically those constructor
861 -- arguments are just variables, or trivial expressions.
863 -- This is the *whole point* of the isRhsEnv predicate
864 markRhsUds env is_pap arg_uds
865 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
866 | otherwise = arg_uds
870 -> Int -> CtxtTy -- Argument number, and context to use for it
872 -> (UsageDetails, [CoreExpr])
873 appSpecial env n ctxt args
876 arg_env = vanillaCtxt
878 go _ [] = (emptyDetails, []) -- Too few args
880 go 1 (arg:args) -- The magic arg
881 = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
882 case occAnalArgs env args of { (args_uds, args') ->
883 (arg_uds +++ args_uds, arg':args') }}
886 = case occAnal arg_env arg of { (arg_uds, arg') ->
887 case go (n-1) args of { (args_uds, args') ->
888 (arg_uds +++ args_uds, arg':args') }}
894 If the case binder occurs at all, the other binders effectively do too.
896 case e of x { (a,b) -> rhs }
899 If e turns out to be (e1,e2) we indeed get something like
900 let a = e1; b = e2; x = (a,b) in rhs
902 Note [Aug 06]: I don't think this is necessary any more, and it helpe
903 to know when binders are unused. See esp the call to
904 isDeadBinder in Simplify.mkDupableAlt
910 -> (UsageDetails, Alt IdWithOccInfo)
911 occAnalAlt env _case_bndr (con, bndrs, rhs)
912 = case occAnal env rhs of { (rhs_usage, rhs') ->
914 (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
915 final_bndrs = tagged_bndrs -- See Note [Aug06] above
917 final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
918 | otherwise = tagged_bndrs
919 -- Leave the binders untagged if the case
920 -- binder occurs at all; see note above
923 (final_usage, (con, final_bndrs, rhs')) }
927 %************************************************************************
929 \subsection[OccurAnal-types]{OccEnv}
931 %************************************************************************
935 = OccEnv OccEncl -- Enclosing context information
936 CtxtTy -- Tells about linearity
938 -- OccEncl is used to control whether to inline into constructor arguments
940 -- x = (p,q) -- Don't inline p or q
941 -- y = /\a -> (p a, q a) -- Still don't inline p or q
942 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
943 -- So OccEncl tells enought about the context to know what to do when
944 -- we encounter a contructor application or PAP.
947 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
948 -- Don't inline into constructor args here
949 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
950 -- Do inline into constructor args here
955 -- True:ctxt Analysing a function-valued expression that will be
958 -- False:ctxt Analysing a function-valued expression that may
959 -- be applied many times; but when it is,
960 -- the CtxtTy inside applies
963 initOccEnv = OccEnv OccRhs []
965 vanillaCtxt :: OccEnv
966 vanillaCtxt = OccEnv OccVanilla []
969 rhsCtxt = OccEnv OccRhs []
971 isRhsEnv :: OccEnv -> Bool
972 isRhsEnv (OccEnv OccRhs _) = True
973 isRhsEnv (OccEnv OccVanilla _) = False
975 setVanillaCtxt :: OccEnv -> OccEnv
976 setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
977 setVanillaCtxt other_env = other_env
979 setCtxt :: OccEnv -> CtxtTy -> OccEnv
980 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
982 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
983 -- The result binders have one-shot-ness set that they might not have had originally.
984 -- This happens in (build (\cn -> e)). Here the occurrence analyser
985 -- linearity context knows that c,n are one-shot, and it records that fact in
986 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
988 oneShotGroup (OccEnv _encl ctxt) bndrs
991 go _ [] rev_bndrs = reverse rev_bndrs
993 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
994 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
996 bndr' | lin_ctxt = setOneShotLambda bndr
999 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1001 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1002 addAppCtxt (OccEnv encl ctxt) args
1003 = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
1006 %************************************************************************
1008 \subsection[OccurAnal-types]{OccEnv}
1010 %************************************************************************
1013 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
1015 (+++), combineAltsUsageDetails
1016 :: UsageDetails -> UsageDetails -> UsageDetails
1019 = plusVarEnv_C addOccInfo usage1 usage2
1021 combineAltsUsageDetails usage1 usage2
1022 = plusVarEnv_C orOccInfo usage1 usage2
1024 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1025 addOneOcc usage id info
1026 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1027 -- ToDo: make this more efficient
1029 emptyDetails :: UsageDetails
1030 emptyDetails = (emptyVarEnv :: UsageDetails)
1032 usedIn :: Id -> UsageDetails -> Bool
1033 v `usedIn` details = isExportedId v || v `elemVarEnv` details
1035 type IdWithOccInfo = Id
1037 tagBinders :: UsageDetails -- Of scope
1039 -> (UsageDetails, -- Details with binders removed
1040 [IdWithOccInfo]) -- Tagged binders
1042 tagBinders usage binders
1044 usage' = usage `delVarEnvList` binders
1045 uss = map (setBinderOcc usage) binders
1047 usage' `seq` (usage', uss)
1049 tagBinder :: UsageDetails -- Of scope
1051 -> (UsageDetails, -- Details with binders removed
1052 IdWithOccInfo) -- Tagged binders
1054 tagBinder usage binder
1056 usage' = usage `delVarEnv` binder
1057 binder' = setBinderOcc usage binder
1059 usage' `seq` (usage', binder')
1061 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1062 setBinderOcc usage bndr
1063 | isTyVar bndr = bndr
1064 | isExportedId bndr = case idOccInfo bndr of
1066 _ -> setIdOccInfo bndr NoOccInfo
1067 -- Don't use local usage info for visible-elsewhere things
1068 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1069 -- about to re-generate it and it shouldn't be "sticky"
1071 | otherwise = setIdOccInfo bndr occ_info
1073 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1077 %************************************************************************
1079 \subsection{Operations over OccInfo}
1081 %************************************************************************
1084 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1085 mkOneOcc _env id int_cxt
1086 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1087 | otherwise = emptyDetails
1089 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1091 markMany IAmDead = IAmDead
1092 markMany _ = NoOccInfo
1094 markInsideSCC occ = markMany occ
1096 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1097 markInsideLam occ = occ
1099 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1101 addOccInfo IAmDead info2 = info2
1102 addOccInfo info1 IAmDead = info1
1103 addOccInfo _ _ = NoOccInfo
1105 -- (orOccInfo orig new) is used
1106 -- when combining occurrence info from branches of a case
1108 orOccInfo IAmDead info2 = info2
1109 orOccInfo info1 IAmDead = info1
1110 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1111 (OneOcc in_lam2 _ int_cxt2)
1112 = OneOcc (in_lam1 || in_lam2)
1113 False -- False, because it occurs in both branches
1114 (int_cxt1 && int_cxt2)
1115 orOccInfo _ _ = NoOccInfo