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