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