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 Id
  12 import TcType
  13 import CoreSubst
  14 import CoreUnfold       ( mkSimpleUnfolding, mkInlineUnfolding )
  15 import VarSet
  16 import VarEnv
  17 import CoreSyn
  18 import Rules
  19 import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkPiTypes )
  20 import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars )
  21 import UniqSupply       ( UniqSupply, UniqSM, initUs_, MonadUnique(..) )
  22 import Name
  23 import MkId             ( voidArgId, realWorldPrimId )
  24 import Maybes           ( catMaybes, isJust )
  25 import BasicTypes       ( isNeverActive, inlinePragmaActivation )
  26 import Bag
  27 import Util
  28 import Outputable
  29 import FastString
  30
  31 import Data.Map (Map)
  32 import qualified Data.Map as Map
  33 import qualified FiniteMap as Map
  34 \end{code}
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 These notes describe how we implement specialisation to eliminate
  43 overloading.
  44
  45 The specialisation pass works on Core
  46 syntax, complete with all the explicit dictionary application,
  47 abstraction and construction as added by the type checker.  The
  48 existing type checker remains largely as it is.
  49
  50 One important thought: the {\em types} passed to an overloaded
  51 function, and the {\em dictionaries} passed are mutually redundant.
  52 If the same function is applied to the same type(s) then it is sure to
  53 be applied to the same dictionary(s)---or rather to the same {\em
  54 values}.  (The arguments might look different but they will evaluate
  55 to the same value.)
  56
  57 Second important thought: we know that we can make progress by
  58 treating dictionary arguments as static and worth specialising on.  So
  59 we can do without binding-time analysis, and instead specialise on
  60 dictionary arguments and no others.
  61
  62 The basic idea
  63 ~~~~~~~~~~~~~~
  64 Suppose we have
  65
  66         let f = <f_rhs>
  67         in <body>
  68
  69 and suppose f is overloaded.
  70
  71 STEP 1: CALL-INSTANCE COLLECTION
  72
  73 We traverse <body>, accumulating all applications of f to types and
  74 dictionaries.
  75
  76 (Might there be partial applications, to just some of its types and
  77 dictionaries?  In principle yes, but in practice the type checker only
  78 builds applications of f to all its types and dictionaries, so partial
  79 applications could only arise as a result of transformation, and even
  80 then I think it's unlikely.  In any case, we simply don't accumulate such
  81 partial applications.)
  82
  83
  84 STEP 2: EQUIVALENCES
  85
  86 So now we have a collection of calls to f:
  87         f t1 t2 d1 d2
  88         f t3 t4 d3 d4
  89         ...
  90 Notice that f may take several type arguments.  To avoid ambiguity, we
  91 say that f is called at type t1/t2 and t3/t4.
  92
  93 We take equivalence classes using equality of the *types* (ignoring
  94 the dictionary args, which as mentioned previously are redundant).
  95
  96 STEP 3: SPECIALISATION
  97
  98 For each equivalence class, choose a representative (f t1 t2 d1 d2),
  99 and create a local instance of f, defined thus:
 100
 101         f@t1/t2 = <f_rhs> t1 t2 d1 d2
 102
 103 f_rhs presumably has some big lambdas and dictionary lambdas, so lots
 104 of simplification will now result.  However we don't actually *do* that
 105 simplification.  Rather, we leave it for the simplifier to do.  If we
 106 *did* do it, though, we'd get more call instances from the specialised
 107 RHS.  We can work out what they are by instantiating the call-instance
 108 set from f's RHS with the types t1, t2.
 109
 110 Add this new id to f's IdInfo, to record that f has a specialised version.
 111
 112 Before doing any of this, check that f's IdInfo doesn't already
 113 tell us about an existing instance of f at the required type/s.
 114 (This might happen if specialisation was applied more than once, or
 115 it might arise from user SPECIALIZE pragmas.)
 116
 117 Recursion
 118 ~~~~~~~~~
 119 Wait a minute!  What if f is recursive?  Then we can't just plug in
 120 its right-hand side, can we?
 121
 122 But it's ok.  The type checker *always* creates non-recursive definitions
 123 for overloaded recursive functions.  For example:
 124
 125         f x = f (x+x)           -- Yes I know its silly
 126
 127 becomes
 128
 129         f a (d::Num a) = let p = +.sel a d
 130                          in
 131                          letrec fl (y::a) = fl (p y y)
 132                          in
 133                          fl
 134
 135 We still have recusion for non-overloaded functions which we
 136 speciailise, but the recursive call should get specialised to the
 137 same recursive version.
 138
 139
 140 Polymorphism 1
 141 ~~~~~~~~~~~~~~
 142
 143 All this is crystal clear when the function is applied to *constant
 144 types*; that is, types which have no type variables inside.  But what if
 145 it is applied to non-constant types?  Suppose we find a call of f at type
 146 t1/t2.  There are two possibilities:
 147
 148 (a) The free type variables of t1, t2 are in scope at the definition point
 149 of f.  In this case there's no problem, we proceed just as before.  A common
 150 example is as follows.  Here's the Haskell:
 151
 152         g y = let f x = x+x
 153               in f y + f y
 154
 155 After typechecking we have
 156
 157         g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
 158                                 in +.sel a d (f a d y) (f a d y)
 159
 160 Notice that the call to f is at type type "a"; a non-constant type.
 161 Both calls to f are at the same type, so we can specialise to give:
 162
 163         g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
 164                                 in +.sel a d (f@a y) (f@a y)
 165
 166
 167 (b) The other case is when the type variables in the instance types
 168 are *not* in scope at the definition point of f.  The example we are
 169 working with above is a good case.  There are two instances of (+.sel a d),
 170 but "a" is not in scope at the definition of +.sel.  Can we do anything?
 171 Yes, we can "common them up", a sort of limited common sub-expression deal.
 172 This would give:
 173
 174         g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
 175                                     f@a (x::a) = +.sel@a x x
 176                                 in +.sel@a (f@a y) (f@a y)
 177
 178 This can save work, and can't be spotted by the type checker, because
 179 the two instances of +.sel weren't originally at the same type.
 180
 181 Further notes on (b)
 182
 183 * There are quite a few variations here.  For example, the defn of
 184   +.sel could be floated ouside the \y, to attempt to gain laziness.
 185   It certainly mustn't be floated outside the \d because the d has to
 186   be in scope too.
 187
 188 * We don't want to inline f_rhs in this case, because
 189 that will duplicate code.  Just commoning up the call is the point.
 190
 191 * Nothing gets added to +.sel's IdInfo.
 192
 193 * Don't bother unless the equivalence class has more than one item!
 194
 195 Not clear whether this is all worth it.  It is of course OK to
 196 simply discard call-instances when passing a big lambda.
 197
 198 Polymorphism 2 -- Overloading
 199 ~~~~~~~~~~~~~~
 200 Consider a function whose most general type is
 201
 202         f :: forall a b. Ord a => [a] -> b -> b
 203
 204 There is really no point in making a version of g at Int/Int and another
 205 at Int/Bool, because it's only instancing the type variable "a" which
 206 buys us any efficiency. Since g is completely polymorphic in b there
 207 ain't much point in making separate versions of g for the different
 208 b types.
 209
 210 That suggests that we should identify which of g's type variables
 211 are constrained (like "a") and which are unconstrained (like "b").
 212 Then when taking equivalence classes in STEP 2, we ignore the type args
 213 corresponding to unconstrained type variable.  In STEP 3 we make
 214 polymorphic versions.  Thus:
 215
 216         f@t1/ = /\b -> <f_rhs> t1 b d1 d2
 217
 218 We do this.
 219
 220
 221 Dictionary floating
 222 ~~~~~~~~~~~~~~~~~~~
 223 Consider this
 224
 225         f a (d::Num a) = let g = ...
 226                          in
 227                          ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
 228
 229 Here, g is only called at one type, but the dictionary isn't in scope at the
 230 definition point for g.  Usually the type checker would build a
 231 definition for d1 which enclosed g, but the transformation system
 232 might have moved d1's defn inward.  Solution: float dictionary bindings
 233 outwards along with call instances.
 234
 235 Consider
 236
 237         f x = let g p q = p==q
 238                   h r s = (r+s, g r s)
 239               in
 240               h x x
 241
 242
 243 Before specialisation, leaving out type abstractions we have
 244
 245         f df x = let g :: Eq a => a -> a -> Bool
 246                      g dg p q = == dg p q
 247                      h :: Num a => a -> a -> (a, Bool)
 248                      h dh r s = let deq = eqFromNum dh
 249                                 in (+ dh r s, g deq r s)
 250               in
 251               h df x x
 252
 253 After specialising h we get a specialised version of h, like this:
 254
 255                     h' r s = let deq = eqFromNum df
 256                              in (+ df r s, g deq r s)
 257
 258 But we can't naively make an instance for g from this, because deq is not in scope
 259 at the defn of g.  Instead, we have to float out the (new) defn of deq
 260 to widen its scope.  Notice that this floating can't be done in advance -- it only
 261 shows up when specialisation is done.
 262
 263 User SPECIALIZE pragmas
 264 ~~~~~~~~~~~~~~~~~~~~~~~
 265 Specialisation pragmas can be digested by the type checker, and implemented
 266 by adding extra definitions along with that of f, in the same way as before
 267
 268         f@t1/t2 = <f_rhs> t1 t2 d1 d2
 269
 270 Indeed the pragmas *have* to be dealt with by the type checker, because
 271 only it knows how to build the dictionaries d1 and d2!  For example
 272
 273         g :: Ord a => [a] -> [a]
 274         {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
 275
 276 Here, the specialised version of g is an application of g's rhs to the
 277 Ord dictionary for (Tree Int), which only the type checker can conjure
 278 up.  There might not even *be* one, if (Tree Int) is not an instance of
 279 Ord!  (All the other specialision has suitable dictionaries to hand
 280 from actual calls.)
 281
 282 Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
 283 it is buried in a complex (as-yet-un-desugared) binding group.
 284 Maybe we should say
 285
 286         f@t1/t2 = f* t1 t2 d1 d2
 287
 288 where f* is the Id f with an IdInfo which says "inline me regardless!".
 289 Indeed all the specialisation could be done in this way.
 290 That in turn means that the simplifier has to be prepared to inline absolutely
 291 any in-scope let-bound thing.
 292
 293
 294 Again, the pragma should permit polymorphism in unconstrained variables:
 295
 296         h :: Ord a => [a] -> b -> b
 297         {-# SPECIALIZE h :: [Int] -> b -> b #-}
 298
 299 We *insist* that all overloaded type variables are specialised to ground types,
 300 (and hence there can be no context inside a SPECIALIZE pragma).
 301 We *permit* unconstrained type variables to be specialised to
 302         - a ground type
 303         - or left as a polymorphic type variable
 304 but nothing in between.  So
 305
 306         {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
 307
 308 is *illegal*.  (It can be handled, but it adds complication, and gains the
 309 programmer nothing.)
 310
 311
 312 SPECIALISING INSTANCE DECLARATIONS
 313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 314 Consider
 315
 316         instance Foo a => Foo [a] where
 317                 ...
 318         {-# SPECIALIZE instance Foo [Int] #-}
 319
 320 The original instance decl creates a dictionary-function
 321 definition:
 322
 323         dfun.Foo.List :: forall a. Foo a -> Foo [a]
 324
 325 The SPECIALIZE pragma just makes a specialised copy, just as for
 326 ordinary function definitions:
 327
 328         dfun.Foo.List@Int :: Foo [Int]
 329         dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
 330
 331 The information about what instance of the dfun exist gets added to
 332 the dfun's IdInfo in the same way as a user-defined function too.
 333
 334
 335 Automatic instance decl specialisation?
 336 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 337 Can instance decls be specialised automatically?  It's tricky.
 338 We could collect call-instance information for each dfun, but
 339 then when we specialised their bodies we'd get new call-instances
 340 for ordinary functions; and when we specialised their bodies, we might get
 341 new call-instances of the dfuns, and so on.  This all arises because of
 342 the unrestricted mutual recursion between instance decls and value decls.
 343
 344 Still, there's no actual problem; it just means that we may not do all
 345 the specialisation we could theoretically do.
 346
 347 Furthermore, instance decls are usually exported and used non-locally,
 348 so we'll want to compile enough to get those specialisations done.
 349
 350 Lastly, there's no such thing as a local instance decl, so we can
 351 survive solely by spitting out *usage* information, and then reading that
 352 back in as a pragma when next compiling the file.  So for now,
 353 we only specialise instance decls in response to pragmas.
 354
 355
 356 SPITTING OUT USAGE INFORMATION
 357 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 358
 359 To spit out usage information we need to traverse the code collecting
 360 call-instance information for all imported (non-prelude?) functions
 361 and data types. Then we equivalence-class it and spit it out.
 362
 363 This is done at the top-level when all the call instances which escape
 364 must be for imported functions and data types.
 365
 366 *** Not currently done ***
 367
 368
 369 Partial specialisation by pragmas
 370 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 371 What about partial specialisation:
 372
 373         k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
 374         {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
 375
 376 or even
 377
 378         {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
 379
 380 Seems quite reasonable.  Similar things could be done with instance decls:
 381
 382         instance (Foo a, Foo b) => Foo (a,b) where
 383                 ...
 384         {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
 385         {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
 386
 387 Ho hum.  Things are complex enough without this.  I pass.
 388
 389
 390 Requirements for the simplifer
 391 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 392 The simplifier has to be able to take advantage of the specialisation.
 393
 394 * When the simplifier finds an application of a polymorphic f, it looks in
 395 f's IdInfo in case there is a suitable instance to call instead.  This converts
 396
 397         f t1 t2 d1 d2   ===>   f_t1_t2
 398
 399 Note that the dictionaries get eaten up too!
 400
 401 * Dictionary selection operations on constant dictionaries must be
 402   short-circuited:
 403
 404         +.sel Int d     ===>  +Int
 405
 406 The obvious way to do this is in the same way as other specialised
 407 calls: +.sel has inside it some IdInfo which tells that if it's applied
 408 to the type Int then it should eat a dictionary and transform to +Int.
 409
 410 In short, dictionary selectors need IdInfo inside them for constant
 411 methods.
 412
 413 * Exactly the same applies if a superclass dictionary is being
 414   extracted:
 415
 416         Eq.sel Int d   ===>   dEqInt
 417
 418 * Something similar applies to dictionary construction too.  Suppose
 419 dfun.Eq.List is the function taking a dictionary for (Eq a) to
 420 one for (Eq [a]).  Then we want
 421
 422         dfun.Eq.List Int d      ===> dEq.List_Int
 423
 424 Where does the Eq [Int] dictionary come from?  It is built in
 425 response to a SPECIALIZE pragma on the Eq [a] instance decl.
 426
 427 In short, dfun Ids need IdInfo with a specialisation for each
 428 constant instance of their instance declaration.
 429
 430 All this uses a single mechanism: the SpecEnv inside an Id
 431
 432
 433 What does the specialisation IdInfo look like?
 434 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 435
 436 The SpecEnv of an Id maps a list of types (the template) to an expression
 437
 438         [Type]  |->  Expr
 439
 440 For example, if f has this SpecInfo:
 441
 442         [Int, a]  ->  \d:Ord Int. f' a
 443
 444 it means that we can replace the call
 445
 446         f Int t  ===>  (\d. f' t)
 447
 448 This chucks one dictionary away and proceeds with the
 449 specialised version of f, namely f'.
 450
 451
 452 What can't be done this way?
 453 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 454 There is no way, post-typechecker, to get a dictionary for (say)
 455 Eq a from a dictionary for Eq [a].  So if we find
 456
 457         ==.sel [t] d
 458
 459 we can't transform to
 460
 461         eqList (==.sel t d')
 462
 463 where
 464         eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
 465
 466 Of course, we currently have no way to automatically derive
 467 eqList, nor to connect it to the Eq [a] instance decl, but you
 468 can imagine that it might somehow be possible.  Taking advantage
 469 of this is permanently ruled out.
 470
 471 Still, this is no great hardship, because we intend to eliminate
 472 overloading altogether anyway!
 473
 474 A note about non-tyvar dictionaries
 475 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 476 Some Ids have types like
 477
 478         forall a,b,c. Eq a -> Ord [a] -> tau
 479
 480 This seems curious at first, because we usually only have dictionary
 481 args whose types are of the form (C a) where a is a type variable.
 482 But this doesn't hold for the functions arising from instance decls,
 483 which sometimes get arguements with types of form (C (T a)) for some
 484 type constructor T.
 485
 486 Should we specialise wrt this compound-type dictionary?  We used to say
 487 "no", saying:
 488         "This is a heuristic judgement, as indeed is the fact that we
 489         specialise wrt only dictionaries.  We choose *not* to specialise
 490         wrt compound dictionaries because at the moment the only place
 491         they show up is in instance decls, where they are simply plugged
 492         into a returned dictionary.  So nothing is gained by specialising
 493         wrt them."
 494
 495 But it is simpler and more uniform to specialise wrt these dicts too;
 496 and in future GHC is likely to support full fledged type signatures
 497 like
 498         f :: Eq [(a,b)] => ...
 499
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsubsection{The new specialiser}
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 Our basic game plan is this.  For let(rec) bound function
 508         f :: (C a, D c) => (a,b,c,d) -> Bool
 509
 510 * Find any specialised calls of f, (f ts ds), where
 511   ts are the type arguments t1 .. t4, and
 512   ds are the dictionary arguments d1 .. d2.
 513
 514 * Add a new definition for f1 (say):
 515
 516         f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
 517
 518   Note that we abstract over the unconstrained type arguments.
 519
 520 * Add the mapping
 521
 522         [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
 523
 524   to the specialisations of f.  This will be used by the
 525   simplifier to replace calls
 526                 (f t1 t2 t3 t4) da db
 527   by
 528                 (\d1 d1 -> f1 t2 t4) da db
 529
 530   All the stuff about how many dictionaries to discard, and what types
 531   to apply the specialised function to, are handled by the fact that the
 532   SpecEnv contains a template for the result of the specialisation.
 533
 534 We don't build *partial* specialisations for f.  For example:
 535
 536   f :: Eq a => a -> a -> Bool
 537   {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
 538
 539 Here, little is gained by making a specialised copy of f.
 540 There's a distinct danger that the specialised version would
 541 first build a dictionary for (Eq b, Eq c), and then select the (==)
 542 method from it!  Even if it didn't, not a great deal is saved.
 543
 544 We do, however, generate polymorphic, but not overloaded, specialisations:
 545
 546   f :: Eq a => [a] -> b -> b -> b
 547   {#- SPECIALISE f :: [Int] -> b -> b -> b #-}
 548
 549 Hence, the invariant is this:
 550
 551         *** no specialised version is overloaded ***
 552
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsubsection{The exported function}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 \begin{code}
 561 specProgram :: UniqSupply -> [CoreBind] -> [CoreBind]
 562 specProgram us binds = initSM us $
 563                        do { (binds', uds') <- go binds
 564                           ; return (wrapDictBinds (ud_binds uds') binds') }
 565   where
 566         -- We need to start with a Subst that knows all the things
 567         -- that are in scope, so that the substitution engine doesn't
 568         -- accidentally re-use a unique that's already in use
 569         -- Easiest thing is to do it all at once, as if all the top-level
 570         -- decls were mutually recursive
 571     top_subst       = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
 572
 573     go []           = return ([], emptyUDs)
 574     go (bind:binds) = do (binds', uds) <- go binds
 575                          (bind', uds') <- specBind top_subst bind uds
 576                          return (bind' ++ binds', uds')
 577 \end{code}
 578
 579 %************************************************************************
 580 %*                                                                      *
 581 \subsubsection{@specExpr@: the main function}
 582 %*                                                                      *
 583 %************************************************************************
 584
 585 \begin{code}
 586 specVar :: Subst -> Id -> CoreExpr
 587 specVar subst v = lookupIdSubst (text "specVar") subst v
 588
 589 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 590 -- We carry a substitution down:
 591 --      a) we must clone any binding that might float outwards,
 592 --         to avoid name clashes
 593 --      b) we carry a type substitution to use when analysing
 594 --         the RHS of specialised bindings (no type-let!)
 595
 596 ---------------- First the easy cases --------------------
 597 specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs)
 598 specExpr subst (Var v)   = return (specVar subst v,         emptyUDs)
 599 specExpr _     (Lit lit) = return (Lit lit,                 emptyUDs)
 600 specExpr subst (Cast e co) = do
 601     (e', uds) <- specExpr subst e
 602     return ((Cast e' (CoreSubst.substTy subst co)), uds)
 603 specExpr subst (Note note body) = do
 604     (body', uds) <- specExpr subst body
 605     return (Note (specNote subst note) body', uds)
 606
 607
 608 ---------------- Applications might generate a call instance --------------------
 609 specExpr subst expr@(App {})
 610   = go expr []
 611   where
 612     go (App fun arg) args = do (arg', uds_arg) <- specExpr subst arg
 613                                (fun', uds_app) <- go fun (arg':args)
 614                                return (App fun' arg', uds_arg `plusUDs` uds_app)
 615
 616     go (Var f)       args = case specVar subst f of
 617                                 Var f' -> return (Var f', mkCallUDs f' args)
 618                                 e'     -> return (e', emptyUDs) -- I don't expect this!
 619     go other         _    = specExpr subst other
 620
 621 ---------------- Lambda/case require dumping of usage details --------------------
 622 specExpr subst e@(Lam _ _) = do
 623     (body', uds) <- specExpr subst' body
 624     let (free_uds, dumped_dbs) = dumpUDs bndrs' uds
 625     return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)
 626   where
 627     (bndrs, body) = collectBinders e
 628     (subst', bndrs') = substBndrs subst bndrs
 629         -- More efficient to collect a group of binders together all at once
 630         -- and we don't want to split a lambda group with dumped bindings
 631
 632 specExpr subst (Case scrut case_bndr ty alts)
 633   = do { (scrut', scrut_uds) <- specExpr subst scrut
 634        ; (scrut'', case_bndr', alts', alts_uds)
 635              <- specCase subst scrut' case_bndr alts
 636        ; return (Case scrut'' case_bndr' (CoreSubst.substTy subst ty) alts'
 637                 , scrut_uds `plusUDs` alts_uds) }
 638
 639 ---------------- Finally, let is the interesting case --------------------
 640 specExpr subst (Let bind body) = do
 641         -- Clone binders
 642     (rhs_subst, body_subst, bind') <- cloneBindSM subst bind
 643
 644         -- Deal with the body
 645     (body', body_uds) <- specExpr body_subst body
 646
 647         -- Deal with the bindings
 648     (binds', uds) <- specBind rhs_subst bind' body_uds
 649
 650         -- All done
 651     return (foldr Let body' binds', uds)
 652
 653 -- Must apply the type substitution to coerceions
 654 specNote :: Subst -> Note -> Note
 655 specNote _ note = note
 656
 657
 658 specCase :: Subst
 659          -> CoreExpr            -- Scrutinee, already done
 660          -> Id -> [CoreAlt]
 661          -> SpecM ( CoreExpr    -- New scrutinee
 662                   , Id
 663                   , [CoreAlt]
 664                   , UsageDetails)
 665 specCase subst scrut' case_bndr [(con, args, rhs)]
 666   | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]
 667   , interestingDict scrut'
 668   , not (isDeadBinder case_bndr && null sc_args')
 669   = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
 670
 671        ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')
 672                               [(con, args', Var sc_arg')]
 673                        | sc_arg' <- sc_args' ]
 674
 675              -- Extend the substitution for RHS to map the *original* binders
 676              -- to their floated verions.  Attach an unfolding to these floated
 677              -- binders so they look interesting to interestingDict
 678              mb_sc_flts :: [Maybe DictId]
 679              mb_sc_flts = map (lookupVarEnv clone_env) args'
 680              clone_env  = zipVarEnv sc_args' (zipWith add_unf sc_args_flt sc_rhss)
 681              subst_prs  = (case_bndr, Var (add_unf case_bndr_flt scrut'))
 682                         : [ (arg, Var sc_flt)
 683                           | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
 684              subst_rhs' = extendIdSubstList subst_rhs subst_prs
 685
 686        ; (rhs',   rhs_uds)   <- specExpr subst_rhs' rhs
 687        ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')
 688              case_bndr_set = unitVarSet case_bndr_flt
 689              sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)
 690                              | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
 691              flt_binds     = scrut_bind : sc_binds
 692              (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
 693              all_uds = flt_binds `addDictBinds` free_uds
 694              alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')
 695        ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
 696   where
 697     (subst_rhs, (case_bndr':args')) = substBndrs subst (case_bndr:args)
 698     sc_args' = filter is_flt_sc_arg args'
 699
 700     clone_me bndr = do { uniq <- getUniqueM
 701                        ; return (mkUserLocal occ uniq ty loc) }
 702        where
 703          name = idName bndr
 704          ty   = idType bndr
 705          occ  = nameOccName name
 706          loc  = getSrcSpan name
 707
 708     add_unf sc_flt sc_rhs  -- Sole purpose: make sc_flt respond True to interestingDictId
 709       = setIdUnfolding sc_flt (mkSimpleUnfolding sc_rhs)
 710
 711     arg_set = mkVarSet args'
 712     is_flt_sc_arg var =  isId var
 713                       && not (isDeadBinder var)
 714                       && isDictTy var_ty
 715                       && not (tyVarsOfType var_ty `intersectsVarSet` arg_set)
 716        where
 717          var_ty = idType var
 718
 719
 720 specCase subst scrut case_bndr alts
 721   = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
 722        ; return (scrut, case_bndr', alts', uds_alts) }
 723   where
 724     (subst_alt, case_bndr') = substBndr subst case_bndr
 725     spec_alt (con, args, rhs) = do
 726           (rhs', uds) <- specExpr subst_rhs rhs
 727           let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
 728           return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)
 729         where
 730           (subst_rhs, args') = substBndrs subst_alt args
 731 \end{code}
 732
 733 Note [Floating dictionaries out of cases]
 734 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 735 Consider
 736    g = \d. case d of { MkD sc ... -> ...(f sc)... }
 737 Naively we can't float d2's binding out of the case expression,
 738 because 'sc' is bound by the case, and that in turn means we can't
 739 specialise f, which seems a pity.
 740
 741 So we invert the case, by floating out a binding
 742 for 'sc_flt' thus:
 743     sc_flt = case d of { MkD sc ... -> sc }
 744 Now we can float the call instance for 'f'.  Indeed this is just
 745 what'll happen if 'sc' was originally bound with a let binding,
 746 but case is more efficient, and necessary with equalities. So it's
 747 good to work with both.
 748
 749 You might think that this won't make any difference, because the
 750 call instance will only get nuked by the \d.  BUT if 'g' itself is
 751 specialised, then transitively we should be able to specialise f.
 752
 753 In general, given
 754    case e of cb { MkD sc ... -> ...(f sc)... }
 755 we transform to
 756    let cb_flt = e
 757        sc_flt = case cb_flt of { MkD sc ... -> sc }
 758    in
 759    case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
 760
 761 The "_flt" things are the floated binds; we use the current substitution
 762 to substitute sc -> sc_flt in the RHS
 763
 764 %************************************************************************
 765 %*                                                                      *
 766 \subsubsection{Dealing with a binding}
 767 %*                                                                      *
 768 %************************************************************************
 769
 770 \begin{code}
 771 specBind :: Subst                       -- Use this for RHSs
 772          -> CoreBind
 773          -> UsageDetails                -- Info on how the scope of the binding
 774          -> SpecM ([CoreBind],          -- New bindings
 775                    UsageDetails)        -- And info to pass upstream
 776
 777 -- Returned UsageDetails:
 778 --    No calls for binders of this bind
 779 specBind rhs_subst (NonRec fn rhs) body_uds
 780   = do { (rhs', rhs_uds) <- specExpr rhs_subst rhs
 781        ; (fn', spec_defns, body_uds1) <- specDefn rhs_subst body_uds fn rhs
 782
 783        ; let pairs = spec_defns ++ [(fn', rhs')]
 784                         -- fn' mentions the spec_defns in its rules,
 785                         -- so put the latter first
 786
 787              combined_uds = body_uds1 `plusUDs` rhs_uds
 788                 -- This way round a call in rhs_uds of a function f
 789                 -- at type T will override a call of f at T in body_uds1; and
 790                 -- that is good because it'll tend to keep "earlier" calls
 791                 -- See Note [Specialisation of dictionary functions]
 792
 793              (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
 794                 -- See Note [From non-recursive to recursive]
 795
 796              final_binds | isEmptyBag dump_dbs = [NonRec b r | (b,r) <- pairs]
 797                          | otherwise = [Rec (flattenDictBinds dump_dbs pairs)]
 798
 799          ; if float_all then
 800              -- Rather than discard the calls mentioning the bound variables
 801              -- we float this binding along with the others
 802               return ([], free_uds `snocDictBinds` final_binds)
 803            else
 804              -- No call in final_uds mentions bound variables,
 805              -- so we can just leave the binding here
 806               return (final_binds, free_uds) }
 807
 808
 809 specBind rhs_subst (Rec pairs) body_uds
 810        -- Note [Specialising a recursive group]
 811   = do { let (bndrs,rhss) = unzip pairs
 812        ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_subst) rhss
 813        ; let scope_uds = body_uds `plusUDs` rhs_uds
 814                        -- Includes binds and calls arising from rhss
 815
 816        ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_subst scope_uds pairs
 817
 818        ; (bndrs3, spec_defns3, uds3)
 819              <- if null spec_defns1  -- Common case: no specialisation
 820                 then return (bndrs1, [], uds1)
 821                 else do {            -- Specialisation occurred; do it again
 822                           (bndrs2, spec_defns2, uds2)
 823                               <- specDefns rhs_subst uds1 (bndrs1 `zip` rhss)
 824                         ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }
 825
 826        ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3
 827              bind = Rec (flattenDictBinds dumped_dbs $
 828                          spec_defns3 ++ zip bndrs3 rhss')
 829
 830        ; if float_all then
 831               return ([], final_uds `snocDictBind` bind)
 832            else
 833               return ([bind], final_uds) }
 834
 835
 836 ---------------------------
 837 specDefns :: Subst
 838           -> UsageDetails               -- Info on how it is used in its scope
 839           -> [(Id,CoreExpr)]            -- The things being bound and their un-processed RHS
 840           -> SpecM ([Id],               -- Original Ids with RULES added
 841                     [(Id,CoreExpr)],    -- Extra, specialised bindings
 842                     UsageDetails)       -- Stuff to fling upwards from the specialised versions
 843
 844 -- Specialise a list of bindings (the contents of a Rec), but flowing usages
 845 -- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
 846 -- Then if the input CallDetails has a specialised call for 'g', whose specialisation
 847 -- in turn generates a specialised call for 'f', we catch that in this one sweep.
 848 -- But not vice versa (it's a fixpoint problem).
 849
 850 specDefns _subst uds []
 851   = return ([], [], uds)
 852 specDefns subst uds ((bndr,rhs):pairs)
 853   = do { (bndrs1, spec_defns1, uds1) <- specDefns subst uds pairs
 854        ; (bndr1, spec_defns2, uds2)  <- specDefn subst uds1 bndr rhs
 855        ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
 856
 857 ---------------------------
 858 specDefn :: Subst
 859          -> UsageDetails                -- Info on how it is used in its scope
 860          -> Id -> CoreExpr              -- The thing being bound and its un-processed RHS
 861          -> SpecM (Id,                  -- Original Id with added RULES
 862                    [(Id,CoreExpr)],     -- Extra, specialised bindings
 863                    UsageDetails)        -- Stuff to fling upwards from the specialised versions
 864
 865 specDefn subst body_uds fn rhs
 866         -- The first case is the interesting one
 867   |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
 868   && rhs_ids    `lengthAtLeast` n_dicts -- and enough dict args
 869   && notNull calls_for_me               -- And there are some calls to specialise
 870   && not (isNeverActive (idInlineActivation fn))
 871         -- Don't specialise NOINLINE things
 872         -- See Note [Auto-specialisation and RULES]
 873
 874 --   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small
 875 --      See Note [Inline specialisation] for why we do not
 876 --      switch off specialisation for inline functions
 877
 878   = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me) $
 879     do {       -- Make a specialised version for each call in calls_for_me
 880          stuff <- mapM spec_call calls_for_me
 881        ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff)
 882              fn' = addIdSpecialisations fn spec_rules
 883              final_uds = body_uds_without_me `plusUDs` plusUDList spec_uds
 884                 -- It's important that the `plusUDs` is this way
 885                 -- round, because body_uds_without_me may bind
 886                 -- dictionaries that are used in calls_for_me passed
 887                 -- to specDefn.  So the dictionary bindings in
 888                 -- spec_uds may mention dictionaries bound in
 889                 -- body_uds_without_me
 890
 891        ; return (fn', spec_defns, final_uds) }
 892
 893   | otherwise   -- No calls or RHS doesn't fit our preconceptions
 894   = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn )
 895           -- Note [Specialisation shape]
 896     -- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $
 897     return (fn, [], body_uds_without_me)
 898
 899   where
 900     fn_type            = idType fn
 901     fn_arity           = idArity fn
 902     fn_unf             = realIdUnfolding fn     -- Ignore loop-breaker-ness here
 903     (tyvars, theta, _) = tcSplitSigmaTy fn_type
 904     n_tyvars           = length tyvars
 905     n_dicts            = length theta
 906     inl_act            = inlinePragmaActivation (idInlinePragma fn)
 907
 908         -- Figure out whether the function has an INLINE pragma
 909         -- See Note [Inline specialisations]
 910     fn_has_inline_rule :: Maybe Bool    -- Derive sat-flag from existing thing
 911     fn_has_inline_rule = case isStableUnfolding_maybe fn_unf of
 912                            Just (_,sat) -> Just sat
 913                            Nothing      -> Nothing
 914
 915     spec_arity = unfoldingArity fn_unf - n_dicts  -- Arity of the *specialised* inline rule
 916
 917     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
 918
 919     (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
 920
 921     rhs_dict_ids = take n_dicts rhs_ids
 922     body         = mkLams (drop n_dicts rhs_ids) rhs_body
 923                 -- Glue back on the non-dict lambdas
 924
 925     already_covered :: [CoreExpr] -> Bool
 926     already_covered args          -- Note [Specialisations already covered]
 927        = isJust (lookupRule (const True) realIdUnfolding
 928                             (substInScope subst)
 929                             fn args (idCoreRules fn))
 930
 931     mk_ty_args :: [Maybe Type] -> [CoreExpr]
 932     mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
 933                where
 934                   mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
 935                   mk_ty_arg _         (Just ty) = Type ty
 936
 937     ----------------------------------------------------------
 938         -- Specialise to one particular call pattern
 939     spec_call :: CallInfo                         -- Call instance
 940               -> SpecM (Maybe ((Id,CoreExpr),     -- Specialised definition
 941                                UsageDetails,      -- Usage details from specialised body
 942                                CoreRule))         -- Info for the Id's SpecEnv
 943     spec_call (CallKey call_ts, (call_ds, _))
 944       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
 945
 946         -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs
 947         -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
 948
 949         -- Construct the new binding
 950         --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
 951         -- PLUS the usage-details
 952         --      { d1' = dx1; d2' = dx2 }
 953         -- where d1', d2' are cloned versions of d1,d2, with the type substitution
 954         -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2
 955         --
 956         -- Note that the substitution is applied to the whole thing.
 957         -- This is convenient, but just slightly fragile.  Notably:
 958         --      * There had better be no name clashes in a/b/c
 959         do { let
 960                 -- poly_tyvars = [b] in the example above
 961                 -- spec_tyvars = [a,c]
 962                 -- ty_args     = [t1,b,t3]
 963                 poly_tyvars   = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
 964                 spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
 965                 spec_ty_args  = map snd spec_tv_binds
 966                 ty_args       = mk_ty_args call_ts
 967                 rhs_subst     = CoreSubst.extendTvSubstList subst spec_tv_binds
 968
 969            ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids
 970                           -- Clone rhs_dicts, including instantiating their types
 971
 972            ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
 973                                           (my_zipEqual rhs_dict_ids inst_dict_ids call_ds)
 974                  inst_args = ty_args ++ map Var inst_dict_ids
 975
 976            ; if already_covered inst_args then
 977                 return Nothing
 978              else do
 979            {    -- Figure out the type of the specialised function
 980              let body_ty = applyTypeToArgs rhs fn_type inst_args
 981                  (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
 982                    | isUnLiftedType body_ty     -- C.f. WwLib.mkWorkerArgs
 983                    = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
 984                    | otherwise = (poly_tyvars, poly_tyvars)
 985                  spec_id_ty = mkPiTypes lam_args body_ty
 986
 987            ; spec_f <- newSpecIdSM fn spec_id_ty
 988            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
 989            ; let
 990                 -- The rule to put in the function's specialisation is:
 991                 --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
 992                 rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
 993                 spec_env_rule = mkLocalRule
 994                                   rule_name
 995                                   inl_act       -- Note [Auto-specialisation and RULES]
 996                                   (idName fn)
 997                                   (poly_tyvars ++ inst_dict_ids)
 998                                   inst_args
 999                                   (mkVarApps (Var spec_f) app_args)
1000
1001                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
1002                 final_uds = foldr consDictBind rhs_uds dx_binds
1003
1004                 -- Adding arity information just propagates it a bit faster
1005                 --      See Note [Arity decrease] in Simplify
1006                 -- Copy InlinePragma information from the parent Id.
1007                 -- So if f has INLINE[1] so does spec_f
1008                 spec_f_w_arity = spec_f `setIdArity`          max 0 (fn_arity - n_dicts)
1009                                         `setInlineActivation` inl_act
1010
1011                 -- Add an InlineRule if the parent has one
1012                 -- See Note [Inline specialisations]
1013                 final_spec_f
1014                   | Just sat <- fn_has_inline_rule
1015                   = let
1016                        mb_spec_arity = if sat then Just spec_arity else Nothing
1017                     in
1018                     spec_f_w_arity `setIdUnfolding` mkInlineUnfolding mb_spec_arity spec_rhs
1019                   | otherwise
1020                   = spec_f_w_arity
1021
1022            ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
1023       where
1024         my_zipEqual xs ys zs
1025          | debugIsOn && not (equalLength xs ys && equalLength ys zs)
1026              = pprPanic "my_zipEqual" (vcat [ ppr xs, ppr ys
1027                                             , ppr fn <+> ppr call_ts
1028                                             , ppr (idType fn), ppr theta
1029                                             , ppr n_dicts, ppr rhs_dict_ids
1030                                             , ppr rhs])
1031          | otherwise = zip3 xs ys zs
1032
1033 bindAuxiliaryDicts
1034         :: Subst
1035         -> [(DictId,DictId,CoreExpr)]   -- (orig_dict, inst_dict, dx)
1036         -> (Subst,                      -- Substitute for all orig_dicts
1037             [CoreBind])                 -- Auxiliary bindings
1038 -- Bind any dictionary arguments to fresh names, to preserve sharing
1039 -- Substitution already substitutes orig_dict -> inst_dict
1040 bindAuxiliaryDicts subst triples = go subst [] triples
1041   where
1042     go subst binds []    = (subst, binds)
1043     go subst binds ((d, dx_id, dx) : pairs)
1044       | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
1045              -- No auxiliary binding necessary
1046              -- Note that we bind the *original* dict in the substitution,
1047              -- overriding any d->dx_id binding put there by substBndrs
1048
1049       | otherwise        = go subst_w_unf (NonRec dx_id dx : binds) pairs
1050       where
1051         dx_id1 = dx_id `setIdUnfolding` mkSimpleUnfolding dx
1052         subst_w_unf = extendIdSubst subst d (Var dx_id1)
1053              -- Important!  We're going to substitute dx_id1 for d
1054              -- and we want it to look "interesting", else we won't gather *any*
1055              -- consequential calls. E.g.
1056              --     f d = ...g d....
1057              -- If we specialise f for a call (f (dfun dNumInt)), we'll get
1058              -- a consequent call (g d') with an auxiliary definition
1059              --     d' = df dNumInt
1060              -- We want that consequent call to look interesting
1061              --
1062              -- Again, note that we bind the *original* dict in the substitution,
1063              -- overriding any d->dx_id binding put there by substBndrs
1064 \end{code}
1065
1066 Note [From non-recursive to recursive]
1067 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1068 Even in the non-recursive case, if any dict-binds depend on 'fn' we might
1069 have built a recursive knot
1070
1071       f a d x = <blah>
1072       MkUD { ud_binds = d7 = MkD ..f..
1073            , ud_calls = ...(f T d7)... }
1074
1075 The we generate
1076
1077       Rec { fs x = <blah>[T/a, d7/d]
1078             f a d x = <blah>
1079                RULE f T _ = fs
1080             d7 = ...f... }
1081
1082 Here the recursion is only through the RULE.
1083
1084
1085 Note [Specialisation of dictionary functions]
1086 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1087 Here is a nasty example that bit us badly: see Trac #3591
1088
1089      dfun a d = MkD a d (meth d)
1090      d4 = <blah>
1091      d2 = dfun T d4
1092      d1 = $p1 d2
1093      d3 = dfun T d1
1094
1095 None of these definitions is recursive. What happened was that we
1096 generated a specialisation:
1097
1098      RULE forall d. dfun T d = dT
1099      dT = (MkD a d (meth d)) [T/a, d1/d]
1100         = MkD T d1 (meth d1)
1101
1102 But now we use the RULE on the RHS of d2, to get
1103
1104     d2 = dT = MkD d1 (meth d1)
1105     d1 = $p1 d2
1106
1107 and now d1 is bottom!  The problem is that when specialising 'dfun' we
1108 should first dump "below" the binding all floated dictionary bindings
1109 that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be
1110 placed below 'dfun', and thus unavailable to it when specialising
1111 'dfun'.  That in turn means that the call (dfun T d1) must be
1112 discarded.  On the other hand, the call (dfun T d4) is fine, assuming
1113 d4 doesn't mention dfun.
1114
1115 But look at this:
1116
1117   class C a where { foo,bar :: [a] -> [a] }
1118
1119   instance C Int where
1120      foo x = r_bar x
1121      bar xs = reverse xs
1122
1123   r_bar :: C a => [a] -> [a]
1124   r_bar xs = bar (xs ++ xs)
1125
1126 That translates to:
1127
1128     r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
1129
1130     Rec { $fCInt :: C Int = MkC foo_help reverse
1131           foo_help (xs::[Int]) = r_bar Int $fCInt xs }
1132
1133 The call (r_bar $fCInt) mentions $fCInt,
1134                         which mentions foo_help,
1135                         which mentions r_bar
1136 But we DO want to specialise r_bar at Int:
1137
1138     Rec { $fCInt :: C Int = MkC foo_help reverse
1139           foo_help (xs::[Int]) = r_bar Int $fCInt xs
1140
1141           r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
1142             RULE r_bar Int _ = r_bar_Int
1143
1144           r_bar_Int xs = bar Int $fCInt (xs ++ xs)
1145            }
1146
1147 Note that, because of its RULE, r_bar joins the recursive
1148 group.  (In this case it'll unravel a short moment later.)
1149
1150
1151 Conclusion: we catch the nasty case using filter_dfuns in
1152 callsForMe To be honest I'm not 100% certain that this is 100%
1153 right, but it works.  Sigh.
1154
1155
1156 Note [Specialising a recursive group]
1157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1158 Consider
1159     let rec { f x = ...g x'...
1160             ; g y = ...f y'.... }
1161     in f 'a'
1162 Here we specialise 'f' at Char; but that is very likely to lead to
1163 a specialisation of 'g' at Char.  We must do the latter, else the
1164 whole point of specialisation is lost.
1165
1166 But we do not want to keep iterating to a fixpoint, because in the
1167 presence of polymorphic recursion we might generate an infinite number
1168 of specialisations.
1169
1170 So we use the following heuristic:
1171   * Arrange the rec block in dependency order, so far as possible
1172     (the occurrence analyser already does this)
1173
1174   * Specialise it much like a sequence of lets
1175
1176   * Then go through the block a second time, feeding call-info from
1177     the RHSs back in the bottom, as it were
1178
1179 In effect, the ordering maxmimises the effectiveness of each sweep,
1180 and we do just two sweeps.   This should catch almost every case of
1181 monomorphic recursion -- the exception could be a very knotted-up
1182 recursion with multiple cycles tied up together.
1183
1184 This plan is implemented in the Rec case of specBindItself.
1185
1186 Note [Specialisations already covered]
1187 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1188 We obviously don't want to generate two specialisations for the same
1189 argument pattern.  There are two wrinkles
1190
1191 1. We do the already-covered test in specDefn, not when we generate
1192 the CallInfo in mkCallUDs.  We used to test in the latter place, but
1193 we now iterate the specialiser somewhat, and the Id at the call site
1194 might therefore not have all the RULES that we can see in specDefn
1195
1196 2. What about two specialisations where the second is an *instance*
1197 of the first?  If the more specific one shows up first, we'll generate
1198 specialisations for both.  If the *less* specific one shows up first,
1199 we *don't* currently generate a specialisation for the more specific
1200 one.  (See the call to lookupRule in already_covered.)  Reasons:
1201   (a) lookupRule doesn't say which matches are exact (bad reason)
1202   (b) if the earlier specialisation is user-provided, it's
1203       far from clear that we should auto-specialise further
1204
1205 Note [Auto-specialisation and RULES]
1206 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1207 Consider:
1208    g :: Num a => a -> a
1209    g = ...
1210
1211    f :: (Int -> Int) -> Int
1212    f w = ...
1213    {-# RULE f g = 0 #-}
1214
1215 Suppose that auto-specialisation makes a specialised version of
1216 g::Int->Int That version won't appear in the LHS of the RULE for f.
1217 So if the specialisation rule fires too early, the rule for f may
1218 never fire.
1219
1220 It might be possible to add new rules, to "complete" the rewrite system.
1221 Thus when adding
1222         RULE forall d. g Int d = g_spec
1223 also add
1224         RULE f g_spec = 0
1225
1226 But that's a bit complicated.  For now we ask the programmer's help,
1227 by *copying the INLINE activation pragma* to the auto-specialised
1228 rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule
1229 will also not be active until phase 2.  And that's what programmers
1230 should jolly well do anyway, even aside from specialisation, to ensure
1231 that g doesn't inline too early.
1232
1233 This in turn means that the RULE would never fire for a NOINLINE
1234 thing so not much point in generating a specialisation at all.
1235
1236 Note [Specialisation shape]
1237 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1238 We only specialise a function if it has visible top-level lambdas
1239 corresponding to its overloading.  E.g. if
1240         f :: forall a. Eq a => ....
1241 then its body must look like
1242         f = /\a. \d. ...
1243
1244 Reason: when specialising the body for a call (f ty dexp), we want to
1245 substitute dexp for d, and pick up specialised calls in the body of f.
1246
1247 This doesn't always work.  One example I came across was this:
1248         newtype Gen a = MkGen{ unGen :: Int -> a }
1249
1250         choose :: Eq a => a -> Gen a
1251         choose n = MkGen (\r -> n)
1252
1253         oneof = choose (1::Int)
1254
1255 It's a silly exapmle, but we get
1256         choose = /\a. g `cast` co
1257 where choose doesn't have any dict arguments.  Thus far I have not
1258 tried to fix this (wait till there's a real example).
1259
1260 Note [Inline specialisations]
1261 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1262 We transfer to the specialised function any INLINE stuff from the
1263 original.  This means
1264    (a) the Activation for its inlining (from its InlinePragma)
1265    (b) any InlineRule
1266
1267 This is a change (Jun06).  Previously the idea is that the point of
1268 inlining was precisely to specialise the function at its call site,
1269 and that's not so important for the specialised copies.  But
1270 *pragma-directed* specialisation now takes place in the
1271 typechecker/desugarer, with manually specified INLINEs.  The
1272 specialiation here is automatic.  It'd be very odd if a function
1273 marked INLINE was specialised (because of some local use), and then
1274 forever after (including importing modules) the specialised version
1275 wasn't INLINEd.  After all, the programmer said INLINE!
1276
1277 You might wonder why we don't just not specialise INLINE functions.
1278 It's because even INLINE functions are sometimes not inlined, when
1279 they aren't applied to interesting arguments.  But perhaps the type
1280 arguments alone are enough to specialise (even though the args are too
1281 boring to trigger inlining), and it's certainly better to call the
1282 specialised version.
1283
1284
1285 %************************************************************************
1286 %*                                                                      *
1287 \subsubsection{UsageDetails and suchlike}
1288 %*                                                                      *
1289 %************************************************************************
1290
1291 \begin{code}
1292 data UsageDetails
1293   = MkUD {
1294         ud_binds :: !(Bag DictBind),
1295                         -- Floated dictionary bindings
1296                         -- The order is important;
1297                         -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
1298                         -- (Remember, Bags preserve order in GHC.)
1299
1300         ud_calls :: !CallDetails
1301
1302         -- INVARIANT: suppose bs = bindersOf ud_binds
1303         -- Then 'calls' may *mention* 'bs',
1304         -- but there should be no calls *for* bs
1305     }
1306
1307 instance Outputable UsageDetails where
1308   ppr (MkUD { ud_binds = dbs, ud_calls = calls })
1309         = ptext (sLit "MkUD") <+> braces (sep (punctuate comma
1310                 [ptext (sLit "binds") <+> equals <+> ppr dbs,
1311                  ptext (sLit "calls") <+> equals <+> ppr calls]))
1312
1313 type DictBind = (CoreBind, VarSet)
1314         -- The set is the free vars of the binding
1315         -- both tyvars and dicts
1316
1317 type DictExpr = CoreExpr
1318
1319 emptyUDs :: UsageDetails
1320 emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv }
1321
1322 ------------------------------------------------------------
1323 type CallDetails  = IdEnv CallInfoSet
1324 newtype CallKey   = CallKey [Maybe Type]                        -- Nothing => unconstrained type argument
1325
1326 -- CallInfo uses a Map, thereby ensuring that
1327 -- we record only one call instance for any key
1328 --
1329 -- The list of types and dictionaries is guaranteed to
1330 -- match the type of f
1331 type CallInfoSet = Map CallKey ([DictExpr], VarSet)
1332                         -- Range is dict args and the vars of the whole
1333                         -- call (including tyvars)
1334                         -- [*not* include the main id itself, of course]
1335
1336 type CallInfo = (CallKey, ([DictExpr], VarSet))
1337
1338 instance Outputable CallKey where
1339   ppr (CallKey ts) = ppr ts
1340
1341 -- Type isn't an instance of Ord, so that we can control which
1342 -- instance we use.  That's tiresome here.  Oh well
1343 instance Eq CallKey where
1344   k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False }
1345
1346 instance Ord CallKey where
1347   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
1348                 where
1349                   cmp Nothing   Nothing   = EQ
1350                   cmp Nothing   (Just _)  = LT
1351                   cmp (Just _)  Nothing   = GT
1352                   cmp (Just t1) (Just t2) = tcCmpType t1 t2
1353
1354 unionCalls :: CallDetails -> CallDetails -> CallDetails
1355 unionCalls c1 c2 = plusVarEnv_C Map.union c1 c2
1356
1357 -- plusCalls :: UsageDetails -> CallDetails -> UsageDetails
1358 -- plusCalls uds call_ds = uds { ud_calls = ud_calls uds `unionCalls` call_ds }
1359
1360 callDetailsFVs :: CallDetails -> VarSet
1361 callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls
1362
1363 callInfoFVs :: CallInfoSet -> VarSet
1364 callInfoFVs call_info = Map.foldRightWithKey (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info
1365
1366 ------------------------------------------------------------
1367 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
1368 singleCall id tys dicts
1369   = MkUD {ud_binds = emptyBag,
1370           ud_calls = unitVarEnv id (Map.singleton (CallKey tys) (dicts, call_fvs)) }
1371   where
1372     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
1373     tys_fvs  = tyVarsOfTypes (catMaybes tys)
1374         -- The type args (tys) are guaranteed to be part of the dictionary
1375         -- types, because they are just the constrained types,
1376         -- and the dictionary is therefore sure to be bound
1377         -- inside the binding for any type variables free in the type;
1378         -- hence it's safe to neglect tyvars free in tys when making
1379         -- the free-var set for this call
1380         -- BUT I don't trust this reasoning; play safe and include tys_fvs
1381         --
1382         -- We don't include the 'id' itself.
1383
1384 mkCallUDs :: Id -> [CoreExpr] -> UsageDetails
1385 mkCallUDs f args
1386   | not (isLocalId f)   -- Imported from elsewhere
1387   || null theta         -- Not overloaded
1388   || not (all isClassPred theta)
1389         -- Only specialise if all overloading is on class params.
1390         -- In ptic, with implicit params, the type args
1391         --  *don't* say what the value of the implicit param is!
1392   || not (spec_tys `lengthIs` n_tyvars)
1393   || not ( dicts   `lengthIs` n_dicts)
1394   || not (any interestingDict dicts)    -- Note [Interesting dictionary arguments]
1395   -- See also Note [Specialisations already covered]
1396   = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
1397     emptyUDs    -- Not overloaded, or no specialisation wanted
1398
1399   | otherwise
1400   = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
1401     singleCall f spec_tys dicts
1402   where
1403     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
1404     constrained_tyvars = tyVarsOfTheta theta
1405     n_tyvars           = length tyvars
1406     n_dicts            = length theta
1407
1408     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
1409     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
1410
1411     mk_spec_ty tyvar ty
1412         | tyvar `elemVarSet` constrained_tyvars = Just ty
1413         | otherwise                             = Nothing
1414 \end{code}
1415
1416 Note [Interesting dictionary arguments]
1417 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1418 Consider this
1419          \a.\d:Eq a.  let f = ... in ...(f d)...
1420 There really is not much point in specialising f wrt the dictionary d,
1421 because the code for the specialised f is not improved at all, because
1422 d is lambda-bound.  We simply get junk specialisations.
1423
1424 What is "interesting"?  Just that it has *some* structure.
1425
1426 \begin{code}
1427 interestingDict :: CoreExpr -> Bool
1428 -- A dictionary argument is interesting if it has *some* structure
1429 interestingDict (Var v) =  hasSomeUnfolding (idUnfolding v)
1430                         || isDataConWorkId v
1431 interestingDict (Type _)          = False
1432 interestingDict (App fn (Type _)) = interestingDict fn
1433 interestingDict (Note _ a)        = interestingDict a
1434 interestingDict (Cast e _)        = interestingDict e
1435 interestingDict _                 = True
1436 \end{code}
1437
1438 \begin{code}
1439 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
1440 plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
1441         (MkUD {ud_binds = db2, ud_calls = calls2})
1442   = MkUD { ud_binds = db1    `unionBags`   db2
1443          , ud_calls = calls1 `unionCalls`  calls2 }
1444
1445 plusUDList :: [UsageDetails] -> UsageDetails
1446 plusUDList = foldr plusUDs emptyUDs
1447
1448 -----------------------------
1449 _dictBindBndrs :: Bag DictBind -> [Id]
1450 _dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
1451
1452 mkDB :: CoreBind -> DictBind
1453 mkDB bind = (bind, bind_fvs bind)
1454
1455 bind_fvs :: CoreBind -> VarSet
1456 bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
1457 bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
1458                            where
1459                              bndrs = map fst prs
1460                              rhs_fvs = unionVarSets (map pair_fvs prs)
1461
1462 pair_fvs :: (Id, CoreExpr) -> VarSet
1463 pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
1464         -- Don't forget variables mentioned in the
1465         -- rules of the bndr.  C.f. OccAnal.addRuleUsage
1466         -- Also tyvars mentioned in its type; they may not appear in the RHS
1467         --      type T a = Int
1468         --      x :: T a = 3
1469
1470 flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
1471 flattenDictBinds dbs pairs
1472   = foldrBag add pairs dbs
1473   where
1474     add (NonRec b r,_) pairs = (b,r) : pairs
1475     add (Rec prs1, _)  pairs = prs1 ++ pairs
1476
1477 snocDictBinds :: UsageDetails -> [CoreBind] -> UsageDetails
1478 -- Add ud_binds to the tail end of the bindings in uds
1479 snocDictBinds uds dbs
1480   = uds { ud_binds = ud_binds uds `unionBags`
1481                      foldr (consBag . mkDB) emptyBag dbs }
1482
1483 consDictBind :: CoreBind -> UsageDetails -> UsageDetails
1484 consDictBind bind uds = uds { ud_binds = mkDB bind `consBag` ud_binds uds }
1485
1486 addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
1487 addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }
1488
1489 snocDictBind :: UsageDetails -> CoreBind -> UsageDetails
1490 snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` mkDB bind }
1491
1492 wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
1493 wrapDictBinds dbs binds
1494   = foldrBag add binds dbs
1495   where
1496     add (bind,_) binds = bind : binds
1497
1498 wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
1499 wrapDictBindsE dbs expr
1500   = foldrBag add expr dbs
1501   where
1502     add (bind,_) expr = Let bind expr
1503
1504 ----------------------
1505 dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
1506 -- Used at a lambda or case binder; just dump anything mentioning the binder
1507 dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1508   | null bndrs = (uds, emptyBag)  -- Common in case alternatives
1509   | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
1510                  (free_uds, dump_dbs)
1511   where
1512     free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
1513     bndr_set = mkVarSet bndrs
1514     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
1515     free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor
1516                  deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be
1517                                                     -- no calls for any of the dicts in dump_dbs
1518
1519 dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
1520 -- Used at a lambda or case binder; just dump anything mentioning the binder
1521 dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1522   = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
1523     (free_uds, dump_dbs, float_all)
1524   where
1525     free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
1526     bndr_set = mkVarSet bndrs
1527     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
1528     free_calls = deleteCallsFor bndrs orig_calls
1529     float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
1530
1531 callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
1532 callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1533   = -- pprTrace ("callsForMe")
1534     --         (vcat [ppr fn,
1535     --                text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),
1536     --                text "Orig calls ="   <+> ppr orig_calls,
1537     --                text "Dep set ="      <+> ppr dep_set,
1538     --                text "Calls for me =" <+> ppr calls_for_me]) $
1539     (uds_without_me, calls_for_me)
1540   where
1541     uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn }
1542     calls_for_me = case lookupVarEnv orig_calls fn of
1543                         Nothing -> []
1544                         Just cs -> filter_dfuns (Map.toList cs)
1545
1546     dep_set = foldlBag go (unitVarSet fn) orig_dbs
1547     go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set
1548                         = extendVarSetList dep_set (bindersOf db)
1549                         | otherwise = dep_set
1550
1551         -- Note [Specialisation of dictionary functions]
1552     filter_dfuns | isDFunId fn = filter ok_call
1553                  | otherwise   = \cs -> cs
1554
1555     ok_call (_, (_,fvs)) = not (fvs `intersectsVarSet` dep_set)
1556
1557 ----------------------
1558 splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
1559 -- Returns (free_dbs, dump_dbs, dump_set)
1560 splitDictBinds dbs bndr_set
1561    = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs
1562                 -- Important that it's foldl not foldr;
1563                 -- we're accumulating the set of dumped ids in dump_set
1564    where
1565     split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
1566         | dump_idset `intersectsVarSet` fvs     -- Dump it
1567         = (free_dbs, dump_dbs `snocBag` db,
1568            extendVarSetList dump_idset (bindersOf bind))
1569
1570         | otherwise     -- Don't dump it
1571         = (free_dbs `snocBag` db, dump_dbs, dump_idset)
1572
1573
1574 ----------------------
1575 deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
1576 -- Remove calls *mentioning* bs
1577 deleteCallsMentioning bs calls
1578   = mapVarEnv filter_calls calls
1579   where
1580     filter_calls :: CallInfoSet -> CallInfoSet
1581     filter_calls = Map.filterWithKey (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
1582
1583 deleteCallsFor :: [Id] -> CallDetails -> CallDetails
1584 -- Remove calls *for* bs
1585 deleteCallsFor bs calls = delVarEnvList calls bs
1586 \end{code}
1587
1588
1589 %************************************************************************
1590 %*                                                                      *
1591 \subsubsection{Boring helper functions}
1592 %*                                                                      *
1593 %************************************************************************
1594
1595 \begin{code}
1596 type SpecM a = UniqSM a
1597
1598 initSM :: UniqSupply -> SpecM a -> a
1599 initSM    = initUs_
1600
1601 mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
1602 mapAndCombineSM _ []     = return ([], emptyUDs)
1603 mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
1604                               (ys, uds2) <- mapAndCombineSM f xs
1605                               return (y:ys, uds1 `plusUDs` uds2)
1606
1607 cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
1608 -- Clone the binders of the bind; return new bind with the cloned binders
1609 -- Return the substitution to use for RHSs, and the one to use for the body
1610 cloneBindSM subst (NonRec bndr rhs) = do
1611     us <- getUniqueSupplyM
1612     let (subst', bndr') = cloneIdBndr subst us bndr
1613     return (subst, subst', NonRec bndr' rhs)
1614
1615 cloneBindSM subst (Rec pairs) = do
1616     us <- getUniqueSupplyM
1617     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
1618     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
1619
1620 newDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
1621 -- Make up completely fresh binders for the dictionaries
1622 -- Their bindings are going to float outwards
1623 newDictBndrs subst bndrs
1624   = do { bndrs' <- mapM new bndrs
1625        ; let subst' = extendIdSubstList subst
1626                         [(d, Var d') | (d,d') <- bndrs `zip` bndrs']
1627        ; return (subst', bndrs' ) }
1628   where
1629     new b = do { uniq <- getUniqueM
1630                ; let n   = idName b
1631                      ty' = CoreSubst.substTy subst (idType b)
1632                ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }
1633
1634 newSpecIdSM :: Id -> Type -> SpecM Id
1635     -- Give the new Id a similar occurrence name to the old one
1636 newSpecIdSM old_id new_ty
1637   = do  { uniq <- getUniqueM
1638         ; let name    = idName old_id
1639               new_occ = mkSpecOcc (nameOccName name)
1640               new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
1641         ; return new_id }
1642 \end{code}
1643
1644
1645                 Old (but interesting) stuff about unboxed bindings
1646                 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1647
1648 What should we do when a value is specialised to a *strict* unboxed value?
1649
1650         map_*_* f (x:xs) = let h = f x
1651                                t = map f xs
1652                            in h:t
1653
1654 Could convert let to case:
1655
1656         map_*_Int# f (x:xs) = case f x of h# ->
1657                               let t = map f xs
1658                               in h#:t
1659
1660 This may be undesirable since it forces evaluation here, but the value
1661 may not be used in all branches of the body. In the general case this
1662 transformation is impossible since the mutual recursion in a letrec
1663 cannot be expressed as a case.
1664
1665 There is also a problem with top-level unboxed values, since our
1666 implementation cannot handle unboxed values at the top level.
1667
1668 Solution: Lift the binding of the unboxed value and extract it when it
1669 is used:
1670
1671         map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
1672                                   t = map f xs
1673                               in case h of
1674                                  _Lift h# -> h#:t
1675
1676 Now give it to the simplifier and the _Lifting will be optimised away.
1677
1678 The benfit is that we have given the specialised "unboxed" values a
1679 very simplep lifted semantics and then leave it up to the simplifier to
1680 optimise it --- knowing that the overheads will be removed in nearly
1681 all cases.
1682
1683 In particular, the value will only be evaluted in the branches of the
1684 program which use it, rather than being forced at the point where the
1685 value is bound. For example:
1686
1687         filtermap_*_* p f (x:xs)
1688           = let h = f x
1689                 t = ...
1690             in case p x of
1691                 True  -> h:t
1692                 False -> t
1693    ==>
1694         filtermap_*_Int# p f (x:xs)
1695           = let h = case (f x) of h# -> _Lift h#
1696                 t = ...
1697             in case p x of
1698                 True  -> case h of _Lift h#
1699                            -> h#:t
1700                 False -> t
1701
1702 The binding for h can still be inlined in the one branch and the
1703 _Lifting eliminated.
1704
1705
1706 Question: When won't the _Lifting be eliminated?
1707
1708 Answer: When they at the top-level (where it is necessary) or when
1709 inlining would duplicate work (or possibly code depending on
1710 options). However, the _Lifting will still be eliminated if the
1711 strictness analyser deems the lifted binding strict.
1712