2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[OccurAnal]{Occurrence analysis pass}
8 %************************************************************************
10 The occurrence analyser re-typechecks a core expression, returning a new
11 core expression with (hopefully) improved usage information.
15 -- The above warning supression flag is a temporary kludge.
16 -- While working on this module you are encouraged to remove it and fix
17 -- any warnings in the module. See
18 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 occurAnalysePgm, occurAnalyseExpr
25 #include "HsVersions.h"
28 import CoreFVs ( idRuleVars )
29 import CoreUtils ( exprIsTrivial, isDefaultAlt )
32 import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
37 import Maybes ( orElse )
38 import Digraph ( stronglyConnCompR, SCC(..) )
39 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
40 import Unique ( Unique )
41 import UniqFM ( keysUFM, intersectsUFM )
42 import Util ( mapAndUnzip )
49 %************************************************************************
51 \subsection[OccurAnal-main]{Counting occurrences: main function}
53 %************************************************************************
55 Here's the externally-callable interface:
58 occurAnalysePgm :: [CoreBind] -> [CoreBind]
60 = snd (go initOccEnv binds)
62 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
66 = (final_usage, bind' ++ binds')
68 (bs_usage, binds') = go env binds
69 (final_usage, bind') = occAnalBind env bind bs_usage
71 occurAnalyseExpr :: CoreExpr -> CoreExpr
72 -- Do occurrence analysis, and discard occurence info returned
73 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
77 %************************************************************************
79 \subsection[OccurAnal-main]{Counting occurrences: main function}
81 %************************************************************************
89 -> UsageDetails -- Usage details of scope
90 -> (UsageDetails, -- Of the whole let(rec)
93 occAnalBind env (NonRec binder rhs) body_usage
94 | not (binder `usedIn` body_usage) -- It's not mentioned
97 | otherwise -- It's mentioned in the body
98 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [RulesOnly]
99 [NonRec tagged_binder rhs'])
101 (body_usage', tagged_binder) = tagBinder body_usage binder
102 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
105 Dropping dead code for recursive bindings is done in a very simple way:
107 the entire set of bindings is dropped if none of its binders are
108 mentioned in its body; otherwise none are.
110 This seems to miss an obvious improvement.
125 Now @f@ is unused. But dependency analysis will sort this out into a
126 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
127 It isn't easy to do a perfect job in one blow. Consider
141 occAnalBind env (Rec pairs) body_usage
142 = foldr ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) (body_usage, []) sccs
144 analysed_pairs :: [Details]
145 analysed_pairs = [ (bndr, rhs_usage, rhs')
146 | (bndr, rhs) <- pairs,
147 let (rhs_usage, rhs') = occAnalRhs env bndr rhs
150 sccs :: [SCC (Node Details)]
151 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR edges
154 ---- stuff for dependency analysis of binds -------------------------------
155 edges :: [Node Details]
156 edges = {-# SCC "occAnalBind.assoc" #-}
157 [ (details, idUnique id, edges_from id rhs_usage)
158 | details@(id, rhs_usage, rhs) <- analysed_pairs
161 -- (a -> b) means a mentions b
162 -- Given the usage details (a UFM that gives occ info for each free var of
163 -- the RHS) we can get the list of free vars -- or rather their Int keys --
164 -- by just extracting the keys from the finite map. Grimy, but fast.
165 -- Previously we had this:
166 -- [ bndr | bndr <- bndrs,
167 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
168 -- which has n**2 cost, and this meant that edges_from alone
169 -- consumed 10% of total runtime!
170 edges_from :: Id -> UsageDetails -> [Unique]
171 edges_from bndr rhs_usage = {-# SCC "occAnalBind.edges_from" #-}
172 keysUFM (addRuleUsage rhs_usage bndr)
174 ---- Stuff to "re-constitute" bindings from dependency-analysis info ------
177 do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
178 | not (bndr `usedIn` body_usage)
179 = (body_usage, binds_so_far) -- Dead code
181 = (body_usage' +++ addRuleUsage rhs_usage bndr, new_bind : binds_so_far)
183 (body_usage', tagged_bndr) = tagBinder body_usage bndr
184 new_bind = NonRec tagged_bndr rhs'
187 do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
188 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
189 = (body_usage, binds_so_far) -- Dead code
190 | otherwise -- If any is used, they all are
191 = (final_usage, final_bind : binds_so_far)
193 details = [details | (details, _, _) <- cycle]
194 bndrs = [bndr | (bndr, _, _) <- details]
195 bndr_usages = [addRuleUsage rhs_usage bndr | (bndr, rhs_usage, _) <- details]
196 total_usage = foldr (+++) body_usage bndr_usages
197 (final_usage, tagged_cycle) = mapAccumL tag_bind total_usage cycle
198 tag_bind usg ((bndr,rhs_usg,rhs),k,ks) = (usg', ((bndr',rhs_usg,rhs),k,ks))
200 (usg', bndr') = tagBinder usg bndr
201 final_bind = Rec (reOrderCycle (mkVarSet bndrs) tagged_cycle)
203 {- An alternative; rebuild the edges. No semantic difference, but perf might change
205 -- Hopefully 'bndrs' is a relatively small group now
206 -- Now get ready for the loop-breaking phase
207 -- We've done dead-code elimination already, so no worries about un-referenced binders
208 keys = map idUnique bndrs
209 mk_node tagged_bndr (_, rhs_usage, rhs')
210 = ((tagged_bndr, rhs'), idUnique tagged_bndr, used)
212 used = [key | key <- keys, used_outside_rule rhs_usage key ]
214 used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of
216 Just RulesOnly -> False -- Ignore rules
221 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
222 strongly connected component (there's guaranteed to be a cycle). It returns the
224 a) in a better order,
225 b) with some of the Ids having a IAmALoopBreaker pragma
227 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
228 that the simplifier can guarantee not to loop provided it never records an inlining
229 for these no-inline guys.
231 Furthermore, the order of the binds is such that if we neglect dependencies
232 on the no-inline Ids then the binds are topologically sorted. This means
233 that the simplifier will generally do a good job if it works from top bottom,
234 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
237 [June 98: I don't understand the following paragraphs, and I've
238 changed the a=b case again so that it isn't a special case any more.]
240 Here's a case that bit me:
248 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
250 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
251 Perhaps something cleverer would suffice.
256 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
257 -- which is gotten from the Id.
258 type Details = (Id, UsageDetails, CoreExpr)
260 reOrderRec :: IdSet -- Binders of this group
261 -> SCC (Node Details)
263 -- Sorted into a plausible order. Enough of the Ids have
264 -- IAmALoopBreaker pragmas that there are no loops left.
265 reOrderRec bndrs (AcyclicSCC ((bndr, _, rhs), _, _)) = [(bndr, rhs)]
266 reOrderRec bndrs (CyclicSCC cycle) = reOrderCycle bndrs cycle
268 reOrderCycle :: IdSet -> [Node Details] -> [(Id,CoreExpr)]
269 reOrderCycle bndrs []
270 = panic "reOrderCycle"
271 reOrderCycle bndrs [bind] -- Common case of simple self-recursion
272 = [(makeLoopBreaker bndrs rhs_usg bndr, rhs)]
274 ((bndr, rhs_usg, rhs), _, _) = bind
276 reOrderCycle bndrs (bind : binds)
277 = -- Choose a loop breaker, mark it no-inline,
278 -- do SCC analysis on the rest, and recursively sort them out
279 concatMap (reOrderRec bndrs) (stronglyConnCompR unchosen) ++
280 [(makeLoopBreaker bndrs rhs_usg bndr, rhs)]
283 (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
284 (bndr, rhs_usg, rhs) = chosen_bind
286 -- This loop looks for the bind with the lowest score
287 -- to pick as the loop breaker. The rest accumulate in
288 choose_loop_breaker (details,_,_) loop_sc acc []
289 = (details, acc) -- Done
291 choose_loop_breaker loop_bind loop_sc acc (bind : binds)
292 | sc < loop_sc -- Lower score so pick this new one
293 = choose_loop_breaker bind sc (loop_bind : acc) binds
295 | otherwise -- No lower so don't pick it
296 = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
300 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
301 score ((bndr, _, rhs), _, _)
302 | workerExists (idWorkerInfo bndr) = 10
303 -- Note [Worker inline loop]
305 | exprIsTrivial rhs = 4 -- Practically certain to be inlined
306 -- Used to have also: && not (isExportedId bndr)
307 -- But I found this sometimes cost an extra iteration when we have
308 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
309 -- where df is the exported dictionary. Then df makes a really
310 -- bad choice for loop breaker
312 | idHasRules bndr = 3
313 -- Avoid things with specialisations; we'd like
314 -- to take advantage of them in the subsequent bindings
315 -- Also vital to avoid risk of divergence:
316 -- Note [Recursive rules]
318 | is_con_app rhs = 2 -- Data types help with cases
321 | inlineCandidate bndr rhs = 1 -- Likely to be inlined
322 -- Note [Inline candidates]
326 inlineCandidate :: Id -> CoreExpr -> Bool
327 inlineCandidate id (Note InlineMe _) = True
328 inlineCandidate id rhs = isOneOcc (idOccInfo id)
332 -- It's really really important to inline dictionaries. Real
333 -- example (the Enum Ordering instance from GHC.Base):
335 -- rec f = \ x -> case d of (p,q,r) -> p x
336 -- g = \ x -> case d of (p,q,r) -> q x
339 -- Here, f and g occur just once; but we can't inline them into d.
340 -- On the other hand we *could* simplify those case expressions if
341 -- we didn't stupidly choose d as the loop breaker.
342 -- But we won't because constructor args are marked "Many".
343 -- Inlining dictionaries is really essential to unravelling
344 -- the loops in static numeric dictionaries, see GHC.Float.
346 -- Cheap and cheerful; the simplifer moves casts out of the way
347 -- The lambda case is important to spot x = /\a. C (f a)
348 -- which comes up when C is a dictionary constructor and
349 -- f is a default method.
350 -- Example: the instance for Show (ST s a) in GHC.ST
352 -- However we *also* treat (\x. C p q) as a con-app-like thing,
353 -- Note [Closure conversion]
354 is_con_app (Var v) = isDataConWorkId v
355 is_con_app (App f _) = is_con_app f
356 is_con_app (Lam b e) = is_con_app e
357 is_con_app (Note _ e) = is_con_app e
358 is_con_app other = False
360 makeLoopBreaker :: VarSet -- Binders of this group
361 -> UsageDetails -- Usage of this rhs (neglecting rules)
363 -- Set the loop-breaker flag, recording whether the thing occurs only in
364 -- the RHS of a RULE (in this recursive group)
365 makeLoopBreaker bndrs rhs_usg bndr
366 = setIdOccInfo bndr (IAmALoopBreaker rules_only)
368 rules_only = bndrs `intersectsUFM` rhs_usg
371 Note [Worker inline loop]
372 ~~~~~~~~~~~~~~~~~~~~~~~~
373 Never choose a wrapper as the loop breaker! Because
374 wrappers get auto-generated inlinings when importing, and
375 that can lead to an infinite inlining loop. For example:
377 $wfoo x = ....foo x....
379 {-loop brk-} foo x = ...$wfoo x...
382 The interface file sees the unfolding for $wfoo, and sees that foo is
383 strict (and hence it gets an auto-generated wrapper). Result: an
384 infinite inlining in the importing scope. So be a bit careful if you
385 change this. A good example is Tree.repTree in
386 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
387 breaker then compiling Game.hs goes into an infinite loop (this
388 happened when we gave is_con_app a lower score than inline candidates).
390 Note [Recursive rules]
391 ~~~~~~~~~~~~~~~~~~~~~~
392 Consider this group, which is typical of what SpecConstr builds:
394 fs a = ....f (C a)....
395 f x = ....f (C a)....
396 {-# RULE f (C a) = fs a #-}
398 So 'f' and 'fs' are mutually recursive. If we choose 'fs' as the loop breaker,
399 all is well; the RULE is applied, and 'fs' becomes self-recursive.
401 But if we choose 'f' as the loop breaker, we may get an infinite loop:
402 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
403 - fs is inlined (say it's small)
404 - now there's another opportunity to apply the RULE
406 So it's very important not to choose the RULE-variable as the loop breaker.
407 This showed up when compiling Control.Concurrent.Chan.getChanContents.
409 Note [Closure conversion]
410 ~~~~~~~~~~~~~~~~~~~~~~~~~
411 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
412 The immediate motivation came from the result of a closure-conversion transformation
413 which generated code like this:
415 data Clo a b = forall c. Clo (c -> a -> b) c
417 ($:) :: Clo a b -> a -> b
418 Clo f env $: x = f env x
420 rec { plus = Clo plus1 ()
422 ; plus1 _ n = Clo plus2 n
425 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
427 If we inline 'plus' and 'plus1', everything unravels nicely. But if
428 we choose 'plus1' as the loop breaker (which is entirely possible
429 otherwise), the loop does not unravel nicely.
432 @occAnalRhs@ deals with the question of bindings where the Id is marked
433 by an INLINE pragma. For these we record that anything which occurs
434 in its RHS occurs many times. This pessimistically assumes that ths
435 inlined binder also occurs many times in its scope, but if it doesn't
436 we'll catch it next time round. At worst this costs an extra simplifier pass.
437 ToDo: try using the occurrence info for the inline'd binder.
439 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
440 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
445 -> Id -> CoreExpr -- Binder and rhs
446 -- For non-recs the binder is alrady tagged
447 -- with occurrence info
448 -> (UsageDetails, CoreExpr)
450 occAnalRhs env id rhs
453 ctxt | certainly_inline id = env
454 | otherwise = rhsCtxt
455 -- Note that we generally use an rhsCtxt. This tells the occ anal n
456 -- that it's looking at an RHS, which has an effect in occAnalApp
458 -- But there's a problem. Consider
463 -- First time round, it looks as if x1 and x2 occur as an arg of a
464 -- let-bound constructor ==> give them a many-occurrence.
465 -- But then x3 is inlined (unconditionally as it happens) and
466 -- next time round, x2 will be, and the next time round x1 will be
467 -- Result: multiple simplifier iterations. Sigh.
468 -- Crude solution: use rhsCtxt for things that occur just once...
470 certainly_inline id = case idOccInfo id of
471 OneOcc in_lam one_br _ -> not in_lam && one_br
477 If the binder has RULES inside it then we count the specialised Ids as
478 "extra rhs's". That way the "parent" keeps the specialised "children"
479 alive. If the parent dies (because it isn't referenced any more),
480 then the children will die too unless they are already referenced
483 That's the basic idea. However in a recursive situation we want to be a bit
484 cleverer. Example (from GHC.Enum):
486 eftInt :: Int# -> Int# -> [Int]
487 eftInt x y = ...(non-recursive)...
489 {-# INLINE [0] eftIntFB #-}
490 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
491 eftIntFB c n x y = ...(non-recursive)...
494 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
495 "eftIntList" [1] eftIntFB (:) [] = eftInt
498 The two look mutually recursive only because of their RULES; we don't want
499 that to inhibit inlining!
501 So when we identify a LoopBreaker, we mark it to say whether it only mentions
502 the other binders in its recursive group in a RULE. If so, we can inline it,
503 because doing so will not expose new occurrences of binders in its group.
508 addRuleUsage :: UsageDetails -> Id -> UsageDetails
509 -- Add the usage from RULES in Id to the usage
510 addRuleUsage usage id
511 = foldVarSet add usage (idRuleVars id)
513 add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info
514 -- (i.e manyOcc) because many copies
515 -- of the specialised thing can appear
523 -> (UsageDetails, -- Gives info only about the "interesting" Ids
526 occAnal env (Type t) = (emptyDetails, Type t)
527 occAnal env (Var v) = (mkOneOcc env v False, Var v)
528 -- At one stage, I gathered the idRuleVars for v here too,
529 -- which in a way is the right thing to do.
530 -- Btu that went wrong right after specialisation, when
531 -- the *occurrences* of the overloaded function didn't have any
532 -- rules in them, so the *specialised* versions looked as if they
533 -- weren't used at all.
536 We regard variables that occur as constructor arguments as "dangerousToDup":
540 f x = let y = expensive x in
542 (case z of {(p,q)->q}, case z of {(p,q)->q})
545 We feel free to duplicate the WHNF (True,y), but that means
546 that y may be duplicated thereby.
548 If we aren't careful we duplicate the (expensive x) call!
549 Constructors are rather like lambdas in this way.
552 occAnal env expr@(Lit lit) = (emptyDetails, expr)
556 occAnal env (Note InlineMe body)
557 = case occAnal env body of { (usage, body') ->
558 (mapVarEnv markMany usage, Note InlineMe body')
561 occAnal env (Note note@(SCC cc) body)
562 = case occAnal env body of { (usage, body') ->
563 (mapVarEnv markInsideSCC usage, Note note body')
566 occAnal env (Note note body)
567 = case occAnal env body of { (usage, body') ->
568 (usage, Note note body')
571 occAnal env (Cast expr co)
572 = case occAnal env expr of { (usage, expr') ->
573 (markRhsUds env True usage, Cast expr' co)
574 -- If we see let x = y `cast` co
575 -- then mark y as 'Many' so that we don't
576 -- immediately inline y again.
581 occAnal env app@(App fun arg)
582 = occAnalApp env (collectArgs app) False
584 -- Ignore type variables altogether
585 -- (a) occurrences inside type lambdas only not marked as InsideLam
586 -- (b) type variables not in environment
588 occAnal env expr@(Lam x body) | isTyVar x
589 = case occAnal env body of { (body_usage, body') ->
590 (body_usage, Lam x body')
593 -- For value lambdas we do a special hack. Consider
595 -- If we did nothing, x is used inside the \y, so would be marked
596 -- as dangerous to dup. But in the common case where the abstraction
597 -- is applied to two arguments this is over-pessimistic.
598 -- So instead, we just mark each binder with its occurrence
599 -- info in the *body* of the multiple lambda.
600 -- Then, the simplifier is careful when partially applying lambdas.
602 occAnal env expr@(Lam _ _)
603 = case occAnal env_body body of { (body_usage, body') ->
605 (final_usage, tagged_binders) = tagBinders body_usage binders
606 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
607 -- we get linear-typed things in the resulting program that we can't handle yet.
608 -- (e.g. PrelShow) TODO
610 really_final_usage = if linear then
613 mapVarEnv markInsideLam final_usage
616 mkLams tagged_binders body') }
618 env_body = vanillaCtxt -- Body is (no longer) an RhsContext
619 (binders, body) = collectBinders expr
620 binders' = oneShotGroup env binders
621 linear = all is_one_shot binders'
622 is_one_shot b = isId b && isOneShotBndr b
624 occAnal env (Case scrut bndr ty alts)
625 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
626 case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
628 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
629 alts_usage' = addCaseBndrUsage alts_usage
630 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
631 total_usage = scrut_usage +++ alts_usage1
633 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
635 -- The case binder gets a usage of either "many" or "dead", never "one".
636 -- Reason: we like to inline single occurrences, to eliminate a binding,
637 -- but inlining a case binder *doesn't* eliminate a binding.
638 -- We *don't* want to transform
639 -- case x of w { (p,q) -> f w }
641 -- case x of w { (p,q) -> f (p,q) }
642 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
644 Just occ -> extendVarEnv usage bndr (markMany occ)
646 alt_env = setVanillaCtxt env
647 -- Consider x = case v of { True -> (p,q); ... }
648 -- Then it's fine to inline p and q
650 occ_anal_scrut (Var v) (alt1 : other_alts)
651 | not (null other_alts) || not (isDefaultAlt alt1)
652 = (mkOneOcc env v True, Var v)
653 occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut
654 -- No need for rhsCtxt
656 occAnal env (Let bind body)
657 = case occAnal env body of { (body_usage, body') ->
658 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
659 (final_usage, mkLets new_binds body') }}
662 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
663 (foldr (+++) emptyDetails arg_uds_s, args')}
665 arg_env = vanillaCtxt
668 Applications are dealt with specially because we want
669 the "build hack" to work.
672 occAnalApp env (Var fun, args) is_rhs
673 = case args_stuff of { (args_uds, args') ->
675 final_args_uds = markRhsUds env is_pap args_uds
677 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
679 fun_uniq = idUnique fun
680 fun_uds = mkOneOcc env fun (valArgCount args > 0)
681 is_pap = isDataConWorkId fun || valArgCount args < idArity fun
683 -- Hack for build, fold, runST
684 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
685 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
686 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
687 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
688 -- (foldr k z xs) may call k many times, but it never
689 -- shares a partial application of k; hence [False,True]
690 -- This means we can optimise
691 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
692 -- by floating in the v
694 | otherwise = occAnalArgs env args
697 occAnalApp env (fun, args) is_rhs
698 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
699 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
700 -- often leaves behind beta redexs like
702 -- Here we would like to mark x,y as one-shot, and treat the whole
703 -- thing much like a let. We do this by pushing some True items
704 -- onto the context stack.
706 case occAnalArgs env args of { (args_uds, args') ->
708 final_uds = fun_uds +++ args_uds
710 (final_uds, mkApps fun' args') }}
713 markRhsUds :: OccEnv -- Check if this is a RhsEnv
714 -> Bool -- and this is true
715 -> UsageDetails -- The do markMany on this
717 -- We mark the free vars of the argument of a constructor or PAP
718 -- as "many", if it is the RHS of a let(rec).
719 -- This means that nothing gets inlined into a constructor argument
720 -- position, which is what we want. Typically those constructor
721 -- arguments are just variables, or trivial expressions.
723 -- This is the *whole point* of the isRhsEnv predicate
724 markRhsUds env is_pap arg_uds
725 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
726 | otherwise = arg_uds
730 -> Int -> CtxtTy -- Argument number, and context to use for it
732 -> (UsageDetails, [CoreExpr])
733 appSpecial env n ctxt args
736 arg_env = vanillaCtxt
738 go n [] = (emptyDetails, []) -- Too few args
740 go 1 (arg:args) -- The magic arg
741 = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
742 case occAnalArgs env args of { (args_uds, args') ->
743 (arg_uds +++ args_uds, arg':args') }}
746 = case occAnal arg_env arg of { (arg_uds, arg') ->
747 case go (n-1) args of { (args_uds, args') ->
748 (arg_uds +++ args_uds, arg':args') }}
754 If the case binder occurs at all, the other binders effectively do too.
756 case e of x { (a,b) -> rhs }
759 If e turns out to be (e1,e2) we indeed get something like
760 let a = e1; b = e2; x = (a,b) in rhs
762 Note [Aug 06]: I don't think this is necessary any more, and it helpe
763 to know when binders are unused. See esp the call to
764 isDeadBinder in Simplify.mkDupableAlt
767 occAnalAlt env case_bndr (con, bndrs, rhs)
768 = case occAnal env rhs of { (rhs_usage, rhs') ->
770 (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
771 final_bndrs = tagged_bndrs -- See Note [Aug06] above
773 final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
774 | otherwise = tagged_bndrs
775 -- Leave the binders untagged if the case
776 -- binder occurs at all; see note above
779 (final_usage, (con, final_bndrs, rhs')) }
783 %************************************************************************
785 \subsection[OccurAnal-types]{OccEnv}
787 %************************************************************************
791 = OccEnv OccEncl -- Enclosing context information
792 CtxtTy -- Tells about linearity
794 -- OccEncl is used to control whether to inline into constructor arguments
796 -- x = (p,q) -- Don't inline p or q
797 -- y = /\a -> (p a, q a) -- Still don't inline p or q
798 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
799 -- So OccEncl tells enought about the context to know what to do when
800 -- we encounter a contructor application or PAP.
803 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
804 -- Don't inline into constructor args here
805 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
806 -- Do inline into constructor args here
811 -- True:ctxt Analysing a function-valued expression that will be
814 -- False:ctxt Analysing a function-valued expression that may
815 -- be applied many times; but when it is,
816 -- the CtxtTy inside applies
819 initOccEnv = OccEnv OccRhs []
821 vanillaCtxt = OccEnv OccVanilla []
822 rhsCtxt = OccEnv OccRhs []
824 isRhsEnv (OccEnv OccRhs _) = True
825 isRhsEnv (OccEnv OccVanilla _) = False
827 setVanillaCtxt :: OccEnv -> OccEnv
828 setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
829 setVanillaCtxt other_env = other_env
831 setCtxt :: OccEnv -> CtxtTy -> OccEnv
832 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
834 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
835 -- The result binders have one-shot-ness set that they might not have had originally.
836 -- This happens in (build (\cn -> e)). Here the occurrence analyser
837 -- linearity context knows that c,n are one-shot, and it records that fact in
838 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
840 oneShotGroup (OccEnv encl ctxt) bndrs
843 go ctxt [] rev_bndrs = reverse rev_bndrs
845 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
846 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
848 bndr' | lin_ctxt = setOneShotLambda bndr
851 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
853 addAppCtxt (OccEnv encl ctxt) args
854 = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
857 %************************************************************************
859 \subsection[OccurAnal-types]{OccEnv}
861 %************************************************************************
864 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
866 (+++), combineAltsUsageDetails
867 :: UsageDetails -> UsageDetails -> UsageDetails
870 = plusVarEnv_C addOccInfo usage1 usage2
872 combineAltsUsageDetails usage1 usage2
873 = plusVarEnv_C orOccInfo usage1 usage2
875 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
876 addOneOcc usage id info
877 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
878 -- ToDo: make this more efficient
880 emptyDetails = (emptyVarEnv :: UsageDetails)
882 usedIn :: Id -> UsageDetails -> Bool
883 v `usedIn` details = isExportedId v || v `elemVarEnv` details
885 type IdWithOccInfo = Id
887 tagBinders :: UsageDetails -- Of scope
889 -> (UsageDetails, -- Details with binders removed
890 [IdWithOccInfo]) -- Tagged binders
892 tagBinders usage binders
894 usage' = usage `delVarEnvList` binders
895 uss = map (setBinderOcc usage) binders
897 usage' `seq` (usage', uss)
899 tagBinder :: UsageDetails -- Of scope
901 -> (UsageDetails, -- Details with binders removed
902 IdWithOccInfo) -- Tagged binders
904 tagBinder usage binder
906 usage' = usage `delVarEnv` binder
907 binder' = setBinderOcc usage binder
909 usage' `seq` (usage', binder')
911 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
912 setBinderOcc usage bndr
913 | isTyVar bndr = bndr
914 | isExportedId bndr = case idOccInfo bndr of
916 other -> setIdOccInfo bndr NoOccInfo
917 -- Don't use local usage info for visible-elsewhere things
918 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
919 -- about to re-generate it and it shouldn't be "sticky"
921 | otherwise = setIdOccInfo bndr occ_info
923 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
927 %************************************************************************
929 \subsection{Operations over OccInfo}
931 %************************************************************************
934 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
935 mkOneOcc env id int_cxt
936 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
937 | otherwise = emptyDetails
939 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
941 markMany IAmDead = IAmDead
942 markMany other = NoOccInfo
944 markInsideSCC occ = markMany occ
946 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
947 markInsideLam occ = occ
949 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
951 addOccInfo IAmDead info2 = info2
952 addOccInfo info1 IAmDead = info1
953 addOccInfo info1 info2 = NoOccInfo
955 -- (orOccInfo orig new) is used
956 -- when combining occurrence info from branches of a case
958 orOccInfo IAmDead info2 = info2
959 orOccInfo info1 IAmDead = info1
960 orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
961 (OneOcc in_lam2 one_branch2 int_cxt2)
962 = OneOcc (in_lam1 || in_lam2)
963 False -- False, because it occurs in both branches
964 (int_cxt1 && int_cxt2)
965 orOccInfo info1 info2 = NoOccInfo