small reworking of the loop-breaker-choosing algorithm
[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 {-# OPTIONS -w #-}
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
19 -- for details
20
21 module OccurAnal (
22         occurAnalysePgm, occurAnalyseExpr
23     ) where
24
25 #include "HsVersions.h"
26
27 import CoreSyn
28 import CoreFVs          ( idRuleVars )
29 import CoreUtils        ( exprIsTrivial, isDefaultAlt )
30 import Id
31 import IdInfo
32 import BasicTypes       ( OccInfo(..), isOneOcc, InterestingCxt )
33
34 import VarSet
35 import VarEnv
36
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 )
43 import Outputable
44
45 import Data.List
46 \end{code}
47
48
49 %************************************************************************
50 %*                                                                      *
51 \subsection[OccurAnal-main]{Counting occurrences: main function}
52 %*                                                                      *
53 %************************************************************************
54
55 Here's the externally-callable interface:
56
57 \begin{code}
58 occurAnalysePgm :: [CoreBind] -> [CoreBind]
59 occurAnalysePgm binds
60   = snd (go initOccEnv binds)
61   where
62     go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
63     go env [] 
64         = (emptyDetails, [])
65     go env (bind:binds) 
66         = (final_usage, bind' ++ binds')
67         where
68            (bs_usage, binds')   = go env binds
69            (final_usage, bind') = occAnalBind env bind bs_usage
70
71 occurAnalyseExpr :: CoreExpr -> CoreExpr
72         -- Do occurrence analysis, and discard occurence info returned
73 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
74 \end{code}
75
76
77 %************************************************************************
78 %*                                                                      *
79 \subsection[OccurAnal-main]{Counting occurrences: main function}
80 %*                                                                      *
81 %************************************************************************
82
83 Bindings
84 ~~~~~~~~
85
86 \begin{code}
87 occAnalBind :: OccEnv
88             -> CoreBind
89             -> UsageDetails             -- Usage details of scope
90             -> (UsageDetails,           -- Of the whole let(rec)
91                 [CoreBind])
92
93 occAnalBind env (NonRec binder rhs) body_usage
94   | not (binder `usedIn` body_usage)            -- It's not mentioned
95   = (body_usage, [])
96
97   | otherwise                   -- It's mentioned in the body
98   = (body_usage' +++ addRuleUsage rhs_usage binder,     -- Note [RulesOnly]
99      [NonRec tagged_binder rhs'])
100   where
101     (body_usage', tagged_binder) = tagBinder body_usage binder
102     (rhs_usage, rhs')            = occAnalRhs env tagged_binder rhs
103 \end{code}
104
105 Dropping dead code for recursive bindings is done in a very simple way:
106
107         the entire set of bindings is dropped if none of its binders are
108         mentioned in its body; otherwise none are.
109
110 This seems to miss an obvious improvement.
111 @
112         letrec  f = ...g...
113                 g = ...f...
114         in
115         ...g...
116
117 ===>
118
119         letrec f = ...g...
120                g = ...(...g...)...
121         in
122         ...g...
123 @
124
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
128
129 @
130         letrec f = ...g...
131                g = ...h...
132                h = ...k...
133                k = ...m...
134                m = ...m...
135         in
136         ...m...
137 @
138
139
140 \begin{code}
141 occAnalBind env (Rec pairs) body_usage
142   = foldr ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) (body_usage, []) sccs
143   where
144     analysed_pairs :: [Details]
145     analysed_pairs  = [ (bndr, rhs_usage, rhs')
146                       | (bndr, rhs) <- pairs,
147                         let (rhs_usage, rhs') = occAnalRhs env bndr rhs
148                       ]
149
150     sccs :: [SCC (Node Details)]
151     sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR edges
152
153
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
159             ]
160
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)
173
174     ---- Stuff to "re-constitute" bindings from dependency-analysis info ------
175
176         -- Non-recursive SCC
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
180       | otherwise
181       = (body_usage' +++ addRuleUsage rhs_usage bndr, new_bind : binds_so_far)  
182       where
183         (body_usage', tagged_bndr) = tagBinder body_usage bndr
184         new_bind                   = NonRec tagged_bndr rhs'
185
186         -- Recursive SCC
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)
192       where
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))
199                                            where
200                                              (usg', bndr') = tagBinder usg bndr
201         final_bind = Rec (reOrderCycle (mkVarSet bndrs) tagged_cycle)
202
203 {-      An alternative; rebuild the edges.  No semantic difference, but perf might change
204
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) 
211           where
212             used = [key | key <- keys, used_outside_rule rhs_usage key ]
213
214         used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of
215                                                 Nothing         -> False
216                                                 Just RulesOnly  -> False        -- Ignore rules
217                                                 other           -> True
218 -}
219 \end{code}
220
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
223 same pairs, but 
224         a) in a better order,
225         b) with some of the Ids having a IAmALoopBreaker pragma
226
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.
230
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.
235
236 ==============
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.]
239
240 Here's a case that bit me:
241
242         letrec
243                 a = b
244                 b = \x. BIG
245         in
246         ...a...a...a....
247
248 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
249
250 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
251 Perhaps something cleverer would suffice.
252 ===============
253
254
255 \begin{code}
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)
259
260 reOrderRec :: IdSet     -- Binders of this group
261            -> SCC (Node Details)
262            -> [(Id,CoreExpr)]
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
267
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)]
273   where
274     ((bndr, rhs_usg, rhs), _, _) = bind
275
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)]
281
282   where
283     (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
284     (bndr, rhs_usg, rhs)  = chosen_bind
285
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
290
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
294
295         | otherwise     -- No lower so don't pick it
296         = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
297         where
298           sc = score bind
299           
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]
304
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
311           
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]
317
318         | is_con_app rhs = 2    -- Data types help with cases
319                 -- Note [conapp]
320
321         | inlineCandidate bndr rhs = 1  -- Likely to be inlined
322                 -- Note [Inline candidates]
323
324         | otherwise = 0
325
326     inlineCandidate :: Id -> CoreExpr -> Bool
327     inlineCandidate id (Note InlineMe _) = True
328     inlineCandidate id rhs               = isOneOcc (idOccInfo id)
329
330         -- Note [conapp]
331         --
332         -- It's really really important to inline dictionaries.  Real
333         -- example (the Enum Ordering instance from GHC.Base):
334         --
335         --      rec     f = \ x -> case d of (p,q,r) -> p x
336         --              g = \ x -> case d of (p,q,r) -> q x
337         --              d = (v, f, g)
338         --
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.
345
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
351         --
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
359
360 makeLoopBreaker :: VarSet               -- Binders of this group
361                 -> UsageDetails         -- Usage of this rhs (neglecting rules)
362                 -> Id -> Id
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)
367   where
368     rules_only = bndrs `intersectsUFM` rhs_usg
369 \end{code}
370
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:
376   rec {
377         $wfoo x = ....foo x....
378         
379         {-loop brk-} foo x = ...$wfoo x...
380   }
381
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).
389
390 Note [Recursive rules]
391 ~~~~~~~~~~~~~~~~~~~~~~
392 Consider this group, which is typical of what SpecConstr builds:
393
394    fs a = ....f (C a)....
395    f  x = ....f (C a)....
396    {-# RULE f (C a) = fs a #-}
397
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.
400
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
405
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.
408
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:
414
415     data Clo a b = forall c. Clo (c -> a -> b) c
416
417     ($:) :: Clo a b -> a -> b
418     Clo f env $: x = f env x
419
420     rec { plus = Clo plus1 ()
421
422         ; plus1 _ n = Clo plus2 n
423
424         ; plus2 Zero     n = n
425         ; plus2 (Succ m) n = Succ (plus $: m $: n) }
426
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.
430
431
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.
438
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.
441
442
443 \begin{code}
444 occAnalRhs :: OccEnv
445            -> Id -> CoreExpr    -- Binder and rhs
446                                 -- For non-recs the binder is alrady tagged
447                                 -- with occurrence info
448            -> (UsageDetails, CoreExpr)
449
450 occAnalRhs env id rhs
451   = occAnal ctxt rhs
452   where
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
457         --
458         -- But there's a problem.  Consider
459         --      x1 = a0 : []
460         --      x2 = a1 : x1
461         --      x3 = a2 : x2
462         --      g  = f x3
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...
469
470     certainly_inline id = case idOccInfo id of
471                             OneOcc in_lam one_br _ -> not in_lam && one_br
472                             other                  -> False
473 \end{code}
474
475 Note [RulesOnly]
476 ~~~~~~~~~~~~~~~~~~
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
481 directly.
482
483 That's the basic idea.  However in a recursive situation we want to be a bit
484 cleverer. Example (from GHC.Enum):
485
486   eftInt :: Int# -> Int# -> [Int]
487   eftInt x y = ...(non-recursive)...
488
489   {-# INLINE [0] eftIntFB #-}
490   eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
491   eftIntFB c n x y = ...(non-recursive)...
492
493   {-# RULES
494   "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
495   "eftIntList"  [1] eftIntFB  (:) [] = eftInt
496    #-}
497
498 The two look mutually recursive only because of their RULES; we don't want 
499 that to inhibit inlining!
500
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.
504
505
506 \begin{code}
507
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)
512   where
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
516 \end{code}
517
518 Expressions
519 ~~~~~~~~~~~
520 \begin{code}
521 occAnal :: OccEnv
522         -> CoreExpr
523         -> (UsageDetails,       -- Gives info only about the "interesting" Ids
524             CoreExpr)
525
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.
534 \end{code}
535
536 We regard variables that occur as constructor arguments as "dangerousToDup":
537
538 \begin{verbatim}
539 module A where
540 f x = let y = expensive x in 
541       let z = (True,y) in 
542       (case z of {(p,q)->q}, case z of {(p,q)->q})
543 \end{verbatim}
544
545 We feel free to duplicate the WHNF (True,y), but that means
546 that y may be duplicated thereby.
547
548 If we aren't careful we duplicate the (expensive x) call!
549 Constructors are rather like lambdas in this way.
550
551 \begin{code}
552 occAnal env expr@(Lit lit) = (emptyDetails, expr)
553 \end{code}
554
555 \begin{code}
556 occAnal env (Note InlineMe body)
557   = case occAnal env body of { (usage, body') -> 
558     (mapVarEnv markMany usage, Note InlineMe body')
559     }
560
561 occAnal env (Note note@(SCC cc) body)
562   = case occAnal env body of { (usage, body') ->
563     (mapVarEnv markInsideSCC usage, Note note body')
564     }
565
566 occAnal env (Note note body)
567   = case occAnal env body of { (usage, body') ->
568     (usage, Note note body')
569     }
570
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. 
577     }
578 \end{code}
579
580 \begin{code}
581 occAnal env app@(App fun arg)
582   = occAnalApp env (collectArgs app) False
583
584 -- Ignore type variables altogether
585 --   (a) occurrences inside type lambdas only not marked as InsideLam
586 --   (b) type variables not in environment
587
588 occAnal env expr@(Lam x body) | isTyVar x
589   = case occAnal env body of { (body_usage, body') ->
590     (body_usage, Lam x body')
591     }
592
593 -- For value lambdas we do a special hack.  Consider
594 --      (\x. \y. ...x...)
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.
601
602 occAnal env expr@(Lam _ _)
603   = case occAnal env_body body of { (body_usage, body') ->
604     let
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 
609
610         really_final_usage = if linear then
611                                 final_usage
612                              else
613                                 mapVarEnv markInsideLam final_usage
614     in
615     (really_final_usage,
616      mkLams tagged_binders body') }
617   where
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
623
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')   -> 
627     let
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
632     in
633     total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
634   where
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 }
640         -- into
641         --      case x of w { (p,q) -> f (p,q) }
642     addCaseBndrUsage usage = case lookupVarEnv usage bndr of
643                                 Nothing  -> usage
644                                 Just occ -> extendVarEnv usage bndr (markMany occ)
645
646     alt_env = setVanillaCtxt env
647         -- Consider     x = case v of { True -> (p,q); ... }
648         -- Then it's fine to inline p and q
649
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
655
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') }}
660
661 occAnalArgs env args
662   = case mapAndUnzip (occAnal arg_env) args of  { (arg_uds_s, args') ->
663     (foldr (+++) emptyDetails arg_uds_s, args')}
664   where
665     arg_env = vanillaCtxt
666 \end{code}
667
668 Applications are dealt with specially because we want
669 the "build hack" to work.
670
671 \begin{code}
672 occAnalApp env (Var fun, args) is_rhs
673   = case args_stuff of { (args_uds, args') ->
674     let
675         final_args_uds = markRhsUds env is_pap args_uds
676     in
677     (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
678   where
679     fun_uniq = idUnique fun
680     fun_uds  = mkOneOcc env fun (valArgCount args > 0)
681     is_pap = isDataConWorkId fun || valArgCount args < idArity fun
682
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
693
694                 | otherwise = occAnalArgs env args
695
696
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
701         --      (\x y -> e) a1 a2
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.
705
706     case occAnalArgs env args of        { (args_uds, args') ->
707     let
708         final_uds = fun_uds +++ args_uds
709     in
710     (final_uds, mkApps fun' args') }}
711     
712
713 markRhsUds :: OccEnv            -- Check if this is a RhsEnv
714            -> Bool              -- and this is true
715            -> UsageDetails      -- The do markMany on this
716            -> UsageDetails
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.
722 --
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
727
728
729 appSpecial :: OccEnv 
730            -> Int -> CtxtTy     -- Argument number, and context to use for it
731            -> [CoreExpr]
732            -> (UsageDetails, [CoreExpr])
733 appSpecial env n ctxt args
734   = go n args
735   where
736     arg_env = vanillaCtxt
737
738     go n [] = (emptyDetails, [])        -- Too few args
739
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') }}
744     
745     go n (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') }}
749 \end{code}
750
751     
752 Case alternatives
753 ~~~~~~~~~~~~~~~~~
754 If the case binder occurs at all, the other binders effectively do too.  
755 For example
756         case e of x { (a,b) -> rhs }
757 is rather like
758         let x = (a,b) in 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
761
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
765
766 \begin{code}
767 occAnalAlt env case_bndr (con, bndrs, rhs)
768   = case occAnal env rhs of { (rhs_usage, rhs') ->
769     let
770         (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
771         final_bndrs = tagged_bndrs      -- See Note [Aug06] above
772 {-
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
777 -}
778     in
779     (final_usage, (con, final_bndrs, rhs')) }
780 \end{code}
781
782
783 %************************************************************************
784 %*                                                                      *
785 \subsection[OccurAnal-types]{OccEnv}
786 %*                                                                      *
787 %************************************************************************
788
789 \begin{code}
790 data OccEnv
791   = OccEnv OccEncl      -- Enclosing context information
792            CtxtTy       -- Tells about linearity
793
794 -- OccEncl is used to control whether to inline into constructor arguments
795 -- For example:
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.
801
802 data OccEncl
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
807
808 type CtxtTy = [Bool]
809         -- []           No info
810         --
811         -- True:ctxt    Analysing a function-valued expression that will be
812         --                      applied just once
813         --
814         -- False:ctxt   Analysing a function-valued expression that may
815         --                      be applied many times; but when it is, 
816         --                      the CtxtTy inside applies
817
818 initOccEnv :: OccEnv
819 initOccEnv = OccEnv OccRhs []
820
821 vanillaCtxt = OccEnv OccVanilla []
822 rhsCtxt     = OccEnv OccRhs     []
823
824 isRhsEnv (OccEnv OccRhs     _) = True
825 isRhsEnv (OccEnv OccVanilla _) = False
826
827 setVanillaCtxt :: OccEnv -> OccEnv
828 setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
829 setVanillaCtxt other_env               = other_env
830
831 setCtxt :: OccEnv -> CtxtTy -> OccEnv
832 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
833
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
839
840 oneShotGroup (OccEnv encl ctxt) bndrs 
841   = go ctxt bndrs []
842   where
843     go ctxt [] rev_bndrs = reverse rev_bndrs
844
845     go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
846         | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
847         where
848           bndr' | lin_ctxt  = setOneShotLambda bndr
849                 | otherwise = bndr
850
851     go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
852
853 addAppCtxt (OccEnv encl ctxt) args 
854   = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
855 \end{code}
856
857 %************************************************************************
858 %*                                                                      *
859 \subsection[OccurAnal-types]{OccEnv}
860 %*                                                                      *
861 %************************************************************************
862
863 \begin{code}
864 type UsageDetails = IdEnv OccInfo       -- A finite map from ids to their usage
865
866 (+++), combineAltsUsageDetails
867         :: UsageDetails -> UsageDetails -> UsageDetails
868
869 (+++) usage1 usage2
870   = plusVarEnv_C addOccInfo usage1 usage2
871
872 combineAltsUsageDetails usage1 usage2
873   = plusVarEnv_C orOccInfo usage1 usage2
874
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
879
880 emptyDetails = (emptyVarEnv :: UsageDetails)
881
882 usedIn :: Id -> UsageDetails -> Bool
883 v `usedIn` details =  isExportedId v || v `elemVarEnv` details
884
885 type IdWithOccInfo = Id
886
887 tagBinders :: UsageDetails          -- Of scope
888            -> [Id]                  -- Binders
889            -> (UsageDetails,        -- Details with binders removed
890               [IdWithOccInfo])    -- Tagged binders
891
892 tagBinders usage binders
893  = let
894      usage' = usage `delVarEnvList` binders
895      uss    = map (setBinderOcc usage) binders
896    in
897    usage' `seq` (usage', uss)
898
899 tagBinder :: UsageDetails           -- Of scope
900           -> Id                     -- Binders
901           -> (UsageDetails,         -- Details with binders removed
902               IdWithOccInfo)        -- Tagged binders
903
904 tagBinder usage binder
905  = let
906      usage'  = usage `delVarEnv` binder
907      binder' = setBinderOcc usage binder
908    in
909    usage' `seq` (usage', binder')
910
911 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
912 setBinderOcc usage bndr
913   | isTyVar bndr      = bndr
914   | isExportedId bndr = case idOccInfo bndr of
915                           NoOccInfo -> bndr
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"
920                           
921   | otherwise = setIdOccInfo bndr occ_info
922   where
923     occ_info = lookupVarEnv usage bndr `orElse` IAmDead
924 \end{code}
925
926
927 %************************************************************************
928 %*                                                                      *
929 \subsection{Operations over OccInfo}
930 %*                                                                      *
931 %************************************************************************
932
933 \begin{code}
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
938
939 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
940
941 markMany IAmDead = IAmDead
942 markMany other   = NoOccInfo
943
944 markInsideSCC occ = markMany occ
945
946 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
947 markInsideLam occ                       = occ
948
949 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
950
951 addOccInfo IAmDead info2       = info2
952 addOccInfo info1 IAmDead       = info1
953 addOccInfo info1 info2         = NoOccInfo
954
955 -- (orOccInfo orig new) is used
956 -- when combining occurrence info from branches of a case
957
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
966 \end{code}