[project @ 2001-10-25 02:13:10 by sof]
[ghc-hetmet.git] / ghc / compiler / specialise / Specialise.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 %
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
5
6 \begin{code}
7 module Specialise ( specProgram ) where
8
9 #include "HsVersions.h"
10
11 import CmdLineOpts      ( DynFlags, DynFlag(..) )
12 import Id               ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
13 import TcType           ( Type, mkTyVarTy, tcSplitSigmaTy, 
14                           tyVarsOfTypes, tyVarsOfTheta, 
15                           mkForAllTys, tcCmpType
16                         )
17 import Subst            ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
18                           simplBndr, simplBndrs, 
19                           substAndCloneId, substAndCloneIds, substAndCloneRecIds,
20                           lookupIdSubst, substInScope
21                         ) 
22 import Var              ( zapSpecPragmaId )
23 import VarSet
24 import VarEnv
25 import CoreSyn
26 import CoreUtils        ( applyTypeToArgs )
27 import CoreFVs          ( exprFreeVars, exprsFreeVars )
28 import CoreLint         ( showPass, endPass )
29 import PprCore          ( pprCoreRules )
30 import Rules            ( addIdSpecialisations, lookupRule )
31
32 import UniqSupply       ( UniqSupply,
33                           UniqSM, initUs_, thenUs, returnUs, getUniqueUs, 
34                           getUs, mapUs
35                         )
36 import Name             ( nameOccName, mkSpecOcc, getSrcLoc )
37 import FiniteMap
38 import Maybes           ( catMaybes, maybeToBool )
39 import ErrUtils         ( dumpIfSet_dyn )
40 import BasicTypes       ( Activation( AlwaysActive ) )
41 import Bag
42 import List             ( partition )
43 import Util             ( zipEqual, zipWithEqual, cmpList, lengthIs,
44                           equalLength, lengthAtLeast )
45 import Outputable
46
47
48 infixr 9 `thenSM`
49 \end{code}
50
51 %************************************************************************
52 %*                                                                      *
53 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
54 %*                                                                      *
55 %************************************************************************
56
57 These notes describe how we implement specialisation to eliminate
58 overloading.
59
60 The specialisation pass works on Core
61 syntax, complete with all the explicit dictionary application,
62 abstraction and construction as added by the type checker.  The
63 existing type checker remains largely as it is.
64
65 One important thought: the {\em types} passed to an overloaded
66 function, and the {\em dictionaries} passed are mutually redundant.
67 If the same function is applied to the same type(s) then it is sure to
68 be applied to the same dictionary(s)---or rather to the same {\em
69 values}.  (The arguments might look different but they will evaluate
70 to the same value.)
71
72 Second important thought: we know that we can make progress by
73 treating dictionary arguments as static and worth specialising on.  So
74 we can do without binding-time analysis, and instead specialise on
75 dictionary arguments and no others.
76
77 The basic idea
78 ~~~~~~~~~~~~~~
79 Suppose we have
80
81         let f = <f_rhs>
82         in <body>
83
84 and suppose f is overloaded.
85
86 STEP 1: CALL-INSTANCE COLLECTION
87
88 We traverse <body>, accumulating all applications of f to types and
89 dictionaries.
90
91 (Might there be partial applications, to just some of its types and
92 dictionaries?  In principle yes, but in practice the type checker only
93 builds applications of f to all its types and dictionaries, so partial
94 applications could only arise as a result of transformation, and even
95 then I think it's unlikely.  In any case, we simply don't accumulate such
96 partial applications.)
97
98
99 STEP 2: EQUIVALENCES
100
101 So now we have a collection of calls to f:
102         f t1 t2 d1 d2
103         f t3 t4 d3 d4
104         ...
105 Notice that f may take several type arguments.  To avoid ambiguity, we
106 say that f is called at type t1/t2 and t3/t4.
107
108 We take equivalence classes using equality of the *types* (ignoring
109 the dictionary args, which as mentioned previously are redundant).
110
111 STEP 3: SPECIALISATION
112
113 For each equivalence class, choose a representative (f t1 t2 d1 d2),
114 and create a local instance of f, defined thus:
115
116         f@t1/t2 = <f_rhs> t1 t2 d1 d2
117
118 f_rhs presumably has some big lambdas and dictionary lambdas, so lots
119 of simplification will now result.  However we don't actually *do* that
120 simplification.  Rather, we leave it for the simplifier to do.  If we
121 *did* do it, though, we'd get more call instances from the specialised
122 RHS.  We can work out what they are by instantiating the call-instance
123 set from f's RHS with the types t1, t2.
124
125 Add this new id to f's IdInfo, to record that f has a specialised version.
126
127 Before doing any of this, check that f's IdInfo doesn't already
128 tell us about an existing instance of f at the required type/s.
129 (This might happen if specialisation was applied more than once, or
130 it might arise from user SPECIALIZE pragmas.)
131
132 Recursion
133 ~~~~~~~~~
134 Wait a minute!  What if f is recursive?  Then we can't just plug in
135 its right-hand side, can we?
136
137 But it's ok.  The type checker *always* creates non-recursive definitions
138 for overloaded recursive functions.  For example:
139
140         f x = f (x+x)           -- Yes I know its silly
141
142 becomes
143
144         f a (d::Num a) = let p = +.sel a d
145                          in
146                          letrec fl (y::a) = fl (p y y)
147                          in
148                          fl
149
150 We still have recusion for non-overloaded functions which we
151 speciailise, but the recursive call should get specialised to the
152 same recursive version.
153
154
155 Polymorphism 1
156 ~~~~~~~~~~~~~~
157
158 All this is crystal clear when the function is applied to *constant
159 types*; that is, types which have no type variables inside.  But what if
160 it is applied to non-constant types?  Suppose we find a call of f at type
161 t1/t2.  There are two possibilities:
162
163 (a) The free type variables of t1, t2 are in scope at the definition point
164 of f.  In this case there's no problem, we proceed just as before.  A common
165 example is as follows.  Here's the Haskell:
166
167         g y = let f x = x+x
168               in f y + f y
169
170 After typechecking we have
171
172         g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
173                                 in +.sel a d (f a d y) (f a d y)
174
175 Notice that the call to f is at type type "a"; a non-constant type.
176 Both calls to f are at the same type, so we can specialise to give:
177
178         g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
179                                 in +.sel a d (f@a y) (f@a y)
180
181
182 (b) The other case is when the type variables in the instance types
183 are *not* in scope at the definition point of f.  The example we are
184 working with above is a good case.  There are two instances of (+.sel a d),
185 but "a" is not in scope at the definition of +.sel.  Can we do anything?
186 Yes, we can "common them up", a sort of limited common sub-expression deal.
187 This would give:
188
189         g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
190                                     f@a (x::a) = +.sel@a x x
191                                 in +.sel@a (f@a y) (f@a y)
192
193 This can save work, and can't be spotted by the type checker, because
194 the two instances of +.sel weren't originally at the same type.
195
196 Further notes on (b)
197
198 * There are quite a few variations here.  For example, the defn of
199   +.sel could be floated ouside the \y, to attempt to gain laziness.
200   It certainly mustn't be floated outside the \d because the d has to
201   be in scope too.
202
203 * We don't want to inline f_rhs in this case, because
204 that will duplicate code.  Just commoning up the call is the point.
205
206 * Nothing gets added to +.sel's IdInfo.
207
208 * Don't bother unless the equivalence class has more than one item!
209
210 Not clear whether this is all worth it.  It is of course OK to
211 simply discard call-instances when passing a big lambda.
212
213 Polymorphism 2 -- Overloading
214 ~~~~~~~~~~~~~~
215 Consider a function whose most general type is
216
217         f :: forall a b. Ord a => [a] -> b -> b
218
219 There is really no point in making a version of g at Int/Int and another
220 at Int/Bool, because it's only instancing the type variable "a" which
221 buys us any efficiency. Since g is completely polymorphic in b there
222 ain't much point in making separate versions of g for the different
223 b types.
224
225 That suggests that we should identify which of g's type variables
226 are constrained (like "a") and which are unconstrained (like "b").
227 Then when taking equivalence classes in STEP 2, we ignore the type args
228 corresponding to unconstrained type variable.  In STEP 3 we make
229 polymorphic versions.  Thus:
230
231         f@t1/ = /\b -> <f_rhs> t1 b d1 d2
232
233 We do this.
234
235
236 Dictionary floating
237 ~~~~~~~~~~~~~~~~~~~
238 Consider this
239
240         f a (d::Num a) = let g = ...
241                          in
242                          ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
243
244 Here, g is only called at one type, but the dictionary isn't in scope at the
245 definition point for g.  Usually the type checker would build a
246 definition for d1 which enclosed g, but the transformation system
247 might have moved d1's defn inward.  Solution: float dictionary bindings
248 outwards along with call instances.
249
250 Consider
251
252         f x = let g p q = p==q
253                   h r s = (r+s, g r s)
254               in
255               h x x
256
257
258 Before specialisation, leaving out type abstractions we have
259
260         f df x = let g :: Eq a => a -> a -> Bool
261                      g dg p q = == dg p q
262                      h :: Num a => a -> a -> (a, Bool)
263                      h dh r s = let deq = eqFromNum dh
264                                 in (+ dh r s, g deq r s)
265               in
266               h df x x
267
268 After specialising h we get a specialised version of h, like this:
269
270                     h' r s = let deq = eqFromNum df
271                              in (+ df r s, g deq r s)
272
273 But we can't naively make an instance for g from this, because deq is not in scope
274 at the defn of g.  Instead, we have to float out the (new) defn of deq
275 to widen its scope.  Notice that this floating can't be done in advance -- it only
276 shows up when specialisation is done.
277
278 User SPECIALIZE pragmas
279 ~~~~~~~~~~~~~~~~~~~~~~~
280 Specialisation pragmas can be digested by the type checker, and implemented
281 by adding extra definitions along with that of f, in the same way as before
282
283         f@t1/t2 = <f_rhs> t1 t2 d1 d2
284
285 Indeed the pragmas *have* to be dealt with by the type checker, because
286 only it knows how to build the dictionaries d1 and d2!  For example
287
288         g :: Ord a => [a] -> [a]
289         {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
290
291 Here, the specialised version of g is an application of g's rhs to the
292 Ord dictionary for (Tree Int), which only the type checker can conjure
293 up.  There might not even *be* one, if (Tree Int) is not an instance of
294 Ord!  (All the other specialision has suitable dictionaries to hand
295 from actual calls.)
296
297 Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
298 it is buried in a complex (as-yet-un-desugared) binding group.
299 Maybe we should say
300
301         f@t1/t2 = f* t1 t2 d1 d2
302
303 where f* is the Id f with an IdInfo which says "inline me regardless!".
304 Indeed all the specialisation could be done in this way.
305 That in turn means that the simplifier has to be prepared to inline absolutely
306 any in-scope let-bound thing.
307
308
309 Again, the pragma should permit polymorphism in unconstrained variables:
310
311         h :: Ord a => [a] -> b -> b
312         {-# SPECIALIZE h :: [Int] -> b -> b #-}
313
314 We *insist* that all overloaded type variables are specialised to ground types,
315 (and hence there can be no context inside a SPECIALIZE pragma).
316 We *permit* unconstrained type variables to be specialised to
317         - a ground type
318         - or left as a polymorphic type variable
319 but nothing in between.  So
320
321         {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
322
323 is *illegal*.  (It can be handled, but it adds complication, and gains the
324 programmer nothing.)
325
326
327 SPECIALISING INSTANCE DECLARATIONS
328 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
329 Consider
330
331         instance Foo a => Foo [a] where
332                 ...
333         {-# SPECIALIZE instance Foo [Int] #-}
334
335 The original instance decl creates a dictionary-function
336 definition:
337
338         dfun.Foo.List :: forall a. Foo a -> Foo [a]
339
340 The SPECIALIZE pragma just makes a specialised copy, just as for
341 ordinary function definitions:
342
343         dfun.Foo.List@Int :: Foo [Int]
344         dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
345
346 The information about what instance of the dfun exist gets added to
347 the dfun's IdInfo in the same way as a user-defined function too.
348
349
350 Automatic instance decl specialisation?
351 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
352 Can instance decls be specialised automatically?  It's tricky.
353 We could collect call-instance information for each dfun, but
354 then when we specialised their bodies we'd get new call-instances
355 for ordinary functions; and when we specialised their bodies, we might get
356 new call-instances of the dfuns, and so on.  This all arises because of
357 the unrestricted mutual recursion between instance decls and value decls.
358
359 Still, there's no actual problem; it just means that we may not do all
360 the specialisation we could theoretically do.
361
362 Furthermore, instance decls are usually exported and used non-locally,
363 so we'll want to compile enough to get those specialisations done.
364
365 Lastly, there's no such thing as a local instance decl, so we can
366 survive solely by spitting out *usage* information, and then reading that
367 back in as a pragma when next compiling the file.  So for now,
368 we only specialise instance decls in response to pragmas.
369
370
371 SPITTING OUT USAGE INFORMATION
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
373
374 To spit out usage information we need to traverse the code collecting
375 call-instance information for all imported (non-prelude?) functions
376 and data types. Then we equivalence-class it and spit it out.
377
378 This is done at the top-level when all the call instances which escape
379 must be for imported functions and data types.
380
381 *** Not currently done ***
382
383
384 Partial specialisation by pragmas
385 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
386 What about partial specialisation:
387
388         k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
389         {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
390
391 or even
392
393         {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
394
395 Seems quite reasonable.  Similar things could be done with instance decls:
396
397         instance (Foo a, Foo b) => Foo (a,b) where
398                 ...
399         {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
400         {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
401
402 Ho hum.  Things are complex enough without this.  I pass.
403
404
405 Requirements for the simplifer
406 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
407 The simplifier has to be able to take advantage of the specialisation.
408
409 * When the simplifier finds an application of a polymorphic f, it looks in
410 f's IdInfo in case there is a suitable instance to call instead.  This converts
411
412         f t1 t2 d1 d2   ===>   f_t1_t2
413
414 Note that the dictionaries get eaten up too!
415
416 * Dictionary selection operations on constant dictionaries must be
417   short-circuited:
418
419         +.sel Int d     ===>  +Int
420
421 The obvious way to do this is in the same way as other specialised
422 calls: +.sel has inside it some IdInfo which tells that if it's applied
423 to the type Int then it should eat a dictionary and transform to +Int.
424
425 In short, dictionary selectors need IdInfo inside them for constant
426 methods.
427
428 * Exactly the same applies if a superclass dictionary is being
429   extracted:
430
431         Eq.sel Int d   ===>   dEqInt
432
433 * Something similar applies to dictionary construction too.  Suppose
434 dfun.Eq.List is the function taking a dictionary for (Eq a) to
435 one for (Eq [a]).  Then we want
436
437         dfun.Eq.List Int d      ===> dEq.List_Int
438
439 Where does the Eq [Int] dictionary come from?  It is built in
440 response to a SPECIALIZE pragma on the Eq [a] instance decl.
441
442 In short, dfun Ids need IdInfo with a specialisation for each
443 constant instance of their instance declaration.
444
445 All this uses a single mechanism: the SpecEnv inside an Id
446
447
448 What does the specialisation IdInfo look like?
449 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
450
451 The SpecEnv of an Id maps a list of types (the template) to an expression
452
453         [Type]  |->  Expr
454
455 For example, if f has this SpecInfo:
456
457         [Int, a]  ->  \d:Ord Int. f' a
458
459 it means that we can replace the call
460
461         f Int t  ===>  (\d. f' t)
462
463 This chucks one dictionary away and proceeds with the
464 specialised version of f, namely f'.
465
466
467 What can't be done this way?
468 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
469 There is no way, post-typechecker, to get a dictionary for (say)
470 Eq a from a dictionary for Eq [a].  So if we find
471
472         ==.sel [t] d
473
474 we can't transform to
475
476         eqList (==.sel t d')
477
478 where
479         eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
480
481 Of course, we currently have no way to automatically derive
482 eqList, nor to connect it to the Eq [a] instance decl, but you
483 can imagine that it might somehow be possible.  Taking advantage
484 of this is permanently ruled out.
485
486 Still, this is no great hardship, because we intend to eliminate
487 overloading altogether anyway!
488
489
490
491 A note about non-tyvar dictionaries
492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
493 Some Ids have types like
494
495         forall a,b,c. Eq a -> Ord [a] -> tau
496
497 This seems curious at first, because we usually only have dictionary
498 args whose types are of the form (C a) where a is a type variable.
499 But this doesn't hold for the functions arising from instance decls,
500 which sometimes get arguements with types of form (C (T a)) for some
501 type constructor T.
502
503 Should we specialise wrt this compound-type dictionary?  We used to say
504 "no", saying:
505         "This is a heuristic judgement, as indeed is the fact that we 
506         specialise wrt only dictionaries.  We choose *not* to specialise
507         wrt compound dictionaries because at the moment the only place
508         they show up is in instance decls, where they are simply plugged
509         into a returned dictionary.  So nothing is gained by specialising
510         wrt them."
511
512 But it is simpler and more uniform to specialise wrt these dicts too;
513 and in future GHC is likely to support full fledged type signatures 
514 like
515         f ;: Eq [(a,b)] => ...
516
517
518 %************************************************************************
519 %*                                                                      *
520 \subsubsection{The new specialiser}
521 %*                                                                      *
522 %************************************************************************
523
524 Our basic game plan is this.  For let(rec) bound function
525         f :: (C a, D c) => (a,b,c,d) -> Bool
526
527 * Find any specialised calls of f, (f ts ds), where 
528   ts are the type arguments t1 .. t4, and
529   ds are the dictionary arguments d1 .. d2.
530
531 * Add a new definition for f1 (say):
532
533         f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
534
535   Note that we abstract over the unconstrained type arguments.
536
537 * Add the mapping
538
539         [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
540
541   to the specialisations of f.  This will be used by the
542   simplifier to replace calls 
543                 (f t1 t2 t3 t4) da db
544   by
545                 (\d1 d1 -> f1 t2 t4) da db
546
547   All the stuff about how many dictionaries to discard, and what types
548   to apply the specialised function to, are handled by the fact that the
549   SpecEnv contains a template for the result of the specialisation.
550
551 We don't build *partial* specialisations for f.  For example:
552
553   f :: Eq a => a -> a -> Bool
554   {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
555
556 Here, little is gained by making a specialised copy of f.
557 There's a distinct danger that the specialised version would
558 first build a dictionary for (Eq b, Eq c), and then select the (==) 
559 method from it!  Even if it didn't, not a great deal is saved.
560
561 We do, however, generate polymorphic, but not overloaded, specialisations:
562
563   f :: Eq a => [a] -> b -> b -> b
564   {#- SPECIALISE f :: [Int] -> b -> b -> b #-}
565
566 Hence, the invariant is this: 
567
568         *** no specialised version is overloaded ***
569
570
571 %************************************************************************
572 %*                                                                      *
573 \subsubsection{The exported function}
574 %*                                                                      *
575 %************************************************************************
576
577 \begin{code}
578 specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
579 specProgram dflags us binds
580   = do
581         showPass dflags "Specialise"
582
583         let binds' = initSM us (go binds        `thenSM` \ (binds', uds') ->
584                                 returnSM (dumpAllDictBinds uds' binds'))
585
586         endPass dflags "Specialise" Opt_D_dump_spec binds'
587
588         dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
589                   (vcat (map dump_specs (concat (map bindersOf binds'))))
590
591         return binds'
592   where
593         -- We need to start with a Subst that knows all the things
594         -- that are in scope, so that the substitution engine doesn't
595         -- accidentally re-use a unique that's already in use
596         -- Easiest thing is to do it all at once, as if all the top-level
597         -- decls were mutually recursive
598     top_subst       = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
599
600     go []           = returnSM ([], emptyUDs)
601     go (bind:binds) = go binds                          `thenSM` \ (binds', uds) ->
602                       specBind top_subst bind uds       `thenSM` \ (bind', uds') ->
603                       returnSM (bind' ++ binds', uds')
604
605 dump_specs var = pprCoreRules var (idSpecialisation var)
606 \end{code}
607
608 %************************************************************************
609 %*                                                                      *
610 \subsubsection{@specExpr@: the main function}
611 %*                                                                      *
612 %************************************************************************
613
614 \begin{code}
615 specVar :: Subst -> Id -> CoreExpr
616 specVar subst v = case lookupIdSubst subst v of
617                         DoneEx e   -> e
618                         DoneId v _ -> Var v
619
620 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
621 -- We carry a substitution down:
622 --      a) we must clone any binding that might flaot outwards,
623 --         to avoid name clashes
624 --      b) we carry a type substitution to use when analysing
625 --         the RHS of specialised bindings (no type-let!)
626
627 ---------------- First the easy cases --------------------
628 specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
629 specExpr subst (Var v)   = returnSM (specVar subst v,         emptyUDs)
630 specExpr subst (Lit lit) = returnSM (Lit lit,                 emptyUDs)
631
632 specExpr subst (Note note body)
633   = specExpr subst body         `thenSM` \ (body', uds) ->
634     returnSM (Note (specNote subst note) body', uds)
635
636
637 ---------------- Applications might generate a call instance --------------------
638 specExpr subst expr@(App fun arg)
639   = go expr []
640   where
641     go (App fun arg) args = specExpr subst arg  `thenSM` \ (arg', uds_arg) ->
642                             go fun (arg':args)  `thenSM` \ (fun', uds_app) ->
643                             returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
644
645     go (Var f)       args = case specVar subst f of
646                                 Var f' -> returnSM (Var f', mkCallUDs subst f' args)
647                                 e'     -> returnSM (e', emptyUDs)       -- I don't expect this!
648     go other         args = specExpr subst other
649
650 ---------------- Lambda/case require dumping of usage details --------------------
651 specExpr subst e@(Lam _ _)
652   = specExpr subst' body        `thenSM` \ (body', uds) ->
653     let
654         (filtered_uds, body'') = dumpUDs bndrs' uds body'
655     in
656     returnSM (mkLams bndrs' body'', filtered_uds)
657   where
658     (bndrs, body) = collectBinders e
659     (subst', bndrs') = simplBndrs subst bndrs
660         -- More efficient to collect a group of binders together all at once
661         -- and we don't want to split a lambda group with dumped bindings
662
663 specExpr subst (Case scrut case_bndr alts)
664   = specExpr subst scrut                        `thenSM` \ (scrut', uds_scrut) ->
665     mapAndCombineSM spec_alt alts       `thenSM` \ (alts', uds_alts) ->
666     returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
667   where
668     (subst_alt, case_bndr') = simplBndr subst case_bndr
669         -- No need to clone case binder; it can't float like a let(rec)
670
671     spec_alt (con, args, rhs)
672         = specExpr subst_rhs rhs                `thenSM` \ (rhs', uds) ->
673           let
674              (uds', rhs'') = dumpUDs args uds rhs'
675           in
676           returnSM ((con, args', rhs''), uds')
677         where
678           (subst_rhs, args') = simplBndrs subst_alt args
679
680 ---------------- Finally, let is the interesting case --------------------
681 specExpr subst (Let bind body)
682   =     -- Clone binders
683     cloneBindSM subst bind                      `thenSM` \ (rhs_subst, body_subst, bind') ->
684         
685         -- Deal with the body
686     specExpr body_subst body                    `thenSM` \ (body', body_uds) ->
687
688         -- Deal with the bindings
689     specBind rhs_subst bind' body_uds           `thenSM` \ (binds', uds) ->
690
691         -- All done
692     returnSM (foldr Let body' binds', uds)
693
694 -- Must apply the type substitution to coerceions
695 specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)
696 specNote subst note           = note
697 \end{code}
698
699 %************************************************************************
700 %*                                                                      *
701 \subsubsection{Dealing with a binding}
702 %*                                                                      *
703 %************************************************************************
704
705 \begin{code}
706 specBind :: Subst                       -- Use this for RHSs
707          -> CoreBind
708          -> UsageDetails                -- Info on how the scope of the binding
709          -> SpecM ([CoreBind],          -- New bindings
710                    UsageDetails)        -- And info to pass upstream
711
712 specBind rhs_subst bind body_uds
713   = specBindItself rhs_subst bind (calls body_uds)      `thenSM` \ (bind', bind_uds) ->
714     let
715         bndrs   = bindersOf bind
716         all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
717                         -- It's important that the `plusUDs` is this way round,
718                         -- because body_uds may bind dictionaries that are
719                         -- used in the calls passed to specDefn.  So the
720                         -- dictionary bindings in bind_uds may mention 
721                         -- dictionaries bound in body_uds.
722     in
723     case splitUDs bndrs all_uds of
724
725         (_, ([],[]))    -- This binding doesn't bind anything needed
726                         -- in the UDs, so put the binding here
727                         -- This is the case for most non-dict bindings, except
728                         -- for the few that are mentioned in a dict binding
729                         -- that is floating upwards in body_uds
730                 -> returnSM ([bind'], all_uds)
731
732         (float_uds, (dict_binds, calls))        -- This binding is needed in the UDs, so float it out
733                 -> returnSM ([], float_uds `plusUDs` mkBigUD bind' dict_binds calls)
734    
735
736 -- A truly gruesome function
737 mkBigUD bind@(NonRec _ _) dbs calls
738   =     -- Common case: non-recursive and no specialisations
739         -- (if there were any specialistions it would have been made recursive)
740     MkUD { dict_binds = listToBag (mkDB bind : dbs),
741            calls = listToCallDetails calls }
742
743 mkBigUD bind dbs calls
744   =     -- General case
745     MkUD { dict_binds = unitBag (mkDB (Rec (bind_prs bind ++ dbsToPairs dbs))),
746                         -- Make a huge Rec
747            calls = listToCallDetails calls }
748   where
749     bind_prs (NonRec b r) = [(b,r)]
750     bind_prs (Rec prs)    = prs
751
752     dbsToPairs []             = []
753     dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
754
755 -- specBindItself deals with the RHS, specialising it according
756 -- to the calls found in the body (if any)
757 specBindItself rhs_subst (NonRec bndr rhs) call_info
758   = specDefn rhs_subst call_info (bndr,rhs)     `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
759     let
760         new_bind | null spec_defns = NonRec bndr' rhs'
761                  | otherwise       = Rec ((bndr',rhs'):spec_defns)
762                 -- bndr' mentions the spec_defns in its SpecEnv
763                 -- Not sure why we couln't just put the spec_defns first
764     in
765     returnSM (new_bind, spec_uds)
766
767 specBindItself rhs_subst (Rec pairs) call_info
768   = mapSM (specDefn rhs_subst call_info) pairs  `thenSM` \ stuff ->
769     let
770         (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
771         spec_defns = concat spec_defns_s
772         spec_uds   = plusUDList spec_uds_s
773         new_bind   = Rec (spec_defns ++ pairs')
774     in
775     returnSM (new_bind, spec_uds)
776     
777
778 specDefn :: Subst                       -- Subst to use for RHS
779          -> CallDetails                 -- Info on how it is used in its scope
780          -> (Id, CoreExpr)              -- The thing being bound and its un-processed RHS
781          -> SpecM ((Id, CoreExpr),      -- The thing and its processed RHS
782                                         --      the Id may now have specialisations attached
783                    [(Id,CoreExpr)],     -- Extra, specialised bindings
784                    UsageDetails         -- Stuff to fling upwards from the RHS and its
785             )                           --      specialised versions
786
787 specDefn subst calls (fn, rhs)
788         -- The first case is the interesting one
789   |  rhs_tyvars `lengthIs` n_tyvars     -- Rhs of fn's defn has right number of big lambdas
790   && rhs_bndrs  `lengthAtLeast` n_dicts -- and enough dict args
791   && not (null calls_for_me)            -- And there are some calls to specialise
792   && not (isDataConWrapId fn)           -- And it's not a data con wrapper, which have
793                                         -- stupid overloading that simply discard the dictionary
794
795 -- At one time I tried not specialising small functions
796 -- but sometimes there are big functions marked INLINE
797 -- that we'd like to specialise.  In particular, dictionary
798 -- functions, which Marcin is keen to inline
799 --  && not (certainlyWillInline fn)     -- And it's not small
800                                         -- If it's small, it's better just to inline
801                                         -- it than to construct lots of specialisations
802   =   -- Specialise the body of the function
803     specExpr subst rhs                                  `thenSM` \ (rhs', rhs_uds) ->
804
805       -- Make a specialised version for each call in calls_for_me
806     mapSM spec_call calls_for_me                `thenSM` \ stuff ->
807     let
808         (spec_defns, spec_uds, spec_rules) = unzip3 stuff
809
810         fn' = addIdSpecialisations zapped_fn spec_rules
811     in
812     returnSM ((fn',rhs'), 
813               spec_defns, 
814               rhs_uds `plusUDs` plusUDList spec_uds)
815
816   | otherwise   -- No calls or RHS doesn't fit our preconceptions
817   = specExpr subst rhs                  `thenSM` \ (rhs', rhs_uds) ->
818     returnSM ((zapped_fn, rhs'), [], rhs_uds)
819   
820   where
821     zapped_fn            = zapSpecPragmaId fn
822         -- If the fn is a SpecPragmaId, make it discardable
823         -- It's role as a holder for a call instance is o'er
824         -- But it might be alive for some other reason by now.
825
826     fn_type            = idType fn
827     (tyvars, theta, _) = tcSplitSigmaTy fn_type
828     n_tyvars           = length tyvars
829     n_dicts            = length theta
830
831         -- It's important that we "see past" any INLINE pragma
832         -- else we'll fail to specialise an INLINE thing
833     (inline_me, rhs')               = dropInline rhs
834     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs'
835
836     rhs_dicts = take n_dicts rhs_ids
837     rhs_bndrs = rhs_tyvars ++ rhs_dicts
838     body      = mkLams (drop n_dicts rhs_ids) rhs_body
839                 -- Glue back on the non-dict lambdas
840
841     calls_for_me = case lookupFM calls fn of
842                         Nothing -> []
843                         Just cs -> fmToList cs
844
845     ----------------------------------------------------------
846         -- Specialise to one particular call pattern
847     spec_call :: (CallKey, ([DictExpr], VarSet))        -- Call instance
848               -> SpecM ((Id,CoreExpr),                  -- Specialised definition
849                         UsageDetails,                   -- Usage details from specialised body
850                         CoreRule)                       -- Info for the Id's SpecEnv
851     spec_call (CallKey call_ts, (call_ds, call_fvs))
852       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
853                 -- Calls are only recorded for properly-saturated applications
854         
855         -- Suppose f's defn is  f = /\ a b c d -> \ d1 d2 -> rhs        
856         -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [dx1, dx2]
857
858         -- Construct the new binding
859         --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs)
860         -- PLUS the usage-details
861         --      { d1' = dx1; d2' = dx2 }
862         -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied.
863         --
864         -- Note that the substitution is applied to the whole thing.
865         -- This is convenient, but just slightly fragile.  Notably:
866         --      * There had better be no name clashes in a/b/c/d
867         --
868         let
869                 -- poly_tyvars = [b,d] in the example above
870                 -- spec_tyvars = [a,c] 
871                 -- ty_args     = [t1,b,t3,d]
872            poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
873            spec_tyvars = [tv | (tv, Just _)  <- rhs_tyvars `zip` call_ts]
874            ty_args     = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
875                        where
876                          mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
877                          mk_ty_arg rhs_tyvar (Just ty) = Type ty
878            rhs_subst  = extendSubstList subst spec_tyvars [DoneTy ty | Just ty <- call_ts]
879         in
880         cloneBinders rhs_subst rhs_dicts                `thenSM` \ (rhs_subst', rhs_dicts') ->
881         let
882            inst_args = ty_args ++ map Var rhs_dicts'
883
884                 -- Figure out the type of the specialised function
885            spec_id_ty = mkForAllTys poly_tyvars (applyTypeToArgs rhs fn_type inst_args)
886         in
887         newIdSM fn spec_id_ty                           `thenSM` \ spec_f ->
888         specExpr rhs_subst' (mkLams poly_tyvars body)   `thenSM` \ (spec_rhs, rhs_uds) ->       
889         let
890                 -- The rule to put in the function's specialisation is:
891                 --      forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
892            spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
893                                 AlwaysActive
894                                 (poly_tyvars ++ rhs_dicts')
895                                 inst_args 
896                                 (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
897
898                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
899            final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
900
901         -- NOTE: we don't add back in any INLINE pragma on the RHS, so even if
902         -- the original function said INLINE, the specialised copies won't.
903         -- The idea is that the point of inlining was precisely to specialise
904         -- the function at its call site, and that's not so important for the
905         -- specialised copies.   But it still smells like an ad hoc decision.
906
907         in
908         returnSM ((spec_f, spec_rhs),   
909                   final_uds,
910                   spec_env_rule)
911
912       where
913         my_zipEqual doc xs ys 
914          | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
915          | otherwise               = zipEqual doc xs ys
916
917 dropInline :: CoreExpr -> (Bool, CoreExpr) 
918 dropInline (Note InlineMe rhs) = (True, rhs)
919 dropInline rhs                 = (False, rhs)
920 \end{code}
921
922 %************************************************************************
923 %*                                                                      *
924 \subsubsection{UsageDetails and suchlike}
925 %*                                                                      *
926 %************************************************************************
927
928 \begin{code}
929 data UsageDetails 
930   = MkUD {
931         dict_binds :: !(Bag DictBind),
932                         -- Floated dictionary bindings
933                         -- The order is important; 
934                         -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
935                         -- (Remember, Bags preserve order in GHC.)
936
937         calls     :: !CallDetails
938     }
939
940 type DictBind = (CoreBind, VarSet)
941         -- The set is the free vars of the binding
942         -- both tyvars and dicts
943
944 type DictExpr = CoreExpr
945
946 emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
947
948 type ProtoUsageDetails = ([DictBind],
949                           [(Id, CallKey, ([DictExpr], VarSet))]
950                          )
951
952 ------------------------------------------------------------                    
953 type CallDetails  = FiniteMap Id CallInfo
954 newtype CallKey   = CallKey [Maybe Type]                        -- Nothing => unconstrained type argument
955 type CallInfo     = FiniteMap CallKey
956                               ([DictExpr], VarSet)              -- Dict args and the vars of the whole
957                                                                 -- call (including tyvars)
958                                                                 -- [*not* include the main id itself, of course]
959         -- The finite maps eliminate duplicates
960         -- The list of types and dictionaries is guaranteed to
961         -- match the type of f
962
963 -- Type isn't an instance of Ord, so that we can control which
964 -- instance we use.  That's tiresome here.  Oh well
965 instance Eq CallKey where
966   k1 == k2 = case k1 `compare` k2 of { EQ -> True; other -> False }
967
968 instance Ord CallKey where
969   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
970                 where
971                   cmp Nothing Nothing     = EQ
972                   cmp Nothing (Just t2)   = LT
973                   cmp (Just t1) Nothing   = GT
974                   cmp (Just t1) (Just t2) = tcCmpType t1 t2
975
976 unionCalls :: CallDetails -> CallDetails -> CallDetails
977 unionCalls c1 c2 = plusFM_C plusFM c1 c2
978
979 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
980 singleCall id tys dicts 
981   = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
982   where
983     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
984     tys_fvs  = tyVarsOfTypes (catMaybes tys)
985         -- The type args (tys) are guaranteed to be part of the dictionary
986         -- types, because they are just the constrained types,
987         -- and the dictionary is therefore sure to be bound
988         -- inside the binding for any type variables free in the type;
989         -- hence it's safe to neglect tyvars free in tys when making
990         -- the free-var set for this call
991         -- BUT I don't trust this reasoning; play safe and include tys_fvs
992         --
993         -- We don't include the 'id' itself.
994
995 listToCallDetails calls
996   = foldr (unionCalls . mk_call) emptyFM calls
997   where
998     mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs)
999         -- NB: the free vars of the call are provided
1000
1001 callDetailsToList calls = [ (id,tys,dicts)
1002                           | (id,fm) <- fmToList calls,
1003                             (tys, dicts) <- fmToList fm
1004                           ]
1005
1006 mkCallUDs subst f args 
1007   | null theta
1008   || not (spec_tys `lengthIs` n_tyvars)
1009   || not ( dicts   `lengthIs` n_dicts)
1010   || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
1011         -- There's already a rule covering this call.  A typical case
1012         -- is where there's an explicit user-provided rule.  Then
1013         -- we don't want to create a specialised version 
1014         -- of the function that overlaps.
1015   = emptyUDs    -- Not overloaded, or no specialisation wanted
1016
1017   | otherwise
1018   = MkUD {dict_binds = emptyBag, 
1019           calls      = singleCall f spec_tys dicts
1020     }
1021   where
1022     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
1023     constrained_tyvars = tyVarsOfTheta theta 
1024     n_tyvars           = length tyvars
1025     n_dicts            = length theta
1026
1027     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
1028     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
1029     
1030     mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
1031                         = Just ty
1032                         | otherwise
1033                         = Nothing
1034
1035 ------------------------------------------------------------                    
1036 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
1037 plusUDs (MkUD {dict_binds = db1, calls = calls1})
1038         (MkUD {dict_binds = db2, calls = calls2})
1039   = MkUD {dict_binds = d, calls = c}
1040   where
1041     d = db1    `unionBags`   db2 
1042     c = calls1 `unionCalls`  calls2
1043
1044 plusUDList = foldr plusUDs emptyUDs
1045
1046 -- zapCalls deletes calls to ids from uds
1047 zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
1048
1049 mkDB bind = (bind, bind_fvs bind)
1050
1051 bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
1052 bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
1053                            where
1054                              bndrs = map fst prs
1055                              rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
1056
1057 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
1058
1059 dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
1060   = foldrBag add binds dbs
1061   where
1062     add (bind,_) binds = bind : binds
1063
1064 dumpUDs :: [CoreBndr]
1065         -> UsageDetails -> CoreExpr
1066         -> (UsageDetails, CoreExpr)
1067 dumpUDs bndrs uds body
1068   = (free_uds, foldr add_let body dict_binds)
1069   where
1070     (free_uds, (dict_binds, _)) = splitUDs bndrs uds
1071     add_let (bind,_) body       = Let bind body
1072
1073 splitUDs :: [CoreBndr]
1074          -> UsageDetails
1075          -> (UsageDetails,              -- These don't mention the binders
1076              ProtoUsageDetails)         -- These do
1077              
1078 splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs, 
1079                           calls      = orig_calls})
1080
1081   = if isEmptyBag dump_dbs && null dump_calls then
1082         -- Common case: binder doesn't affect floats
1083         (uds, ([],[]))  
1084
1085     else
1086         -- Binders bind some of the fvs of the floats
1087         (MkUD {dict_binds = free_dbs, 
1088                calls      = listToCallDetails free_calls},
1089          (bagToList dump_dbs, dump_calls)
1090         )
1091
1092   where
1093     bndr_set = mkVarSet bndrs
1094
1095     (free_dbs, dump_dbs, dump_idset) 
1096           = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
1097                 -- Important that it's foldl not foldr;
1098                 -- we're accumulating the set of dumped ids in dump_set
1099
1100         -- Filter out any calls that mention things that are being dumped
1101     orig_call_list                 = callDetailsToList orig_calls
1102     (dump_calls, free_calls)       = partition captured orig_call_list
1103     captured (id,tys,(dicts, fvs)) =  fvs `intersectsVarSet` dump_idset
1104                                    || id `elemVarSet` dump_idset
1105
1106     dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
1107         | dump_idset `intersectsVarSet` fvs     -- Dump it
1108         = (free_dbs, dump_dbs `snocBag` db,
1109            dump_idset `unionVarSet` mkVarSet (bindersOf bind))
1110
1111         | otherwise     -- Don't dump it
1112         = (free_dbs `snocBag` db, dump_dbs, dump_idset)
1113 \end{code}
1114
1115
1116 %************************************************************************
1117 %*                                                                      *
1118 \subsubsection{Boring helper functions}
1119 %*                                                                      *
1120 %************************************************************************
1121
1122 \begin{code}
1123 type SpecM a = UniqSM a
1124
1125 thenSM    = thenUs
1126 returnSM  = returnUs
1127 getUniqSM = getUniqueUs
1128 mapSM     = mapUs
1129 initSM    = initUs_
1130
1131 mapAndCombineSM f []     = returnSM ([], emptyUDs)
1132 mapAndCombineSM f (x:xs) = f x  `thenSM` \ (y, uds1) ->
1133                            mapAndCombineSM f xs `thenSM` \ (ys, uds2) ->
1134                            returnSM (y:ys, uds1 `plusUDs` uds2)
1135
1136 cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
1137 -- Clone the binders of the bind; return new bind with the cloned binders
1138 -- Return the substitution to use for RHSs, and the one to use for the body
1139 cloneBindSM subst (NonRec bndr rhs)
1140   = getUs       `thenUs` \ us ->
1141     let
1142         (subst', bndr') = substAndCloneId subst us bndr
1143     in
1144     returnUs (subst, subst', NonRec bndr' rhs)
1145
1146 cloneBindSM subst (Rec pairs)
1147   = getUs       `thenUs` \ us ->
1148     let
1149         (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs)
1150     in
1151     returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
1152
1153 cloneBinders subst bndrs
1154   = getUs       `thenUs` \ us ->
1155     returnUs (substAndCloneIds subst us bndrs)
1156
1157 newIdSM old_id new_ty
1158   = getUniqSM           `thenSM` \ uniq ->
1159     let 
1160         -- Give the new Id a similar occurrence name to the old one
1161         name   = idName old_id
1162         new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
1163     in
1164     returnSM new_id
1165 \end{code}
1166
1167
1168                 Old (but interesting) stuff about unboxed bindings
1169                 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1170
1171 What should we do when a value is specialised to a *strict* unboxed value?
1172
1173         map_*_* f (x:xs) = let h = f x
1174                                t = map f xs
1175                            in h:t
1176
1177 Could convert let to case:
1178
1179         map_*_Int# f (x:xs) = case f x of h# ->
1180                               let t = map f xs
1181                               in h#:t
1182
1183 This may be undesirable since it forces evaluation here, but the value
1184 may not be used in all branches of the body. In the general case this
1185 transformation is impossible since the mutual recursion in a letrec
1186 cannot be expressed as a case.
1187
1188 There is also a problem with top-level unboxed values, since our
1189 implementation cannot handle unboxed values at the top level.
1190
1191 Solution: Lift the binding of the unboxed value and extract it when it
1192 is used:
1193
1194         map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
1195                                   t = map f xs
1196                               in case h of
1197                                  _Lift h# -> h#:t
1198
1199 Now give it to the simplifier and the _Lifting will be optimised away.
1200
1201 The benfit is that we have given the specialised "unboxed" values a
1202 very simplep lifted semantics and then leave it up to the simplifier to
1203 optimise it --- knowing that the overheads will be removed in nearly
1204 all cases.
1205
1206 In particular, the value will only be evaluted in the branches of the
1207 program which use it, rather than being forced at the point where the
1208 value is bound. For example:
1209
1210         filtermap_*_* p f (x:xs)
1211           = let h = f x
1212                 t = ...
1213             in case p x of
1214                 True  -> h:t
1215                 False -> t
1216    ==>
1217         filtermap_*_Int# p f (x:xs)
1218           = let h = case (f x) of h# -> _Lift h#
1219                 t = ...
1220             in case p x of
1221                 True  -> case h of _Lift h#
1222                            -> h#:t
1223                 False -> t
1224
1225 The binding for h can still be inlined in the one branch and the
1226 _Lifting eliminated.
1227
1228
1229 Question: When won't the _Lifting be eliminated?
1230
1231 Answer: When they at the top-level (where it is necessary) or when
1232 inlining would duplicate work (or possibly code depending on
1233 options). However, the _Lifting will still be eliminated if the
1234 strictness analyser deems the lifted binding strict.
1235