c593e81eb668faa151fb31f1fc24a08bb3d93230
[ghc.git] / compiler / simplCore / OccurAnal.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 %************************************************************************
5 %*                                                                      *
6 \section[OccurAnal]{Occurrence analysis pass}
7 %*                                                                      *
8 %************************************************************************
9
10 The occurrence analyser re-typechecks a core expression, returning a new
11 core expression with (hopefully) improved usage information.
12
13 \begin{code}
14 module OccurAnal (
15         occurAnalysePgm, occurAnalyseExpr
16     ) where
17
18 #include "HsVersions.h"
19
20 import CoreSyn
21 import CoreFVs
22 import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
23 import Id
24 import NameEnv
25 import NameSet
26 import Name             ( Name, localiseName )
27 import BasicTypes
28 import Coercion
29
30 import VarSet
31 import VarEnv
32 import Var
33
34 import Maybes           ( orElse )
35 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVerticesR )
36 import PrelNames        ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
37 import Unique
38 import UniqFM
39 import Util             ( mapAndUnzip, filterOut )
40 import Bag
41 import Outputable
42 import FastString
43 import Data.List
44 \end{code}
45
46
47 %************************************************************************
48 %*                                                                      *
49 \subsection[OccurAnal-main]{Counting occurrences: main function}
50 %*                                                                      *
51 %************************************************************************
52
53 Here's the externally-callable interface:
54
55 \begin{code}
56 occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
57                 -> [CoreBind] -> [CoreBind]
58 occurAnalysePgm active_rule imp_rules binds
59   = snd (go (initOccEnv active_rule imp_rules) binds)
60   where
61     initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)
62     -- The RULES keep things alive!
63
64     go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
65     go _ []
66         = (initial_uds, [])
67     go env (bind:binds)
68         = (final_usage, bind' ++ binds')
69         where
70            (bs_usage, binds')   = go env binds
71            (final_usage, bind') = occAnalBind env env bind bs_usage
72
73 occurAnalyseExpr :: CoreExpr -> CoreExpr
74         -- Do occurrence analysis, and discard occurence info returned
75 occurAnalyseExpr expr 
76   = snd (occAnal (initOccEnv all_active_rules []) expr)
77   where
78     -- To be conservative, we say that all inlines and rules are active
79     all_active_rules = Just (\_ -> True)
80 \end{code}
81
82
83 %************************************************************************
84 %*                                                                      *
85 \subsection[OccurAnal-main]{Counting occurrences: main function}
86 %*                                                                      *
87 %************************************************************************
88
89 Bindings
90 ~~~~~~~~
91
92 \begin{code}
93 occAnalBind :: OccEnv           -- The incoming OccEnv
94             -> OccEnv           -- Same, but trimmed by (binderOf bind)
95             -> CoreBind
96             -> UsageDetails             -- Usage details of scope
97             -> (UsageDetails,           -- Of the whole let(rec)
98                 [CoreBind])
99
100 occAnalBind env _ (NonRec binder rhs) body_usage
101   | isTyVar binder      -- A type let; we don't gather usage info
102   = (body_usage, [NonRec binder rhs])
103
104   | isCoVar binder       -- A coercion let; again no usage info
105                          -- We trust that it'll get inlined away
106                          -- as soon as it takes form (cv = Coercion co)
107   = (body_usage, [NonRec binder rhs])
108
109   | not (binder `usedIn` body_usage)    -- It's not mentioned
110   = (body_usage, [])
111
112   | otherwise                   -- It's mentioned in the body
113   = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs'])
114   where
115     (body_usage', tagged_binder) = tagBinder body_usage binder
116     (rhs_usage1, rhs')           = occAnalRhs env (Just tagged_binder) rhs
117     rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder)
118     rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder)
119        -- See Note [Rules are extra RHSs] and Note [Rule dependency info]
120 \end{code}
121
122 Note [Dead code]
123 ~~~~~~~~~~~~~~~~
124 Dropping dead code for recursive bindings is done in a very simple way:
125
126         the entire set of bindings is dropped if none of its binders are
127         mentioned in its body; otherwise none are.
128
129 This seems to miss an obvious improvement.
130
131         letrec  f = ...g...
132                 g = ...f...
133         in
134         ...g...
135 ===>
136         letrec f = ...g...
137                g = ...(...g...)...
138         in
139         ...g...
140
141 Now 'f' is unused! But it's OK!  Dependency analysis will sort this
142 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
143 dropped.  It isn't easy to do a perfect job in one blow.  Consider
144
145         letrec f = ...g...
146                g = ...h...
147                h = ...k...
148                k = ...m...
149                m = ...m...
150         in
151         ...m...
152
153
154 Note [Loop breaking and RULES]
155 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 Loop breaking is surprisingly subtle.  First read the section 4 of
157 "Secrets of the GHC inliner".  This describes our basic plan.
158
159 However things are made quite a bit more complicated by RULES.  Remember
160
161   * Note [Rules are extra RHSs]
162     ~~~~~~~~~~~~~~~~~~~~~~~~~~~
163     A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
164     keeps the specialised "children" alive.  If the parent dies
165     (because it isn't referenced any more), then the children will die
166     too (unless they are already referenced directly).
167
168     To that end, we build a Rec group for each cyclic strongly
169     connected component,
170         *treating f's rules as extra RHSs for 'f'*.
171     More concretely, the SCC analysis runs on a graph with an edge
172     from f -> g iff g is mentioned in
173         (a) f's rhs
174         (b) f's RULES
175     These are rec_edges.
176
177     Under (b) we include variables free in *either* LHS *or* RHS of
178     the rule.  The former might seems silly, but see Note [Rule
179     dependency info].  So in Example [eftInt], eftInt and eftIntFB
180     will be put in the same Rec, even though their 'main' RHSs are
181     both non-recursive.
182
183   * Note [Rules are visible in their own rec group]
184     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
185     We want the rules for 'f' to be visible in f's right-hand side.
186     And we'd like them to be visible in other functions in f's Rec
187     group.  E.g. in Example [Specialisation rules] we want f' rule
188     to be visible in both f's RHS, and fs's RHS.
189
190     This means that we must simplify the RULEs first, before looking
191     at any of the definitions.  This is done by Simplify.simplRecBind,
192     when it calls addLetIdInfo.
193
194   * Note [Choosing loop breakers]
195     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
196     We avoid infinite inlinings by choosing loop breakers, and
197     ensuring that a loop breaker cuts each loop.  But what is a
198     "loop"?  In particular, a RULE is like an equation for 'f' that
199     is *always* inlined if it is applicable.  We do *not* disable
200     rules for loop-breakers.  It's up to whoever makes the rules to
201     make sure that the rules themselves always terminate.  See Note
202     [Rules for recursive functions] in Simplify.lhs
203
204     Hence, if
205         f's RHS (or its INLINE template if it has one) mentions g, and
206         g has a RULE that mentions h, and
207         h has a RULE that mentions f
208
209     then we *must* choose f to be a loop breaker.  In general, take the
210     free variables of f's RHS, and augment it with all the variables
211     reachable by RULES from those starting points.  That is the whole
212     reason for computing rule_fv_env in occAnalBind.  (Of course we
213     only consider free vars that are also binders in this Rec group.)
214     See also Note [Finding rule RHS free vars]
215
216     Note that when we compute this rule_fv_env, we only consider variables
217     free in the *RHS* of the rule, in contrast to the way we build the
218     Rec group in the first place (Note [Rule dependency info])
219
220     Note that if 'g' has RHS that mentions 'w', we should add w to
221     g's loop-breaker edges.  More concretely there is an edge from f -> g 
222     iff
223         (a) g is mentioned in f's RHS
224         (b) h is mentioned in f's RHS, and 
225             g appears in the RHS of a RULE of h
226             or a transitive sequence of rules starting with h
227
228     Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
229     chosen as a loop breaker, because their RHSs don't mention each other.
230     And indeed both can be inlined safely.
231
232     Note that the edges of the graph we use for computing loop breakers
233     are not the same as the edges we use for computing the Rec blocks.
234     That's why we compute
235         rec_edges          for the Rec block analysis
236         loop_breaker_edges for the loop breaker analysis
237
238   * Note [Finding rule RHS free vars]
239     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
240     Consider this real example from Data Parallel Haskell
241          tagZero :: Array Int -> Array Tag
242          {-# INLINE [1] tagZeroes #-}
243          tagZero xs = pmap (\x -> fromBool (x==0)) xs
244
245          {-# RULES "tagZero" [~1] forall xs n.
246              pmap fromBool <blah blah> = tagZero xs #-}     
247     So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.
248     However, tagZero can only be inlined in phase 1 and later, while
249     the RULE is only active *before* phase 1.  So there's no problem.
250
251     To make this work, we look for the RHS free vars only for
252     *active* rules.  That's the reason for the is_active argument
253     to idRhsRuleVars, and the occ_rule_act field of the OccEnv.
254  
255   * Note [Weak loop breakers]
256     ~~~~~~~~~~~~~~~~~~~~~~~~~
257     There is a last nasty wrinkle.  Suppose we have
258
259         Rec { f = f_rhs
260               RULE f [] = g
261
262               h = h_rhs
263               g = h
264               ...more...
265         }
266
267     Remember that we simplify the RULES before any RHS (see Note
268     [Rules are visible in their own rec group] above).
269
270     So we must *not* postInlineUnconditionally 'g', even though
271     its RHS turns out to be trivial.  (I'm assuming that 'g' is
272     not choosen as a loop breaker.)  Why not?  Because then we
273     drop the binding for 'g', which leaves it out of scope in the
274     RULE!
275
276     We "solve" this by making g a "weak" or "rules-only" loop breaker,
277     with OccInfo = IAmLoopBreaker True.  A normal "strong" loop breaker
278     has IAmLoopBreaker False.  So
279
280                                 Inline  postInlineUnconditionally
281         IAmLoopBreaker False    no      no
282         IAmLoopBreaker True     yes     no
283         other                   yes     yes
284
285     The **sole** reason for this kind of loop breaker is so that
286     postInlineUnconditionally does not fire.  Ugh.
287
288   * Note [Rule dependency info]
289     ~~~~~~~~~~~~~~~~~~~~~~~~~~~
290     The VarSet in a SpecInfo is used for dependency analysis in the
291     occurrence analyser.  We must track free vars in *both* lhs and rhs.  
292     Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
293     Why both? Consider
294         x = y
295         RULE f x = 4
296     Then if we substitute y for x, we'd better do so in the
297     rule's LHS too, so we'd better ensure the dependency is respected
298
299
300   * Note [Inline rules]
301     ~~~~~~~~~~~~~~~~~~~
302     None of the above stuff about RULES applies to Inline Rules,
303     stored in a CoreUnfolding.  The unfolding, if any, is simplified
304     at the same time as the regular RHS of the function, so it should
305     be treated *exactly* like an extra RHS.
306
307     There is a danger that we'll be sub-optimal if we see this
308          f = ...f...
309          [INLINE f = ..no f...]
310     where f is recursive, but the INLINE is not. This can just about
311     happen with a sufficiently odd set of rules; eg
312
313         foo :: Int -> Int
314         {-# INLINE [1] foo #-}
315         foo x = x+1
316
317         bar :: Int -> Int
318         {-# INLINE [1] bar #-}
319         bar x = foo x + 1
320
321         {-# RULES "foo" [~1] forall x. foo x = bar x #-}
322
323     Here the RULE makes bar recursive; but it's INLINE pragma remains
324     non-recursive. It's tempting to then say that 'bar' should not be
325     a loop breaker, but an attempt to do so goes wrong in two ways:
326        a) We may get
327              $df = ...$cfoo...
328              $cfoo = ...$df....
329              [INLINE $cfoo = ...no-$df...]
330           But we want $cfoo to depend on $df explicitly so that we
331           put the bindings in the right order to inline $df in $cfoo
332           and perhaps break the loop altogether.  (Maybe this
333        b)
334
335
336
337 Example [eftInt]
338 ~~~~~~~~~~~~~~~
339 Example (from GHC.Enum):
340
341   eftInt :: Int# -> Int# -> [Int]
342   eftInt x y = ...(non-recursive)...
343
344   {-# INLINE [0] eftIntFB #-}
345   eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
346   eftIntFB c n x y = ...(non-recursive)...
347
348   {-# RULES
349   "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
350   "eftIntList"  [1] eftIntFB  (:) [] = eftInt
351    #-}
352
353 Example [Specialisation rules]
354 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
355 Consider this group, which is typical of what SpecConstr builds:
356
357    fs a = ....f (C a)....
358    f  x = ....f (C a)....
359    {-# RULE f (C a) = fs a #-}
360
361 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
362
363 But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
364         - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
365         - fs is inlined (say it's small)
366         - now there's another opportunity to apply the RULE
367
368 This showed up when compiling Control.Concurrent.Chan.getChanContents.
369
370
371 \begin{code}
372 occAnalBind _ env (Rec pairs) body_usage
373   = foldr (occAnalRec env) (body_usage, []) sccs
374         -- For a recursive group, we 
375         --      * occ-analyse all the RHSs
376         --      * compute strongly-connected components
377         --      * feed those components to occAnalRec
378   where
379     -------------Dependency analysis ------------------------------
380     bndr_set = mkVarSet (map fst pairs)
381
382     sccs :: [SCC (Node Details)]
383     sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges
384
385     rec_edges :: [Node Details]
386     rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
387     
388     make_node (bndr, rhs)
389         = (details, varUnique bndr, keysUFM out_edges)
390         where
391           details = ND { nd_bndr = bndr, nd_rhs = rhs'
392                        , nd_uds = rhs_usage3, nd_inl = inl_fvs}
393
394           (rhs_usage1, rhs') = occAnalRhs env Nothing rhs
395           rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs]
396           rhs_usage3 = addIdOccs rhs_usage2 unf_fvs
397           unf        = realIdUnfolding bndr     -- Ignore any current loop-breaker flag
398           unf_fvs    = stableUnfoldingVars unf
399           rule_fvs   = idRuleVars bndr          -- See Note [Rule dependency info]
400
401           inl_fvs   = rhs_fvs `unionVarSet` unf_fvs
402           rhs_fvs   = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1
403           out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3
404         -- (a -> b) means a mentions b
405         -- Given the usage details (a UFM that gives occ info for each free var of
406         -- the RHS) we can get the list of free vars -- or rather their Int keys --
407         -- by just extracting the keys from the finite map.  Grimy, but fast.
408         -- Previously we had this:
409         --      [ bndr | bndr <- bndrs,
410         --               maybeToBool (lookupVarEnv rhs_usage bndr)]
411         -- which has n**2 cost, and this meant that edges_from alone
412         -- consumed 10% of total runtime!
413
414 -----------------------------
415 occAnalRec :: OccEnv -> SCC (Node Details)
416            -> (UsageDetails, [CoreBind])
417            -> (UsageDetails, [CoreBind])
418
419         -- The NonRec case is just like a Let (NonRec ...) above
420 occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _))
421              (body_usage, binds)
422   | not (bndr `usedIn` body_usage) 
423   = (body_usage, binds)
424
425   | otherwise                   -- It's mentioned in the body
426   = (body_usage' +++ rhs_usage, 
427      NonRec tagged_bndr rhs : binds)
428   where
429     (body_usage', tagged_bndr) = tagBinder body_usage bndr
430
431
432         -- The Rec case is the interesting one
433         -- See Note [Loop breaking]
434 occAnalRec env (CyclicSCC nodes) (body_usage, binds)
435   | not (any (`usedIn` body_usage) bndrs)       -- NB: look at body_usage, not total_usage
436   = (body_usage, binds)                         -- Dead code
437
438   | otherwise   -- At this point we always build a single Rec
439   = (final_usage, Rec pairs : binds)
440
441   where
442     bndrs    = [b | (ND { nd_bndr = b }, _, _) <- nodes]
443     bndr_set = mkVarSet bndrs
444     non_boring bndr = isId bndr &&
445                       (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr)
446
447         ----------------------------
448         -- Tag the binders with their occurrence info
449     total_usage = foldl add_usage body_usage nodes
450     add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage
451     (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
452
453     tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
454         -- (a) Tag the binders in the details with occ info
455         -- (b) Mark the binder with "weak loop-breaker" OccInfo 
456         --      saying "no preInlineUnconditionally" if it is used
457         --      in any rule (lhs or rhs) of the recursive group
458         --      See Note [Weak loop breakers]
459     tag_node usage (details@ND { nd_bndr = bndr }, k, ks)
460       = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks))
461       where
462         bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
463               | otherwise                      = bndr1
464         bndr1 = setBinderOcc usage bndr
465     all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) 
466                                                     emptyVarSet bndrs
467
468         ----------------------------
469         -- Now reconstruct the cycle
470     pairs | any non_boring bndrs
471           = foldr (reOrderRec 0) [] $
472             stronglyConnCompFromEdgedVerticesR loop_breaker_edges
473           | otherwise
474           = reOrderCycle 0 tagged_nodes []
475
476         -- See Note [Choosing loop breakers] for loop_breaker_edges
477     loop_breaker_edges = map mk_node tagged_nodes
478     mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks)
479         where
480           new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs))
481
482     ------------------------------------
483     rule_fv_env :: IdEnv IdSet  -- Variables from this group mentioned in RHS of rules
484                                 -- Domain is *subset* of bound vars (others have no rule fvs)
485     rule_fv_env = transClosureFV init_rule_fvs
486     init_rule_fvs
487       | Just is_active <- occ_rule_act env  -- See Note [Finding rule RHS free vars]
488       = [ (b, rule_fvs)
489         | b <- bndrs
490         , isId b
491         , let rule_fvs = idRuleRhsVars is_active b
492                          `intersectVarSet` bndr_set
493         , not (isEmptyVarSet rule_fvs)]
494       | otherwise 
495       = []
496 \end{code}
497
498 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
499 strongly connected component (there's guaranteed to be a cycle).  It returns the
500 same pairs, but
501         a) in a better order,
502         b) with some of the Ids having a IAmALoopBreaker pragma
503
504 The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means
505 that the simplifier can guarantee not to loop provided it never records an inlining
506 for these no-inline guys.
507
508 Furthermore, the order of the binds is such that if we neglect dependencies
509 on the no-inline Ids then the binds are topologically sorted.  This means
510 that the simplifier will generally do a good job if it works from top bottom,
511 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
512
513 ==============
514 [June 98: I don't understand the following paragraphs, and I've
515           changed the a=b case again so that it isn't a special case any more.]
516
517 Here's a case that bit me:
518
519         letrec
520                 a = b
521                 b = \x. BIG
522         in
523         ...a...a...a....
524
525 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
526
527 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
528 Perhaps something cleverer would suffice.
529 ===============
530
531
532 \begin{code}
533 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
534                                                 -- which is gotten from the Id.
535 data Details
536   = ND { nd_bndr :: Id          -- Binder
537        , nd_rhs  :: CoreExpr    -- RHS
538
539        , nd_uds  :: UsageDetails  -- Usage from RHS,
540                                   -- including RULES and InlineRule unfolding
541
542        , nd_inl  :: IdSet       -- Other binders *from this Rec group* mentioned in
543        }                        --   its InlineRule unfolding (if present)
544                                 --   AND the  RHS
545                                 -- but *excluding* any RULES
546                                 -- This is the IdSet that may be used if the Id is inlined
547
548 reOrderRec :: Int -> SCC (Node Details)
549            -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
550 -- Sorted into a plausible order.  Enough of the Ids have
551 --      IAmALoopBreaker pragmas that there are no loops left.
552 reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _))
553                                    pairs = (bndr, rhs) : pairs
554 reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs
555
556 reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
557 reOrderCycle _ [] _
558   = panic "reOrderCycle"
559 reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs
560   =    -- Common case of simple self-recursion
561     (makeLoopBreaker False bndr, rhs) : pairs
562
563 reOrderCycle depth (bind : binds) pairs
564   =     -- Choose a loop breaker, mark it no-inline,
565         -- do SCC analysis on the rest, and recursively sort them out
566 --    pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $
567     foldr (reOrderRec new_depth)
568           ([ (makeLoopBreaker False bndr, rhs) 
569            | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs)
570           (stronglyConnCompFromEdgedVerticesR unchosen) 
571   where
572     (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds
573
574     approximate_loop_breaker = depth >= 2
575     new_depth | approximate_loop_breaker = 0
576               | otherwise                = depth+1
577         -- After two iterations (d=0, d=1) give up
578         -- and approximate, returning to d=0
579
580         -- This loop looks for the bind with the lowest score
581         -- to pick as the loop  breaker.  The rest accumulate in
582     choose_loop_breaker loop_binds _loop_sc acc []
583         = (loop_binds, acc)        -- Done
584
585         -- If approximate_loop_breaker is True, we pick *all*
586         -- nodes with lowest score, else just one
587         -- See Note [Complexity of loop breaking]
588     choose_loop_breaker loop_binds loop_sc acc (bind : binds)
589         | sc < loop_sc  -- Lower score so pick this new one
590         = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds
591
592         | approximate_loop_breaker && sc == loop_sc
593         = choose_loop_breaker (bind : loop_binds) loop_sc acc binds
594         
595         | otherwise     -- Higher score so don't pick it
596         = choose_loop_breaker loop_binds loop_sc (bind : acc) binds
597         where
598           sc = score bind
599
600     score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker
601     score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)
602         | not (isId bndr) = 100     -- A type or cercion variable is never a loop breaker
603
604         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
605                               -- Note [DFuns should not be loop breakers]
606
607         | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
608         = case inl_source of
609              InlineWrapper {} -> 10  -- Note [INLINE pragmas]
610              _other           ->  3  -- Data structures are more important than this
611                                      -- so that dictionary/method recursion unravels
612                 -- Note that this case hits all InlineRule things, so we
613                 -- never look at 'rhs for InlineRule stuff. That's right, because
614                 -- 'rhs' is irrelevant for inlining things with an InlineRule
615                 
616         | is_con_app rhs = 5  -- Data types help with cases: Note [Constructor applications]
617                 
618         | exprIsTrivial rhs = 10  -- Practically certain to be inlined
619                 -- Used to have also: && not (isExportedId bndr)
620                 -- But I found this sometimes cost an extra iteration when we have
621                 --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }
622                 -- where df is the exported dictionary. Then df makes a really
623                 -- bad choice for loop breaker
624
625         
626 -- If an Id is marked "never inline" then it makes a great loop breaker
627 -- The only reason for not checking that here is that it is rare
628 -- and I've never seen a situation where it makes a difference,
629 -- so it probably isn't worth the time to test on every binder
630 --      | isNeverActive (idInlinePragma bndr) = -10
631
632         | isOneOcc (idOccInfo bndr) = 2  -- Likely to be inlined
633
634         | canUnfold (realIdUnfolding bndr) = 1
635                 -- The Id has some kind of unfolding
636                 -- Ignore loop-breaker-ness here because that is what we are setting!
637
638         | otherwise = 0
639
640         -- Checking for a constructor application
641         -- Cheap and cheerful; the simplifer moves casts out of the way
642         -- The lambda case is important to spot x = /\a. C (f a)
643         -- which comes up when C is a dictionary constructor and
644         -- f is a default method.
645         -- Example: the instance for Show (ST s a) in GHC.ST
646         --
647         -- However we *also* treat (\x. C p q) as a con-app-like thing,
648         --      Note [Closure conversion]
649     is_con_app (Var v)    = isConLikeId v
650     is_con_app (App f _)  = is_con_app f
651     is_con_app (Lam _ e)  = is_con_app e
652     is_con_app (Note _ e) = is_con_app e
653     is_con_app _          = False
654
655 makeLoopBreaker :: Bool -> Id -> Id
656 -- Set the loop-breaker flag: see Note [Weak loop breakers]
657 makeLoopBreaker weak bndr 
658   = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak)
659 \end{code}
660
661 Note [Complexity of loop breaking]
662 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
663 The loop-breaking algorithm knocks out one binder at a time, and 
664 performs a new SCC analysis on the remaining binders.  That can
665 behave very badly in tightly-coupled groups of bindings; in the
666 worst case it can be (N**2)*log N, because it does a full SCC
667 on N, then N-1, then N-2 and so on.
668
669 To avoid this, we switch plans after 2 (or whatever) attempts:
670   Plan A: pick one binder with the lowest score, make it
671           a loop breaker, and try again
672   Plan B: pick *all* binders with the lowest score, make them
673           all loop breakers, and try again 
674 Since there are only a small finite number of scores, this will
675 terminate in a constant number of iterations, rather than O(N)
676 iterations.
677
678 You might thing that it's very unlikely, but RULES make it much
679 more likely.  Here's a real example from Trac #1969:
680   Rec { $dm = \d.\x. op d
681         {-# RULES forall d. $dm Int d  = $s$dm1
682                   forall d. $dm Bool d = $s$dm2 #-}
683         
684         dInt = MkD .... opInt ...
685         dInt = MkD .... opBool ...
686         opInt  = $dm dInt
687         opBool = $dm dBool
688
689         $s$dm1 = \x. op dInt
690         $s$dm2 = \x. op dBool }
691 The RULES stuff means that we can't choose $dm as a loop breaker
692 (Note [Choosing loop breakers]), so we must choose at least (say)
693 opInt *and* opBool, and so on.  The number of loop breakders is
694 linear in the number of instance declarations.
695
696 Note [INLINE pragmas]
697 ~~~~~~~~~~~~~~~~~~~~~
698 Avoid choosing a function with an INLINE pramga as the loop breaker!  
699 If such a function is mutually-recursive with a non-INLINE thing,
700 then the latter should be the loop-breaker.
701
702 Usually this is just a question of optimisation. But a particularly
703 bad case is wrappers generated by the demand analyser: if you make
704 then into a loop breaker you may get an infinite inlining loop.  For
705 example:
706   rec {
707         $wfoo x = ....foo x....
708
709         {-loop brk-} foo x = ...$wfoo x...
710   }
711 The interface file sees the unfolding for $wfoo, and sees that foo is
712 strict (and hence it gets an auto-generated wrapper).  Result: an
713 infinite inlining in the importing scope.  So be a bit careful if you
714 change this.  A good example is Tree.repTree in
715 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
716 breaker then compiling Game.hs goes into an infinite loop.  This
717 happened when we gave is_con_app a lower score than inline candidates:
718
719   Tree.repTree
720     = __inline_me (/\a. \w w1 w2 -> 
721                    case Tree.$wrepTree @ a w w1 w2 of
722                     { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
723   Tree.$wrepTree
724     = /\a w w1 w2 -> 
725       (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
726
727 Here we do *not* want to choose 'repTree' as the loop breaker.
728
729 Note [DFuns should not be loop breakers]
730 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
731 It's particularly bad to make a DFun into a loop breaker.  See
732 Note [How instance declarations are translated] in TcInstDcls
733
734 We give DFuns a higher score than ordinary CONLIKE things because 
735 if there's a choice we want the DFun to be the non-looop breker. Eg
736  
737 rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)
738
739       $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)
740       {-# DFUN #-}
741       $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)
742     }
743
744 Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it
745 if we can't unravel the DFun first.
746
747 Note [Constructor applications]
748 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
749 It's really really important to inline dictionaries.  Real
750 example (the Enum Ordering instance from GHC.Base):
751
752      rec     f = \ x -> case d of (p,q,r) -> p x
753              g = \ x -> case d of (p,q,r) -> q x
754              d = (v, f, g)
755
756 Here, f and g occur just once; but we can't inline them into d.
757 On the other hand we *could* simplify those case expressions if
758 we didn't stupidly choose d as the loop breaker.
759 But we won't because constructor args are marked "Many".
760 Inlining dictionaries is really essential to unravelling
761 the loops in static numeric dictionaries, see GHC.Float.
762
763 Note [Closure conversion]
764 ~~~~~~~~~~~~~~~~~~~~~~~~~
765 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
766 The immediate motivation came from the result of a closure-conversion transformation
767 which generated code like this:
768
769     data Clo a b = forall c. Clo (c -> a -> b) c
770
771     ($:) :: Clo a b -> a -> b
772     Clo f env $: x = f env x
773
774     rec { plus = Clo plus1 ()
775
776         ; plus1 _ n = Clo plus2 n
777
778         ; plus2 Zero     n = n
779         ; plus2 (Succ m) n = Succ (plus $: m $: n) }
780
781 If we inline 'plus' and 'plus1', everything unravels nicely.  But if
782 we choose 'plus1' as the loop breaker (which is entirely possible
783 otherwise), the loop does not unravel nicely.
784
785
786 @occAnalRhs@ deals with the question of bindings where the Id is marked
787 by an INLINE pragma.  For these we record that anything which occurs
788 in its RHS occurs many times.  This pessimistically assumes that ths
789 inlined binder also occurs many times in its scope, but if it doesn't
790 we'll catch it next time round.  At worst this costs an extra simplifier pass.
791 ToDo: try using the occurrence info for the inline'd binder.
792
793 [March 97] We do the same for atomic RHSs.  Reason: see notes with reOrderRec.
794 [June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with reOrderRec.
795
796
797 \begin{code}
798 occAnalRhs :: OccEnv
799            -> Maybe Id -> CoreExpr    -- Binder and rhs
800                  -- Just b  => non-rec, and alrady tagged with occurrence info
801                  -- Nothing => Rec, no occ info
802            -> (UsageDetails, CoreExpr)
803               -- Returned usage details covers only the RHS,
804               -- and *not* the RULE or INLINE template for the Id
805 occAnalRhs env mb_bndr rhs
806   = occAnal ctxt rhs
807   where
808     -- See Note [Cascading inlines]
809     ctxt = case mb_bndr of
810              Just b | certainly_inline b -> env
811              _other                      -> rhsCtxt env
812
813     certainly_inline bndr  -- See Note [Cascading inlines]
814       = case idOccInfo bndr of
815           OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable
816           _                      -> False
817       where
818         active     = isAlwaysActive (idInlineActivation bndr)
819         not_stable = not (isStableUnfolding (idUnfolding bndr))
820
821 addIdOccs :: UsageDetails -> VarSet -> UsageDetails
822 addIdOccs usage id_set = foldVarSet add usage id_set
823   where
824     add v u | isId v    = addOneOcc u v NoOccInfo
825             | otherwise = u
826         -- Give a non-committal binder info (i.e NoOccInfo) because
827         --   a) Many copies of the specialised thing can appear
828         --   b) We don't want to substitute a BIG expression inside a RULE
829         --      even if that's the only occurrence of the thing
830         --      (Same goes for INLINE.)
831 \end{code}
832
833 Note [Cascading inlines]
834 ~~~~~~~~~~~~~~~~~~~~~~~~
835 By default we use an rhsCtxt for the RHS of a binding.  This tells the
836 occ anal n that it's looking at an RHS, which has an effect in
837 occAnalApp.  In particular, for constructor applications, it makes
838 the arguments appear to have NoOccInfo, so that we don't inline into
839 them. Thus    x = f y
840               k = Just x
841 we do not want to inline x.
842
843 But there's a problem.  Consider
844      x1 = a0 : []
845      x2 = a1 : x1
846      x3 = a2 : x2
847      g  = f x3
848 First time round, it looks as if x1 and x2 occur as an arg of a
849 let-bound constructor ==> give them a many-occurrence.
850 But then x3 is inlined (unconditionally as it happens) and
851 next time round, x2 will be, and the next time round x1 will be
852 Result: multiple simplifier iterations.  Sigh.
853
854 So, when analysing the RHS of x3 we notice that x3 will itself
855 definitely inline the next time round, and so we analyse x3's rhs in
856 an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.
857
858 Annoyingly, we have to approximiate SimplUtils.preInlineUnconditionally.
859 If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates
860 indefinitely:
861         x = f y
862         k = Just x
863 inline ==>
864         k = Just (f y)
865 float ==>
866         x1 = f y
867         k = Just x1
868
869 This is worse than the slow cascade, so we only want to say "certainly_inline"
870 if it really is certain.  Look at the note with preInlineUnconditionally
871 for the various clauses.
872
873 Expressions
874 ~~~~~~~~~~~
875 \begin{code}
876 occAnal :: OccEnv
877         -> CoreExpr
878         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
879             CoreExpr)
880
881 occAnal _   expr@(Type _) = (emptyDetails,         expr)
882 occAnal _   expr@(Lit _)  = (emptyDetails,         expr)   
883 occAnal env expr@(Var v)  = (mkOneOcc env v False, expr)
884     -- At one stage, I gathered the idRuleVars for v here too,
885     -- which in a way is the right thing to do.
886     -- But that went wrong right after specialisation, when
887     -- the *occurrences* of the overloaded function didn't have any
888     -- rules in them, so the *specialised* versions looked as if they
889     -- weren't used at all.
890
891 occAnal _ (Coercion co) 
892   = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
893         -- See Note [Gather occurrences of coercion veriables]
894 \end{code}
895
896 Note [Gather occurrences of coercion veriables]
897 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
898 We need to gather info about what coercion variables appear, so that
899 we can sort them into the right place when doing dependency analysis.
900
901 \begin{code}
902 \end{code}
903
904 \begin{code}
905 occAnal env (Note note@(SCC _) body)
906   = case occAnal env body of { (usage, body') ->
907     (mapVarEnv markInsideSCC usage, Note note body')
908     }
909
910 occAnal env (Note note body)
911   = case occAnal env body of { (usage, body') ->
912     (usage, Note note body')
913     }
914
915 occAnal env (Cast expr co)
916   = case occAnal env expr of { (usage, expr') ->
917     let usage1 = markManyIf (isRhsEnv env) usage
918         usage2 = addIdOccs usage1 (coVarsOfCo co)
919           -- See Note [Gather occurrences of coercion veriables]
920     in (usage2, Cast expr' co)
921         -- If we see let x = y `cast` co
922         -- then mark y as 'Many' so that we don't
923         -- immediately inline y again.
924     }
925 \end{code}
926
927 \begin{code}
928 occAnal env app@(App _ _)
929   = occAnalApp env (collectArgs app)
930
931 -- Ignore type variables altogether
932 --   (a) occurrences inside type lambdas only not marked as InsideLam
933 --   (b) type variables not in environment
934
935 occAnal env (Lam x body) | isTyVar x
936   = case occAnal env body of { (body_usage, body') ->
937     (body_usage, Lam x body')
938     }
939
940 -- For value lambdas we do a special hack.  Consider
941 --      (\x. \y. ...x...)
942 -- If we did nothing, x is used inside the \y, so would be marked
943 -- as dangerous to dup.  But in the common case where the abstraction
944 -- is applied to two arguments this is over-pessimistic.
945 -- So instead, we just mark each binder with its occurrence
946 -- info in the *body* of the multiple lambda.
947 -- Then, the simplifier is careful when partially applying lambdas.
948
949 occAnal env expr@(Lam _ _)
950   = case occAnal env_body body of { (body_usage, body') ->
951     let
952         (final_usage, tagged_binders) = tagLamBinders body_usage binders'
953                       -- Use binders' to put one-shot info on the lambdas
954
955         --      URGH!  Sept 99: we don't seem to be able to use binders' here, because
956         --      we get linear-typed things in the resulting program that we can't handle yet.
957         --      (e.g. PrelShow)  TODO
958
959         really_final_usage = if linear then
960                                 final_usage
961                              else
962                                 mapVarEnv markInsideLam final_usage
963     in
964     (really_final_usage,
965      mkLams tagged_binders body') }
966   where
967     env_body        = vanillaCtxt (trimOccEnv env binders)
968                         -- Body is (no longer) an RhsContext
969     (binders, body) = collectBinders expr
970     binders'        = oneShotGroup env binders
971     linear          = all is_one_shot binders'
972     is_one_shot b   = isId b && isOneShotBndr b
973
974 occAnal env (Case scrut bndr ty alts)
975   = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->
976     case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
977     let
978         alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
979         (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
980         total_usage = scrut_usage +++ alts_usage1
981     in
982     total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
983   where
984         -- Note [Case binder usage]     
985         -- ~~~~~~~~~~~~~~~~~~~~~~~~
986         -- The case binder gets a usage of either "many" or "dead", never "one".
987         -- Reason: we like to inline single occurrences, to eliminate a binding,
988         -- but inlining a case binder *doesn't* eliminate a binding.
989         -- We *don't* want to transform
990         --      case x of w { (p,q) -> f w }
991         -- into
992         --      case x of w { (p,q) -> f (p,q) }
993     tag_case_bndr usage bndr
994       = case lookupVarEnv usage bndr of
995           Nothing -> (usage,                  setIdOccInfo bndr IAmDead)
996           Just _  -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)
997
998     alt_env      = mkAltEnv env scrut bndr
999     occ_anal_alt = occAnalAlt alt_env bndr
1000
1001     occ_anal_scrut (Var v) (alt1 : other_alts)
1002         | not (null other_alts) || not (isDefaultAlt alt1)
1003         = (mkOneOcc env v True, Var v)  -- The 'True' says that the variable occurs
1004                                         -- in an interesting context; the case has
1005                                         -- at least one non-default alternative
1006     occ_anal_scrut scrut _alts  
1007         = occAnal (vanillaCtxt env) scrut    -- No need for rhsCtxt
1008
1009 occAnal env (Let bind body)
1010   = case occAnal env_body body                    of { (body_usage, body') ->
1011     case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) ->
1012        (final_usage, mkLets new_binds body') }}
1013   where
1014     env_body = trimOccEnv env (bindersOf bind)
1015
1016 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
1017 occAnalArgs env args
1018   = case mapAndUnzip (occAnal arg_env) args of  { (arg_uds_s, args') ->
1019     (foldr (+++) emptyDetails arg_uds_s, args')}
1020   where
1021     arg_env = vanillaCtxt env
1022 \end{code}
1023
1024 Applications are dealt with specially because we want
1025 the "build hack" to work.
1026
1027 Note [Arguments of let-bound constructors]
1028 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1029 Consider
1030     f x = let y = expensive x in
1031           let z = (True,y) in
1032           (case z of {(p,q)->q}, case z of {(p,q)->q})
1033 We feel free to duplicate the WHNF (True,y), but that means
1034 that y may be duplicated thereby.
1035
1036 If we aren't careful we duplicate the (expensive x) call!
1037 Constructors are rather like lambdas in this way.
1038
1039 \begin{code}
1040 occAnalApp :: OccEnv
1041            -> (Expr CoreBndr, [Arg CoreBndr])
1042            -> (UsageDetails, Expr CoreBndr)
1043 occAnalApp env (Var fun, args)
1044   = case args_stuff of { (args_uds, args') ->
1045     let
1046        final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
1047           -- We mark the free vars of the argument of a constructor or PAP
1048           -- as "many", if it is the RHS of a let(rec).
1049           -- This means that nothing gets inlined into a constructor argument
1050           -- position, which is what we want.  Typically those constructor
1051           -- arguments are just variables, or trivial expressions.
1052           --
1053           -- This is the *whole point* of the isRhsEnv predicate
1054           -- See Note [Arguments of let-bound constructors]
1055     in
1056     (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
1057   where
1058     fun_uniq = idUnique fun
1059     fun_uds  = mkOneOcc env fun (valArgCount args > 0)
1060     is_exp = isExpandableApp fun (valArgCount args)
1061            -- See Note [CONLIKE pragma] in BasicTypes
1062            -- The definition of is_exp should match that in
1063            -- Simplify.prepareRhs
1064
1065                 -- Hack for build, fold, runST
1066     args_stuff  | fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
1067                 | fun_uniq == augmentIdKey  = appSpecial env 2 [True,True]  args
1068                 | fun_uniq == foldrIdKey    = appSpecial env 3 [False,True] args
1069                 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True]       args
1070                         -- (foldr k z xs) may call k many times, but it never
1071                         -- shares a partial application of k; hence [False,True]
1072                         -- This means we can optimise
1073                         --      foldr (\x -> let v = ...x... in \y -> ...v...) z xs
1074                         -- by floating in the v
1075
1076                 | otherwise = occAnalArgs env args
1077
1078
1079 occAnalApp env (fun, args)
1080   = case occAnal (addAppCtxt env args) fun of   { (fun_uds, fun') ->
1081         -- The addAppCtxt is a bit cunning.  One iteration of the simplifier
1082         -- often leaves behind beta redexs like
1083         --      (\x y -> e) a1 a2
1084         -- Here we would like to mark x,y as one-shot, and treat the whole
1085         -- thing much like a let.  We do this by pushing some True items
1086         -- onto the context stack.
1087
1088     case occAnalArgs env args of        { (args_uds, args') ->
1089     let
1090         final_uds = fun_uds +++ args_uds
1091     in
1092     (final_uds, mkApps fun' args') }}
1093
1094
1095 markManyIf :: Bool              -- If this is true
1096            -> UsageDetails      -- Then do markMany on this
1097            -> UsageDetails
1098 markManyIf True  uds = mapVarEnv markMany uds
1099 markManyIf False uds = uds
1100
1101 appSpecial :: OccEnv
1102            -> Int -> CtxtTy     -- Argument number, and context to use for it
1103            -> [CoreExpr]
1104            -> (UsageDetails, [CoreExpr])
1105 appSpecial env n ctxt args
1106   = go n args
1107   where
1108     arg_env = vanillaCtxt env
1109
1110     go _ [] = (emptyDetails, [])        -- Too few args
1111
1112     go 1 (arg:args)                     -- The magic arg
1113       = case occAnal (setCtxtTy arg_env ctxt) arg of    { (arg_uds, arg') ->
1114         case occAnalArgs env args of                    { (args_uds, args') ->
1115         (arg_uds +++ args_uds, arg':args') }}
1116
1117     go n (arg:args)
1118       = case occAnal arg_env arg of     { (arg_uds, arg') ->
1119         case go (n-1) args of           { (args_uds, args') ->
1120         (arg_uds +++ args_uds, arg':args') }}
1121 \end{code}
1122
1123
1124 Note [Binders in case alternatives]
1125 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1126 Consider
1127     case x of y { (a,b) -> f y }
1128 We treat 'a', 'b' as dead, because they don't physically occur in the
1129 case alternative.  (Indeed, a variable is dead iff it doesn't occur in
1130 its scope in the output of OccAnal.)  It really helps to know when
1131 binders are unused.  See esp the call to isDeadBinder in
1132 Simplify.mkDupableAlt
1133
1134 In this example, though, the Simplifier will bring 'a' and 'b' back to
1135 life, beause it binds 'y' to (a,b) (imagine got inlined and
1136 scrutinised y).
1137
1138 \begin{code}
1139 occAnalAlt :: OccEnv
1140            -> CoreBndr
1141            -> CoreAlt
1142            -> (UsageDetails, Alt IdWithOccInfo)
1143 occAnalAlt env case_bndr (con, bndrs, rhs)
1144   = let 
1145         env' = trimOccEnv env bndrs
1146     in 
1147     case occAnal env' rhs of { (rhs_usage1, rhs1) ->
1148     let
1149         proxies = getProxies env' case_bndr 
1150         (rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies
1151         (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
1152         bndrs' = tagged_bndrs      -- See Note [Binders in case alternatives]
1153     in
1154     (alt_usg, (con, bndrs', rhs2)) }
1155
1156 wrapProxy :: ProxyBind -> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
1157 wrapProxy (bndr, rhs_var, co) (body_usg, body)
1158   | not (bndr `usedIn` body_usg) 
1159   = (body_usg, body)
1160   | otherwise
1161   = (body_usg' +++ rhs_usg, Let (NonRec tagged_bndr rhs) body)
1162   where
1163     (body_usg', tagged_bndr) = tagBinder body_usg bndr
1164     rhs_usg = unitVarEnv rhs_var NoOccInfo      -- We don't need exact info
1165     rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
1166 \end{code}
1167
1168
1169 %************************************************************************
1170 %*                                                                      *
1171                     OccEnv                                                                      
1172 %*                                                                      *
1173 %************************************************************************
1174
1175 \begin{code}
1176 data OccEnv
1177   = OccEnv { occ_encl     :: !OccEncl      -- Enclosing context information
1178            , occ_ctxt     :: !CtxtTy       -- Tells about linearity
1179            , occ_proxy    :: ProxyEnv
1180            , occ_rule_fvs :: ImpRuleUsage
1181            , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive
1182              -- See Note [Finding rule RHS free vars]
1183     }
1184
1185
1186 -----------------------------
1187 -- OccEncl is used to control whether to inline into constructor arguments
1188 -- For example:
1189 --      x = (p,q)               -- Don't inline p or q
1190 --      y = /\a -> (p a, q a)   -- Still don't inline p or q
1191 --      z = f (p,q)             -- Do inline p,q; it may make a rule fire
1192 -- So OccEncl tells enought about the context to know what to do when
1193 -- we encounter a contructor application or PAP.
1194
1195 data OccEncl
1196   = OccRhs              -- RHS of let(rec), albeit perhaps inside a type lambda
1197                         -- Don't inline into constructor args here
1198   | OccVanilla          -- Argument of function, body of lambda, scruintee of case etc.
1199                         -- Do inline into constructor args here
1200
1201 instance Outputable OccEncl where
1202   ppr OccRhs     = ptext (sLit "occRhs")
1203   ppr OccVanilla = ptext (sLit "occVanilla")
1204
1205 type CtxtTy = [Bool]
1206         -- []           No info
1207         --
1208         -- True:ctxt    Analysing a function-valued expression that will be
1209         --                      applied just once
1210         --
1211         -- False:ctxt   Analysing a function-valued expression that may
1212         --                      be applied many times; but when it is,
1213         --                      the CtxtTy inside applies
1214
1215 initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule] 
1216            -> OccEnv
1217 initOccEnv active_rule imp_rules
1218   = OccEnv { occ_encl  = OccVanilla
1219            , occ_ctxt  = []
1220            , occ_proxy = PE emptyVarEnv emptyVarSet
1221            , occ_rule_fvs = findImpRuleUsage active_rule imp_rules
1222            , occ_rule_act = active_rule }
1223
1224 vanillaCtxt :: OccEnv -> OccEnv
1225 vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }
1226
1227 rhsCtxt :: OccEnv -> OccEnv
1228 rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] }
1229
1230 setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
1231 setCtxtTy env ctxt = env { occ_ctxt = ctxt }
1232
1233 isRhsEnv :: OccEnv -> Bool
1234 isRhsEnv (OccEnv { occ_encl = OccRhs })     = True
1235 isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
1236
1237 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
1238         -- The result binders have one-shot-ness set that they might not have had originally.
1239         -- This happens in (build (\cn -> e)).  Here the occurrence analyser
1240         -- linearity context knows that c,n are one-shot, and it records that fact in
1241         -- the binder. This is useful to guide subsequent float-in/float-out tranformations
1242
1243 oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs
1244   = go ctxt bndrs []
1245   where
1246     go _ [] rev_bndrs = reverse rev_bndrs
1247
1248     go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
1249         | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
1250         where
1251           bndr' | lin_ctxt  = setOneShotLambda bndr
1252                 | otherwise = bndr
1253
1254     go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1255
1256 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1257 addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
1258   = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }
1259 \end{code}
1260
1261 %************************************************************************
1262 %*                                                                      *
1263                     ImpRuleUsage
1264 %*                                                                      *
1265 %************************************************************************
1266
1267 \begin{code}
1268 type ImpRuleUsage = NameEnv UsageDetails
1269   -- Maps an *imported* Id f to the UsageDetails for *local* Ids
1270   -- used on the RHS for a *local* rule for f.
1271 \end{code}
1272
1273 Note [ImpRuleUsage]
1274 ~~~~~~~~~~~~~~~~
1275 Consider this, where A.g is an imported Id
1276  
1277    f x = A.g x
1278    {-# RULE "foo" forall x. A.g x = f x #-}
1279
1280 Obviously there's a loop, but the danger is that the occurrence analyser
1281 will say that 'f' is not a loop breaker.  Then the simplifier will 
1282 optimise 'f' to
1283    f x = f x
1284 and then gaily inline 'f'.  Result infinite loop.  More realistically, 
1285 these kind of rules are generated when specialising imported INLINABLE Ids.
1286
1287 Solution: treat an occurrence of A.g as an occurrence of all the local Ids
1288 that occur on the RULE's RHS.  This mapping from imported Id to local Ids
1289 is held in occ_rule_fvs.
1290
1291 \begin{code}
1292 findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage
1293 -- Find the *local* Ids that can be reached transitively,
1294 -- via local rules, from each *imported* Id.  
1295 -- Sigh: this function seems more complicated than it is really worth
1296 findImpRuleUsage Nothing _ = emptyNameEnv
1297 findImpRuleUsage (Just is_active) rules
1298   = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
1299               | f <- rule_names 
1300               , let ls = find_lcl_deps f
1301               , not (isEmptyVarSet ls) ]
1302   where
1303     rule_names    = map ru_fn rules
1304     rule_name_set = mkNameSet rule_names
1305
1306     imp_deps :: NameEnv VarSet
1307       -- (f,g) means imported Id 'g' appears in RHS of 
1308       --       rule for imported Id 'f', *or* does so transitively
1309     imp_deps = foldr add_imp emptyNameEnv rules
1310     add_imp rule acc 
1311       | is_active (ruleActivation rule)
1312       = extendNameEnv_C unionVarSet acc (ru_fn rule)
1313                         (exprSomeFreeVars keep_imp (ru_rhs rule))
1314       | otherwise = acc
1315     keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
1316     full_imp_deps = transClosureFV (ufmToList imp_deps)
1317
1318     lcl_deps :: NameEnv VarSet
1319       -- (f, l) means localId 'l' appears immediately 
1320       --        in the RHS of a rule for imported Id 'f'
1321       -- Remember, many rules might have the same ru_fn
1322       -- so we do need to fold 
1323     lcl_deps = foldr add_lcl emptyNameEnv rules
1324     add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule)
1325                                        (exprFreeIds (ru_rhs rule))
1326
1327     find_lcl_deps :: Name -> VarSet
1328     find_lcl_deps f 
1329       = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f) 
1330                    (lookupNameEnv full_imp_deps f `orElse` emptyVarSet)
1331     lookup_lcl :: Name -> VarSet
1332     lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet
1333
1334 -------------
1335 transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet
1336 -- If (f,g), (g,h) are in the input, then (f,h) is in the output
1337 transClosureFV fv_list
1338   | no_change = env
1339   | otherwise = transClosureFV new_fv_list
1340   where
1341     env = listToUFM fv_list
1342     (no_change, new_fv_list) = mapAccumL bump True fv_list
1343     bump no_change (b,fvs)
1344       | no_change_here = (no_change, (b,fvs))
1345       | otherwise      = (False,     (b,new_fvs))
1346       where
1347         (new_fvs, no_change_here) = extendFvs env fvs
1348
1349 -------------
1350 extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
1351 -- (extendFVs env s) returns 
1352 --     (s `union` env(s), env(s) `subset` s)
1353 extendFvs env s
1354   = foldVarSet add (s, True) s
1355   where
1356     add v (vs, no_change_so_far)
1357         = case lookupUFM env v of
1358             Just fvs | not (fvs `subVarSet` s) 
1359                      -> (vs `unionVarSet` fvs, False)
1360             _        -> (vs, no_change_so_far)
1361 \end{code}
1362
1363
1364 %************************************************************************
1365 %*                                                                      *
1366                     ProxyEnv                                                                    
1367 %*                                                                      *
1368 %************************************************************************
1369
1370 \begin{code}
1371 data ProxyEnv   -- See Note [ProxyEnv]
1372    = PE (IdEnv  -- Domain = scrutinee variables
1373            (Id,                  -- The scrutinee variable again
1374             [(Id,Coercion)]))    -- The case binders that it maps to
1375         VarSet  -- Free variables of both range and domain
1376 \end{code}
1377
1378 Note [ProxyEnv]
1379 ~~~~~~~~~~~~~~~
1380 The ProxyEnv keeps track of the connection between case binders and
1381 scrutinee.  Specifically, if
1382      sc |-> (sc, [...(cb, co)...])
1383 is a binding in the ProxyEnv, then
1384      cb = sc |> coi
1385 Typically we add such a binding when encountering the case expression
1386      case (sc |> coi) of cb { ... }
1387
1388 Things to note:
1389   * The domain of the ProxyEnv is the variable (or casted variable) 
1390     scrutinees of enclosing cases.  This is additionally used
1391     to ensure we gather occurrence info even for GlobalId scrutinees;
1392     see Note [Binder swap for GlobalId scrutinee]
1393
1394   * The ProxyEnv is just an optimisation; you can throw away any 
1395     element without losing correctness.  And we do so when pushing
1396     it inside a binding (see trimProxyEnv).
1397
1398   * One scrutinee might map to many case binders:  Eg
1399       case sc of cb1 { DEFAULT -> ....case sc of cb2 { ... } .. }
1400
1401 INVARIANTS
1402  * If sc1 |-> (sc2, [...(cb, co)...]), then sc1==sc2
1403    It's a UniqFM and we sometimes need the domain Id
1404
1405  * Any particular case binder 'cb' occurs only once in entire range
1406
1407  * No loops
1408
1409 The Main Reason for having a ProxyEnv is so that when we encounter
1410     case e of cb { pi -> ri }
1411 we can find all the in-scope variables derivable from 'cb', 
1412 and effectively add let-bindings for them (or at least for the
1413 ones *mentioned* in ri) thus:
1414     case e of cb { pi -> let { x = ..cb..; y = ...cb.. }
1415                          in ri }
1416 In this way we'll replace occurrences of 'x', 'y' with 'cb',
1417 which implements the Binder-swap idea (see Note [Binder swap])
1418
1419 The function getProxies finds these bindings; then we 
1420 add just the necessary ones, using wrapProxy. 
1421
1422 Note [Binder swap]
1423 ~~~~~~~~~~~~~~~~~~
1424 We do these two transformations right here:
1425
1426  (1)   case x of b { pi -> ri }
1427     ==>
1428       case x of b { pi -> let x=b in ri }
1429
1430  (2)  case (x |> co) of b { pi -> ri }
1431     ==>
1432       case (x |> co) of b { pi -> let x = b |> sym co in ri }
1433
1434     Why (2)?  See Note [Case of cast]
1435
1436 In both cases, in a particular alternative (pi -> ri), we only 
1437 add the binding if
1438   (a) x occurs free in (pi -> ri)
1439         (ie it occurs in ri, but is not bound in pi)
1440   (b) the pi does not bind b (or the free vars of co)
1441 We need (a) and (b) for the inserted binding to be correct.
1442
1443 For the alternatives where we inject the binding, we can transfer
1444 all x's OccInfo to b.  And that is the point.
1445
1446 Notice that 
1447   * The deliberate shadowing of 'x'. 
1448   * That (a) rapidly becomes false, so no bindings are injected.
1449
1450 The reason for doing these transformations here is because it allows
1451 us to adjust the OccInfo for 'x' and 'b' as we go.
1452
1453   * Suppose the only occurrences of 'x' are the scrutinee and in the
1454     ri; then this transformation makes it occur just once, and hence
1455     get inlined right away.
1456
1457   * If we do this in the Simplifier, we don't know whether 'x' is used
1458     in ri, so we are forced to pessimistically zap b's OccInfo even
1459     though it is typically dead (ie neither it nor x appear in the
1460     ri).  There's nothing actually wrong with zapping it, except that
1461     it's kind of nice to know which variables are dead.  My nose
1462     tells me to keep this information as robustly as possible.
1463
1464 The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
1465 {x=b}; it's Nothing if the binder-swap doesn't happen.
1466
1467 There is a danger though.  Consider
1468       let v = x +# y
1469       in case (f v) of w -> ...v...v...
1470 And suppose that (f v) expands to just v.  Then we'd like to
1471 use 'w' instead of 'v' in the alternative.  But it may be too
1472 late; we may have substituted the (cheap) x+#y for v in the 
1473 same simplifier pass that reduced (f v) to v.
1474
1475 I think this is just too bad.  CSE will recover some of it.
1476
1477 Note [Case of cast]
1478 ~~~~~~~~~~~~~~~~~~~
1479 Consider        case (x `cast` co) of b { I# ->
1480                 ... (case (x `cast` co) of {...}) ...
1481 We'd like to eliminate the inner case.  That is the motivation for
1482 equation (2) in Note [Binder swap].  When we get to the inner case, we
1483 inline x, cancel the casts, and away we go.
1484
1485 Note [Binder swap on GlobalId scrutinees]
1486 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1487 When the scrutinee is a GlobalId we must take care in two ways
1488
1489  i) In order to *know* whether 'x' occurs free in the RHS, we need its
1490     occurrence info. BUT, we don't gather occurrence info for
1491     GlobalIds.  That's one use for the (small) occ_proxy env in OccEnv is
1492     for: it says "gather occurrence info for these.
1493
1494  ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
1495      has an External Name. See, for example, SimplEnv Note [Global Ids in
1496      the substitution].
1497
1498 Note [getProxies is subtle]
1499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1500 The code for getProxies isn't all that obvious. Consider
1501
1502   case v |> cov  of x { DEFAULT ->
1503   case x |> cox1 of y { DEFAULT ->
1504   case x |> cox2 of z { DEFAULT -> r
1505
1506 These will give us a ProxyEnv looking like:
1507   x |-> (x, [(y, cox1), (z, cox2)])
1508   v |-> (v, [(x, cov)])
1509
1510 From this we want to extract the bindings
1511     x = z |> sym cox2
1512     v = x |> sym cov
1513     y = x |> cox1
1514
1515 Notice that later bindings may mention earlier ones, and that
1516 we need to go "both ways".
1517
1518 Note [Zap case binders in proxy bindings]
1519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1520 From the original
1521      case x of cb(dead) { p -> ...x... }
1522 we will get
1523      case x of cb(live) { p -> let x = cb in ...x... }
1524
1525 Core Lint never expects to find an *occurence* of an Id marked
1526 as Dead, so we must zap the OccInfo on cb before making the 
1527 binding x = cb.  See Trac #5028.
1528
1529 Historical note [no-case-of-case]
1530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1531 We *used* to suppress the binder-swap in case expressions when 
1532 -fno-case-of-case is on.  Old remarks:
1533     "This happens in the first simplifier pass,
1534     and enhances full laziness.  Here's the bad case:
1535             f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
1536     If we eliminate the inner case, we trap it inside the I# v -> arm,
1537     which might prevent some full laziness happening.  I've seen this
1538     in action in spectral/cichelli/Prog.hs:
1539              [(m,n) | m <- [1..max], n <- [1..max]]
1540     Hence the check for NoCaseOfCase."
1541 However, now the full-laziness pass itself reverses the binder-swap, so this
1542 check is no longer necessary.
1543
1544 Historical note [Suppressing the case binder-swap]
1545 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1546 This old note describes a problem that is also fixed by doing the
1547 binder-swap in OccAnal:
1548
1549     There is another situation when it might make sense to suppress the
1550     case-expression binde-swap. If we have
1551
1552         case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
1553                        ...other cases .... }
1554
1555     We'll perform the binder-swap for the outer case, giving
1556
1557         case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
1558                        ...other cases .... }
1559
1560     But there is no point in doing it for the inner case, because w1 can't
1561     be inlined anyway.  Furthermore, doing the case-swapping involves
1562     zapping w2's occurrence info (see paragraphs that follow), and that
1563     forces us to bind w2 when doing case merging.  So we get
1564
1565         case x of w1 { A -> let w2 = w1 in e1
1566                        B -> let w2 = w1 in e2
1567                        ...other cases .... }
1568
1569     This is plain silly in the common case where w2 is dead.
1570
1571     Even so, I can't see a good way to implement this idea.  I tried
1572     not doing the binder-swap if the scrutinee was already evaluated
1573     but that failed big-time:
1574
1575             data T = MkT !Int
1576
1577             case v of w  { MkT x ->
1578             case x of x1 { I# y1 ->
1579             case x of x2 { I# y2 -> ...
1580
1581     Notice that because MkT is strict, x is marked "evaluated".  But to
1582     eliminate the last case, we must either make sure that x (as well as
1583     x1) has unfolding MkT y1.  THe straightforward thing to do is to do
1584     the binder-swap.  So this whole note is a no-op.
1585
1586 It's fixed by doing the binder-swap in OccAnal because we can do the
1587 binder-swap unconditionally and still get occurrence analysis
1588 information right.
1589
1590 \begin{code}
1591 extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv
1592 -- (extendPE x co y) typically arises from 
1593 --                case (x |> co) of y { ... }
1594 -- It extends the proxy env with the binding 
1595 --                     y = x |> co
1596 extendProxyEnv pe scrut co case_bndr
1597   | scrut == case_bndr = PE env1 fvs1   -- If case_bndr shadows scrut,
1598   | otherwise          = PE env2 fvs2   --   don't extend
1599   where
1600     PE env1 fvs1 = trimProxyEnv pe [case_bndr]
1601     env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
1602     single cb_co = (scrut1, [cb_co]) 
1603     add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
1604     fvs2 = fvs1 `unionVarSet`  tyCoVarsOfCo co
1605                 `extendVarSet` case_bndr
1606                 `extendVarSet` scrut1
1607
1608     scrut1 = mkLocalId (localiseName (idName scrut)) (idType scrut)
1609         -- Localise the scrut_var before shadowing it; we're making a 
1610         -- new binding for it, and it might have an External Name, or
1611         -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
1612         -- Also we don't want any INLINE or NOINLINE pragmas!
1613
1614 -----------
1615 type ProxyBind = (Id, Id, Coercion)
1616      -- (scrut variable, case-binder variable, coercion)
1617
1618 getProxies :: OccEnv -> Id -> Bag ProxyBind
1619 -- Return a bunch of bindings [...(xi,ei)...] 
1620 -- such that  let { ...; xi=ei; ... } binds the xi using y alone
1621 -- See Note [getProxies is subtle]
1622 getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
1623   = -- pprTrace "wrapProxies" (ppr case_bndr) $
1624     go_fwd case_bndr
1625   where
1626     fwd_pe :: IdEnv (Id, Coercion)
1627     fwd_pe = foldVarEnv add1 emptyVarEnv pe
1628            where
1629              add1 (x,ycos) env = foldr (add2 x) env ycos
1630              add2 x (y,co) env = extendVarEnv env y (x,co)
1631
1632     go_fwd :: Id -> Bag ProxyBind
1633         -- Return bindings derivable from case_bndr
1634     go_fwd case_bndr = -- pprTrace "go_fwd" (vcat [ppr case_bndr, text "fwd_pe =" <+> ppr fwd_pe, 
1635                        --                         text "pe =" <+> ppr pe]) $ 
1636                        go_fwd' case_bndr
1637
1638     go_fwd' case_bndr
1639         | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
1640         = unitBag (scrut,  case_bndr, mkSymCo co)
1641           `unionBags` go_fwd scrut
1642           `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
1643                                        , cb /= case_bndr]
1644         | otherwise 
1645         = emptyBag
1646
1647     lookup_bwd :: Id -> [(Id, Coercion)]
1648         -- Return case_bndrs that are connected to scrut 
1649     lookup_bwd scrut = case lookupVarEnv pe scrut of
1650                           Nothing          -> []
1651                           Just (_, cb_cos) -> cb_cos
1652
1653     go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind
1654     go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
1655
1656     go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind
1657     go_bwd1 scrut (case_bndr, co) 
1658        = -- pprTrace "go_bwd1" (ppr case_bndr) $
1659          unitBag (case_bndr, scrut, co)
1660          `unionBags` go_bwd case_bndr (lookup_bwd case_bndr)
1661
1662 -----------
1663 mkAltEnv :: OccEnv -> CoreExpr -> Id -> OccEnv
1664 -- Does two things: a) makes the occ_ctxt = OccVanilla
1665 --                  b) extends the ProxyEnv if possible
1666 mkAltEnv env scrut cb
1667   = env { occ_encl  = OccVanilla, occ_proxy = pe' }
1668   where
1669     pe  = occ_proxy env
1670     pe' = case scrut of
1671              Var v           -> extendProxyEnv pe v (mkReflCo (idType v)) cb
1672              Cast (Var v) co -> extendProxyEnv pe v co                    cb
1673              _other          -> trimProxyEnv pe [cb]
1674
1675 -----------
1676 trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
1677 trimOccEnv env bndrs = env { occ_proxy = trimProxyEnv (occ_proxy env) bndrs }
1678
1679 -----------
1680 trimProxyEnv :: ProxyEnv -> [CoreBndr] -> ProxyEnv
1681 -- We are about to push this ProxyEnv inside a binding for 'bndrs'
1682 -- So dump any ProxyEnv bindings which mention any of the bndrs
1683 trimProxyEnv (PE pe fvs) bndrs 
1684   | not (bndr_set `intersectsVarSet` fvs) 
1685   = PE pe fvs
1686   | otherwise
1687   = PE pe' (fvs `minusVarSet` bndr_set)
1688   where
1689     pe' = mapVarEnv trim pe
1690     bndr_set = mkVarSet bndrs
1691     trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
1692                          | otherwise = (scrut, filterOut discard cb_cos)
1693     discard (cb,co) = bndr_set `intersectsVarSet` 
1694                       extendVarSet (tyCoVarsOfCo co) cb
1695 \end{code}
1696
1697
1698 %************************************************************************
1699 %*                                                                      *
1700 \subsection[OccurAnal-types]{OccEnv}
1701 %*                                                                      *
1702 %************************************************************************
1703
1704 \begin{code}
1705 type UsageDetails = IdEnv OccInfo       -- A finite map from ids to their usage
1706                 -- INVARIANT: never IAmDead
1707                 -- (Deadness is signalled by not being in the map at all)
1708
1709 (+++), combineAltsUsageDetails
1710         :: UsageDetails -> UsageDetails -> UsageDetails
1711
1712 (+++) usage1 usage2
1713   = plusVarEnv_C addOccInfo usage1 usage2
1714
1715 combineAltsUsageDetails usage1 usage2
1716   = plusVarEnv_C orOccInfo usage1 usage2
1717
1718 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1719 addOneOcc usage id info
1720   = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1721         -- ToDo: make this more efficient
1722
1723 emptyDetails :: UsageDetails
1724 emptyDetails = (emptyVarEnv :: UsageDetails)
1725
1726 usedIn :: Id -> UsageDetails -> Bool
1727 v `usedIn` details = isExportedId v || v `elemVarEnv` details
1728
1729 type IdWithOccInfo = Id
1730
1731 tagLamBinders :: UsageDetails          -- Of scope
1732               -> [Id]                  -- Binders
1733               -> (UsageDetails,        -- Details with binders removed
1734                  [IdWithOccInfo])    -- Tagged binders
1735 -- Used for lambda and case binders
1736 -- It copes with the fact that lambda bindings can have InlineRule 
1737 -- unfoldings, used for join points
1738 tagLamBinders usage binders = usage' `seq` (usage', bndrs')
1739   where
1740     (usage', bndrs') = mapAccumR tag_lam usage binders
1741     tag_lam usage bndr = (usage2, setBinderOcc usage bndr)
1742       where
1743         usage1 = usage `delVarEnv` bndr
1744         usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr)
1745                | otherwise = usage1
1746
1747 tagBinder :: UsageDetails           -- Of scope
1748           -> Id                     -- Binders
1749           -> (UsageDetails,         -- Details with binders removed
1750               IdWithOccInfo)        -- Tagged binders
1751
1752 tagBinder usage binder
1753  = let
1754      usage'  = usage `delVarEnv` binder
1755      binder' = setBinderOcc usage binder
1756    in
1757    usage' `seq` (usage', binder')
1758
1759 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1760 setBinderOcc usage bndr
1761   | isTyVar bndr      = bndr
1762   | isExportedId bndr = case idOccInfo bndr of
1763                           NoOccInfo -> bndr
1764                           _         -> setIdOccInfo bndr NoOccInfo
1765             -- Don't use local usage info for visible-elsewhere things
1766             -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1767             -- about to re-generate it and it shouldn't be "sticky"
1768
1769   | otherwise = setIdOccInfo bndr occ_info
1770   where
1771     occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1772 \end{code}
1773
1774
1775 %************************************************************************
1776 %*                                                                      *
1777 \subsection{Operations over OccInfo}
1778 %*                                                                      *
1779 %************************************************************************
1780
1781 \begin{code}
1782 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1783 mkOneOcc env id int_cxt
1784   | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1785   | PE env _ <- occ_proxy env
1786   , id `elemVarEnv` env = unitVarEnv id NoOccInfo
1787   | Just uds <- lookupNameEnv (occ_rule_fvs env) (idName id)
1788   = uds
1789   | otherwise           = emptyDetails
1790
1791 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1792
1793 markMany _  = NoOccInfo
1794
1795 markInsideSCC occ = markMany occ
1796
1797 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1798 markInsideLam occ                       = occ
1799
1800 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1801
1802 addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
1803                     NoOccInfo   -- Both branches are at least One
1804                                 -- (Argument is never IAmDead)
1805
1806 -- (orOccInfo orig new) is used
1807 -- when combining occurrence info from branches of a case
1808
1809 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1810           (OneOcc in_lam2 _ int_cxt2)
1811   = OneOcc (in_lam1 || in_lam2)
1812            False        -- False, because it occurs in both branches
1813            (int_cxt1 && int_cxt2)
1814 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
1815                   NoOccInfo
1816 \end{code}