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 )
  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 CoreUnfold       ( certainlyWillInline )
  28 import CoreFVs          ( exprFreeVars, exprsFreeVars )
  29 import CoreLint         ( showPass, endPass )
  30 import PprCore          ( pprCoreRules )
  31 import Rules            ( addIdSpecialisations, lookupRule )
  32
  33 import UniqSupply       ( UniqSupply,
  34                           UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
  35                           getUs, mapUs
  36                         )
  37 import Name             ( nameOccName, mkSpecOcc, getSrcLoc )
  38 import FiniteMap
  39 import Maybes           ( catMaybes, maybeToBool )
  40 import ErrUtils         ( dumpIfSet_dyn )
  41 import Bag
  42 import List             ( partition )
  43 import Util             ( zipEqual, zipWithEqual, cmpList )
  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 :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
 578 specProgram dflags us binds
 579   = do
 580         showPass dflags "Specialise"
 581
 582         let binds' = initSM us (go binds        `thenSM` \ (binds', uds') ->
 583                                 returnSM (dumpAllDictBinds uds' binds'))
 584
 585         endPass dflags "Specialise" Opt_D_dump_spec binds'
 586
 587         dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
 588                   (vcat (map dump_specs (concat (map bindersOf binds'))))
 589
 590         return binds'
 591   where
 592         -- We need to start with a Subst that knows all the things
 593         -- that are in scope, so that the substitution engine doesn't
 594         -- accidentally re-use a unique that's already in use
 595         -- Easiest thing is to do it all at once, as if all the top-level
 596         -- decls were mutually recursive
 597     top_subst       = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
 598
 599     go []           = returnSM ([], emptyUDs)
 600     go (bind:binds) = go binds                          `thenSM` \ (binds', uds) ->
 601                       specBind top_subst bind uds       `thenSM` \ (bind', uds') ->
 602                       returnSM (bind' ++ binds', uds')
 603
 604 dump_specs var = pprCoreRules var (idSpecialisation var)
 605 \end{code}
 606
 607 %************************************************************************
 608 %*                                                                      *
 609 \subsubsection{@specExpr@: the main function}
 610 %*                                                                      *
 611 %************************************************************************
 612
 613 \begin{code}
 614 specVar :: Subst -> Id -> CoreExpr
 615 specVar subst v = case lookupIdSubst subst v of
 616                         DoneEx e   -> e
 617                         DoneId v _ -> Var v
 618
 619 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 620 -- We carry a substitution down:
 621 --      a) we must clone any binding that might flaot outwards,
 622 --         to avoid name clashes
 623 --      b) we carry a type substitution to use when analysing
 624 --         the RHS of specialised bindings (no type-let!)
 625
 626 ---------------- First the easy cases --------------------
 627 specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
 628 specExpr subst (Var v)   = returnSM (specVar subst v,         emptyUDs)
 629 specExpr subst (Lit lit) = returnSM (Lit lit,                 emptyUDs)
 630
 631 specExpr subst (Note note body)
 632   = specExpr subst body         `thenSM` \ (body', uds) ->
 633     returnSM (Note (specNote subst note) body', uds)
 634
 635
 636 ---------------- Applications might generate a call instance --------------------
 637 specExpr subst expr@(App fun arg)
 638   = go expr []
 639   where
 640     go (App fun arg) args = specExpr subst arg  `thenSM` \ (arg', uds_arg) ->
 641                             go fun (arg':args)  `thenSM` \ (fun', uds_app) ->
 642                             returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
 643
 644     go (Var f)       args = case specVar subst f of
 645                                 Var f' -> returnSM (Var f', mkCallUDs subst f' args)
 646                                 e'     -> returnSM (e', emptyUDs)       -- I don't expect this!
 647     go other         args = specExpr subst other
 648
 649 ---------------- Lambda/case require dumping of usage details --------------------
 650 specExpr subst e@(Lam _ _)
 651   = specExpr subst' body        `thenSM` \ (body', uds) ->
 652     let
 653         (filtered_uds, body'') = dumpUDs bndrs' uds body'
 654     in
 655     returnSM (mkLams bndrs' body'', filtered_uds)
 656   where
 657     (bndrs, body) = collectBinders e
 658     (subst', bndrs') = simplBndrs subst bndrs
 659         -- More efficient to collect a group of binders together all at once
 660         -- and we don't want to split a lambda group with dumped bindings
 661
 662 specExpr subst (Case scrut case_bndr alts)
 663   = specExpr subst scrut                        `thenSM` \ (scrut', uds_scrut) ->
 664     mapAndCombineSM spec_alt alts       `thenSM` \ (alts', uds_alts) ->
 665     returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
 666   where
 667     (subst_alt, case_bndr') = simplBndr subst case_bndr
 668         -- No need to clone case binder; it can't float like a let(rec)
 669
 670     spec_alt (con, args, rhs)
 671         = specExpr subst_rhs rhs                `thenSM` \ (rhs', uds) ->
 672           let
 673              (uds', rhs'') = dumpUDs args uds rhs'
 674           in
 675           returnSM ((con, args', rhs''), uds')
 676         where
 677           (subst_rhs, args') = simplBndrs subst_alt args
 678
 679 ---------------- Finally, let is the interesting case --------------------
 680 specExpr subst (Let bind body)
 681   =     -- Clone binders
 682     cloneBindSM subst bind                      `thenSM` \ (rhs_subst, body_subst, bind') ->
 683
 684         -- Deal with the body
 685     specExpr body_subst body                    `thenSM` \ (body', body_uds) ->
 686
 687         -- Deal with the bindings
 688     specBind rhs_subst bind' body_uds           `thenSM` \ (binds', uds) ->
 689
 690         -- All done
 691     returnSM (foldr Let body' binds', uds)
 692
 693 -- Must apply the type substitution to coerceions
 694 specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)
 695 specNote subst note           = note
 696 \end{code}
 697
 698 %************************************************************************
 699 %*                                                                      *
 700 \subsubsection{Dealing with a binding}
 701 %*                                                                      *
 702 %************************************************************************
 703
 704 \begin{code}
 705 specBind :: Subst                       -- Use this for RHSs
 706          -> CoreBind
 707          -> UsageDetails                -- Info on how the scope of the binding
 708          -> SpecM ([CoreBind],          -- New bindings
 709                    UsageDetails)        -- And info to pass upstream
 710
 711 specBind rhs_subst bind body_uds
 712   = specBindItself rhs_subst bind (calls body_uds)      `thenSM` \ (bind', bind_uds) ->
 713     let
 714         bndrs   = bindersOf bind
 715         all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
 716                         -- It's important that the `plusUDs` is this way round,
 717                         -- because body_uds may bind dictionaries that are
 718                         -- used in the calls passed to specDefn.  So the
 719                         -- dictionary bindings in bind_uds may mention
 720                         -- dictionaries bound in body_uds.
 721     in
 722     case splitUDs bndrs all_uds of
 723
 724         (_, ([],[]))    -- This binding doesn't bind anything needed
 725                         -- in the UDs, so put the binding here
 726                         -- This is the case for most non-dict bindings, except
 727                         -- for the few that are mentioned in a dict binding
 728                         -- that is floating upwards in body_uds
 729                 -> returnSM ([bind'], all_uds)
 730
 731         (float_uds, (dict_binds, calls))        -- This binding is needed in the UDs, so float it out
 732                 -> returnSM ([], float_uds `plusUDs` mkBigUD bind' dict_binds calls)
 733
 734
 735 -- A truly gruesome function
 736 mkBigUD bind@(NonRec _ _) dbs calls
 737   =     -- Common case: non-recursive and no specialisations
 738         -- (if there were any specialistions it would have been made recursive)
 739     MkUD { dict_binds = listToBag (mkDB bind : dbs),
 740            calls = listToCallDetails calls }
 741
 742 mkBigUD bind dbs calls
 743   =     -- General case
 744     MkUD { dict_binds = unitBag (mkDB (Rec (bind_prs bind ++ dbsToPairs dbs))),
 745                         -- Make a huge Rec
 746            calls = listToCallDetails calls }
 747   where
 748     bind_prs (NonRec b r) = [(b,r)]
 749     bind_prs (Rec prs)    = prs
 750
 751     dbsToPairs []             = []
 752     dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
 753
 754 -- specBindItself deals with the RHS, specialising it according
 755 -- to the calls found in the body (if any)
 756 specBindItself rhs_subst (NonRec bndr rhs) call_info
 757   = specDefn rhs_subst call_info (bndr,rhs)     `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
 758     let
 759         new_bind | null spec_defns = NonRec bndr' rhs'
 760                  | otherwise       = Rec ((bndr',rhs'):spec_defns)
 761                 -- bndr' mentions the spec_defns in its SpecEnv
 762                 -- Not sure why we couln't just put the spec_defns first
 763     in
 764     returnSM (new_bind, spec_uds)
 765
 766 specBindItself rhs_subst (Rec pairs) call_info
 767   = mapSM (specDefn rhs_subst call_info) pairs  `thenSM` \ stuff ->
 768     let
 769         (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
 770         spec_defns = concat spec_defns_s
 771         spec_uds   = plusUDList spec_uds_s
 772         new_bind   = Rec (spec_defns ++ pairs')
 773     in
 774     returnSM (new_bind, spec_uds)
 775
 776
 777 specDefn :: Subst                       -- Subst to use for RHS
 778          -> CallDetails                 -- Info on how it is used in its scope
 779          -> (Id, CoreExpr)              -- The thing being bound and its un-processed RHS
 780          -> SpecM ((Id, CoreExpr),      -- The thing and its processed RHS
 781                                         --      the Id may now have specialisations attached
 782                    [(Id,CoreExpr)],     -- Extra, specialised bindings
 783                    UsageDetails         -- Stuff to fling upwards from the RHS and its
 784             )                           --      specialised versions
 785
 786 specDefn subst calls (fn, rhs)
 787         -- The first case is the interesting one
 788   |  n_tyvars == length rhs_tyvars      -- Rhs of fn's defn has right number of big lambdas
 789   && n_dicts  <= length rhs_bndrs       -- and enough dict args
 790   && not (null calls_for_me)            -- And there are some calls to specialise
 791   && not (certainlyWillInline fn)       -- And it's not small
 792                                         -- If it's small, it's better just to inline
 793                                         -- it than to construct lots of specialisations
 794   =   -- Specialise the body of the function
 795     specExpr subst rhs                                  `thenSM` \ (rhs', rhs_uds) ->
 796
 797       -- Make a specialised version for each call in calls_for_me
 798     mapSM spec_call calls_for_me                `thenSM` \ stuff ->
 799     let
 800         (spec_defns, spec_uds, spec_rules) = unzip3 stuff
 801
 802         fn' = addIdSpecialisations zapped_fn spec_rules
 803     in
 804     returnSM ((fn',rhs'),
 805               spec_defns,
 806               rhs_uds `plusUDs` plusUDList spec_uds)
 807
 808   | otherwise   -- No calls or RHS doesn't fit our preconceptions
 809   = specExpr subst rhs                  `thenSM` \ (rhs', rhs_uds) ->
 810     returnSM ((zapped_fn, rhs'), [], rhs_uds)
 811
 812   where
 813     zapped_fn            = zapSpecPragmaId fn
 814         -- If the fn is a SpecPragmaId, make it discardable
 815         -- It's role as a holder for a call instance is o'er
 816         -- But it might be alive for some other reason by now.
 817
 818     fn_type            = idType fn
 819     (tyvars, theta, _) = tcSplitSigmaTy fn_type
 820     n_tyvars           = length tyvars
 821     n_dicts            = length theta
 822
 823     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
 824     rhs_dicts = take n_dicts rhs_ids
 825     rhs_bndrs = rhs_tyvars ++ rhs_dicts
 826     body      = mkLams (drop n_dicts rhs_ids) rhs_body
 827                 -- Glue back on the non-dict lambdas
 828
 829     calls_for_me = case lookupFM calls fn of
 830                         Nothing -> []
 831                         Just cs -> fmToList cs
 832
 833     ----------------------------------------------------------
 834         -- Specialise to one particular call pattern
 835     spec_call :: (CallKey, ([DictExpr], VarSet))        -- Call instance
 836               -> SpecM ((Id,CoreExpr),                  -- Specialised definition
 837                         UsageDetails,                   -- Usage details from specialised body
 838                         CoreRule)                       -- Info for the Id's SpecEnv
 839     spec_call (CallKey call_ts, (call_ds, call_fvs))
 840       = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
 841                 -- Calls are only recorded for properly-saturated applications
 842
 843         -- Suppose f's defn is  f = /\ a b c d -> \ d1 d2 -> rhs
 844         -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [dx1, dx2]
 845
 846         -- Construct the new binding
 847         --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs)
 848         -- PLUS the usage-details
 849         --      { d1' = dx1; d2' = dx2 }
 850         -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied.
 851         --
 852         -- Note that the substitution is applied to the whole thing.
 853         -- This is convenient, but just slightly fragile.  Notably:
 854         --      * There had better be no name clashes in a/b/c/d
 855         --
 856         let
 857                 -- poly_tyvars = [b,d] in the example above
 858                 -- spec_tyvars = [a,c]
 859                 -- ty_args     = [t1,b,t3,d]
 860            poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
 861            spec_tyvars = [tv | (tv, Just _)  <- rhs_tyvars `zip` call_ts]
 862            ty_args     = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
 863                        where
 864                          mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
 865                          mk_ty_arg rhs_tyvar (Just ty) = Type ty
 866            rhs_subst  = extendSubstList subst spec_tyvars [DoneTy ty | Just ty <- call_ts]
 867         in
 868         cloneBinders rhs_subst rhs_dicts                `thenSM` \ (rhs_subst', rhs_dicts') ->
 869         let
 870            inst_args = ty_args ++ map Var rhs_dicts'
 871
 872                 -- Figure out the type of the specialised function
 873            spec_id_ty = mkForAllTys poly_tyvars (applyTypeToArgs rhs fn_type inst_args)
 874         in
 875         newIdSM fn spec_id_ty                           `thenSM` \ spec_f ->
 876         specExpr rhs_subst' (mkLams poly_tyvars body)   `thenSM` \ (spec_rhs, rhs_uds) ->
 877         let
 878                 -- The rule to put in the function's specialisation is:
 879                 --      forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d
 880            spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
 881                                 (poly_tyvars ++ rhs_dicts')
 882                                 inst_args
 883                                 (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
 884
 885                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
 886            final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
 887         in
 888         returnSM ((spec_f, spec_rhs),
 889                   final_uds,
 890                   spec_env_rule)
 891
 892       where
 893         my_zipEqual doc xs ys
 894          | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
 895          | otherwise              = zipEqual doc xs ys
 896 \end{code}
 897
 898 %************************************************************************
 899 %*                                                                      *
 900 \subsubsection{UsageDetails and suchlike}
 901 %*                                                                      *
 902 %************************************************************************
 903
 904 \begin{code}
 905 data UsageDetails
 906   = MkUD {
 907         dict_binds :: !(Bag DictBind),
 908                         -- Floated dictionary bindings
 909                         -- The order is important;
 910                         -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
 911                         -- (Remember, Bags preserve order in GHC.)
 912
 913         calls     :: !CallDetails
 914     }
 915
 916 type DictBind = (CoreBind, VarSet)
 917         -- The set is the free vars of the binding
 918         -- both tyvars and dicts
 919
 920 type DictExpr = CoreExpr
 921
 922 emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
 923
 924 type ProtoUsageDetails = ([DictBind],
 925                           [(Id, CallKey, ([DictExpr], VarSet))]
 926                          )
 927
 928 ------------------------------------------------------------
 929 type CallDetails  = FiniteMap Id CallInfo
 930 newtype CallKey   = CallKey [Maybe Type]                        -- Nothing => unconstrained type argument
 931 type CallInfo     = FiniteMap CallKey
 932                               ([DictExpr], VarSet)              -- Dict args and the vars of the whole
 933                                                                 -- call (including tyvars)
 934                                                                 -- [*not* include the main id itself, of course]
 935         -- The finite maps eliminate duplicates
 936         -- The list of types and dictionaries is guaranteed to
 937         -- match the type of f
 938
 939 -- Type isn't an instance of Ord, so that we can control which
 940 -- instance we use.  That's tiresome here.  Oh well
 941 instance Eq CallKey where
 942   k1 == k2 = case k1 `compare` k2 of { EQ -> True; other -> False }
 943
 944 instance Ord CallKey where
 945   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
 946                 where
 947                   cmp Nothing Nothing     = EQ
 948                   cmp Nothing (Just t2)   = LT
 949                   cmp (Just t1) Nothing   = GT
 950                   cmp (Just t1) (Just t2) = tcCmpType t1 t2
 951
 952 unionCalls :: CallDetails -> CallDetails -> CallDetails
 953 unionCalls c1 c2 = plusFM_C plusFM c1 c2
 954
 955 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
 956 singleCall id tys dicts
 957   = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
 958   where
 959     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
 960     tys_fvs  = tyVarsOfTypes (catMaybes tys)
 961         -- The type args (tys) are guaranteed to be part of the dictionary
 962         -- types, because they are just the constrained types,
 963         -- and the dictionary is therefore sure to be bound
 964         -- inside the binding for any type variables free in the type;
 965         -- hence it's safe to neglect tyvars free in tys when making
 966         -- the free-var set for this call
 967         -- BUT I don't trust this reasoning; play safe and include tys_fvs
 968         --
 969         -- We don't include the 'id' itself.
 970
 971 listToCallDetails calls
 972   = foldr (unionCalls . mk_call) emptyFM calls
 973   where
 974     mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs)
 975         -- NB: the free vars of the call are provided
 976
 977 callDetailsToList calls = [ (id,tys,dicts)
 978                           | (id,fm) <- fmToList calls,
 979                             (tys, dicts) <- fmToList fm
 980                           ]
 981
 982 mkCallUDs subst f args
 983   | null theta
 984   || length spec_tys /= n_tyvars
 985   || length dicts    /= n_dicts
 986   || maybeToBool (lookupRule (substInScope subst) f args)
 987         -- There's already a rule covering this call.  A typical case
 988         -- is where there's an explicit user-provided rule.  Then
 989         -- we don't want to create a specialised version
 990         -- of the function that overlaps.
 991   = emptyUDs    -- Not overloaded, or no specialisation wanted
 992
 993   | otherwise
 994   = MkUD {dict_binds = emptyBag,
 995           calls      = singleCall f spec_tys dicts
 996     }
 997   where
 998     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
 999     constrained_tyvars = tyVarsOfTheta theta
1000     n_tyvars           = length tyvars
1001     n_dicts            = length theta
1002
1003     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
1004     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
1005
1006     mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
1007                         = Just ty
1008                         | otherwise
1009                         = Nothing
1010
1011 ------------------------------------------------------------
1012 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
1013 plusUDs (MkUD {dict_binds = db1, calls = calls1})
1014         (MkUD {dict_binds = db2, calls = calls2})
1015   = MkUD {dict_binds = d, calls = c}
1016   where
1017     d = db1    `unionBags`   db2
1018     c = calls1 `unionCalls`  calls2
1019
1020 plusUDList = foldr plusUDs emptyUDs
1021
1022 -- zapCalls deletes calls to ids from uds
1023 zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
1024
1025 mkDB bind = (bind, bind_fvs bind)
1026
1027 bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
1028 bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
1029                            where
1030                              bndrs = map fst prs
1031                              rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
1032
1033 addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
1034
1035 dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
1036   = foldrBag add binds dbs
1037   where
1038     add (bind,_) binds = bind : binds
1039
1040 dumpUDs :: [CoreBndr]
1041         -> UsageDetails -> CoreExpr
1042         -> (UsageDetails, CoreExpr)
1043 dumpUDs bndrs uds body
1044   = (free_uds, foldr add_let body dict_binds)
1045   where
1046     (free_uds, (dict_binds, _)) = splitUDs bndrs uds
1047     add_let (bind,_) body       = Let bind body
1048
1049 splitUDs :: [CoreBndr]
1050          -> UsageDetails
1051          -> (UsageDetails,              -- These don't mention the binders
1052              ProtoUsageDetails)         -- These do
1053
1054 splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
1055                           calls      = orig_calls})
1056
1057   = if isEmptyBag dump_dbs && null dump_calls then
1058         -- Common case: binder doesn't affect floats
1059         (uds, ([],[]))
1060
1061     else
1062         -- Binders bind some of the fvs of the floats
1063         (MkUD {dict_binds = free_dbs,
1064                calls      = listToCallDetails free_calls},
1065          (bagToList dump_dbs, dump_calls)
1066         )
1067
1068   where
1069     bndr_set = mkVarSet bndrs
1070
1071     (free_dbs, dump_dbs, dump_idset)
1072           = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
1073                 -- Important that it's foldl not foldr;
1074                 -- we're accumulating the set of dumped ids in dump_set
1075
1076         -- Filter out any calls that mention things that are being dumped
1077     orig_call_list                 = callDetailsToList orig_calls
1078     (dump_calls, free_calls)       = partition captured orig_call_list
1079     captured (id,tys,(dicts, fvs)) =  fvs `intersectsVarSet` dump_idset
1080                                    || id `elemVarSet` dump_idset
1081
1082     dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
1083         | dump_idset `intersectsVarSet` fvs     -- Dump it
1084         = (free_dbs, dump_dbs `snocBag` db,
1085            dump_idset `unionVarSet` mkVarSet (bindersOf bind))
1086
1087         | otherwise     -- Don't dump it
1088         = (free_dbs `snocBag` db, dump_dbs, dump_idset)
1089 \end{code}
1090
1091
1092 %************************************************************************
1093 %*                                                                      *
1094 \subsubsection{Boring helper functions}
1095 %*                                                                      *
1096 %************************************************************************
1097
1098 \begin{code}
1099 type SpecM a = UniqSM a
1100
1101 thenSM    = thenUs
1102 returnSM  = returnUs
1103 getUniqSM = getUniqueUs
1104 mapSM     = mapUs
1105 initSM    = initUs_
1106
1107 mapAndCombineSM f []     = returnSM ([], emptyUDs)
1108 mapAndCombineSM f (x:xs) = f x  `thenSM` \ (y, uds1) ->
1109                            mapAndCombineSM f xs `thenSM` \ (ys, uds2) ->
1110                            returnSM (y:ys, uds1 `plusUDs` uds2)
1111
1112 cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
1113 -- Clone the binders of the bind; return new bind with the cloned binders
1114 -- Return the substitution to use for RHSs, and the one to use for the body
1115 cloneBindSM subst (NonRec bndr rhs)
1116   = getUs       `thenUs` \ us ->
1117     let
1118         (subst', bndr') = substAndCloneId subst us bndr
1119     in
1120     returnUs (subst, subst', NonRec bndr' rhs)
1121
1122 cloneBindSM subst (Rec pairs)
1123   = getUs       `thenUs` \ us ->
1124     let
1125         (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs)
1126     in
1127     returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
1128
1129 cloneBinders subst bndrs
1130   = getUs       `thenUs` \ us ->
1131     returnUs (substAndCloneIds subst us bndrs)
1132
1133 newIdSM old_id new_ty
1134   = getUniqSM           `thenSM` \ uniq ->
1135     let
1136         -- Give the new Id a similar occurrence name to the old one
1137         name   = idName old_id
1138         new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
1139     in
1140     returnSM new_id
1141 \end{code}
1142
1143
1144                 Old (but interesting) stuff about unboxed bindings
1145                 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1146
1147 What should we do when a value is specialised to a *strict* unboxed value?
1148
1149         map_*_* f (x:xs) = let h = f x
1150                                t = map f xs
1151                            in h:t
1152
1153 Could convert let to case:
1154
1155         map_*_Int# f (x:xs) = case f x of h# ->
1156                               let t = map f xs
1157                               in h#:t
1158
1159 This may be undesirable since it forces evaluation here, but the value
1160 may not be used in all branches of the body. In the general case this
1161 transformation is impossible since the mutual recursion in a letrec
1162 cannot be expressed as a case.
1163
1164 There is also a problem with top-level unboxed values, since our
1165 implementation cannot handle unboxed values at the top level.
1166
1167 Solution: Lift the binding of the unboxed value and extract it when it
1168 is used:
1169
1170         map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
1171                                   t = map f xs
1172                               in case h of
1173                                  _Lift h# -> h#:t
1174
1175 Now give it to the simplifier and the _Lifting will be optimised away.
1176
1177 The benfit is that we have given the specialised "unboxed" values a
1178 very simplep lifted semantics and then leave it up to the simplifier to
1179 optimise it --- knowing that the overheads will be removed in nearly
1180 all cases.
1181
1182 In particular, the value will only be evaluted in the branches of the
1183 program which use it, rather than being forced at the point where the
1184 value is bound. For example:
1185
1186         filtermap_*_* p f (x:xs)
1187           = let h = f x
1188                 t = ...
1189             in case p x of
1190                 True  -> h:t
1191                 False -> t
1192    ==>
1193         filtermap_*_Int# p f (x:xs)
1194           = let h = case (f x) of h# -> _Lift h#
1195                 t = ...
1196             in case p x of
1197                 True  -> case h of _Lift h#
1198                            -> h#:t
1199                 False -> t
1200
1201 The binding for h can still be inlined in the one branch and the
1202 _Lifting eliminated.
1203
1204
1205 Question: When won't the _Lifting be eliminated?
1206
1207 Answer: When they at the top-level (where it is necessary) or when
1208 inlining would duplicate work (or possibly code depending on
1209 options). However, the _Lifting will still be eliminated if the
1210 strictness analyser deems the lifted binding strict.
1211