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