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