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 DynFlags ( DynFlags, DynFlag(..) )
  18 import Id               ( Id, idName, idType, mkUserLocal, idCoreRules,
  19                           idInlinePragma, setInlinePragma, setIdUnfolding,
  20                           isLocalId )
  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                           extendIdSubst
  29                         )
  30 import CoreUnfold       ( mkUnfolding )
  31 import SimplUtils       ( interestingArg )
  32 import Var              ( DictId )
  33 import VarSet
  34 import VarEnv
  35 import CoreSyn
  36 import Rules
  37 import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkPiTypes )
  38 import CoreFVs          ( exprFreeVars, exprsFreeVars, idFreeVars )
  39 import CoreLint         ( showPass, endPass )
  40 import UniqSupply       ( UniqSupply,
  41                           UniqSM, initUs_,
  42                           MonadUnique(..)
  43                         )
  44 import Name
  45 import MkId             ( voidArgId, realWorldPrimId )
  46 import FiniteMap
  47 import Maybes           ( catMaybes, isJust )
  48 import ErrUtils         ( dumpIfSet_dyn )
  49 import Bag
  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 A note about non-tyvar dictionaries
 495 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 496 Some Ids have types like
 497
 498         forall a,b,c. Eq a -> Ord [a] -> tau
 499
 500 This seems curious at first, because we usually only have dictionary
 501 args whose types are of the form (C a) where a is a type variable.
 502 But this doesn't hold for the functions arising from instance decls,
 503 which sometimes get arguements with types of form (C (T a)) for some
 504 type constructor T.
 505
 506 Should we specialise wrt this compound-type dictionary?  We used to say
 507 "no", saying:
 508         "This is a heuristic judgement, as indeed is the fact that we
 509         specialise wrt only dictionaries.  We choose *not* to specialise
 510         wrt compound dictionaries because at the moment the only place
 511         they show up is in instance decls, where they are simply plugged
 512         into a returned dictionary.  So nothing is gained by specialising
 513         wrt them."
 514
 515 But it is simpler and more uniform to specialise wrt these dicts too;
 516 and in future GHC is likely to support full fledged type signatures
 517 like
 518         f :: Eq [(a,b)] => ...
 519
 520
 521 %************************************************************************
 522 %*                                                                      *
 523 \subsubsection{The new specialiser}
 524 %*                                                                      *
 525 %************************************************************************
 526
 527 Our basic game plan is this.  For let(rec) bound function
 528         f :: (C a, D c) => (a,b,c,d) -> Bool
 529
 530 * Find any specialised calls of f, (f ts ds), where
 531   ts are the type arguments t1 .. t4, and
 532   ds are the dictionary arguments d1 .. d2.
 533
 534 * Add a new definition for f1 (say):
 535
 536         f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
 537
 538   Note that we abstract over the unconstrained type arguments.
 539
 540 * Add the mapping
 541
 542         [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
 543
 544   to the specialisations of f.  This will be used by the
 545   simplifier to replace calls
 546                 (f t1 t2 t3 t4) da db
 547   by
 548                 (\d1 d1 -> f1 t2 t4) da db
 549
 550   All the stuff about how many dictionaries to discard, and what types
 551   to apply the specialised function to, are handled by the fact that the
 552   SpecEnv contains a template for the result of the specialisation.
 553
 554 We don't build *partial* specialisations for f.  For example:
 555
 556   f :: Eq a => a -> a -> Bool
 557   {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
 558
 559 Here, little is gained by making a specialised copy of f.
 560 There's a distinct danger that the specialised version would
 561 first build a dictionary for (Eq b, Eq c), and then select the (==)
 562 method from it!  Even if it didn't, not a great deal is saved.
 563
 564 We do, however, generate polymorphic, but not overloaded, specialisations:
 565
 566   f :: Eq a => [a] -> b -> b -> b
 567   {#- SPECIALISE f :: [Int] -> b -> b -> b #-}
 568
 569 Hence, the invariant is this:
 570
 571         *** no specialised version is overloaded ***
 572
 573
 574 %************************************************************************
 575 %*                                                                      *
 576 \subsubsection{The exported function}
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 \begin{code}
 581 specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
 582 specProgram dflags us binds = do
 583
 584         showPass dflags "Specialise"
 585
 586         let binds' = initSM us (do (binds', uds') <- go binds
 587                                    return (dumpAllDictBinds uds' binds'))
 588
 589         endPass dflags "Specialise" Opt_D_dump_spec binds'
 590
 591         dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
 592                       (pprRulesForUser (rulesOfBinds binds'))
 593
 594         return binds'
 595   where
 596         -- We need to start with a Subst that knows all the things
 597         -- that are in scope, so that the substitution engine doesn't
 598         -- accidentally re-use a unique that's already in use
 599         -- Easiest thing is to do it all at once, as if all the top-level
 600         -- decls were mutually recursive
 601     top_subst       = mkEmptySubst (mkInScopeSet (mkVarSet (bindersOfBinds binds)))
 602
 603     go []           = return ([], emptyUDs)
 604     go (bind:binds) = do (binds', uds) <- go binds
 605                          (bind', uds') <- specBind top_subst bind uds
 606                          return (bind' ++ binds', uds')
 607 \end{code}
 608
 609 %************************************************************************
 610 %*                                                                      *
 611 \subsubsection{@specExpr@: the main function}
 612 %*                                                                      *
 613 %************************************************************************
 614
 615 \begin{code}
 616 specVar :: Subst -> Id -> CoreExpr
 617 specVar subst v = lookupIdSubst subst v
 618
 619 specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 620 -- We carry a substitution down:
 621 --      a) we must clone any binding that might float outwards,
 622 --         to avoid name clashes
 623 --      b) we carry a type substitution to use when analysing
 624 --         the RHS of specialised bindings (no type-let!)
 625
 626 ---------------- First the easy cases --------------------
 627 specExpr subst (Type ty) = return (Type (substTy subst ty), emptyUDs)
 628 specExpr subst (Var v)   = return (specVar subst v,         emptyUDs)
 629 specExpr _     (Lit lit) = return (Lit lit,                 emptyUDs)
 630 specExpr subst (Cast e co) = do
 631     (e', uds) <- specExpr subst e
 632     return ((Cast e' (substTy subst co)), uds)
 633 specExpr subst (Note note body) = do
 634     (body', uds) <- specExpr subst body
 635     return (Note (specNote subst note) body', uds)
 636
 637
 638 ---------------- Applications might generate a call instance --------------------
 639 specExpr subst expr@(App {})
 640   = go expr []
 641   where
 642     go (App fun arg) args = do (arg', uds_arg) <- specExpr subst arg
 643                                (fun', uds_app) <- go fun (arg':args)
 644                                return (App fun' arg', uds_arg `plusUDs` uds_app)
 645
 646     go (Var f)       args = case specVar subst f of
 647                                 Var f' -> return (Var f', mkCallUDs f' args)
 648                                 e'     -> return (e', emptyUDs) -- I don't expect this!
 649     go other         _    = specExpr subst other
 650
 651 ---------------- Lambda/case require dumping of usage details --------------------
 652 specExpr subst e@(Lam _ _) = do
 653     (body', uds) <- specExpr subst' body
 654     let (filtered_uds, body'') = dumpUDs bndrs' uds body'
 655     return (mkLams bndrs' body'', filtered_uds)
 656   where
 657     (bndrs, body) = collectBinders e
 658     (subst', bndrs') = substBndrs subst bndrs
 659         -- More efficient to collect a group of binders together all at once
 660         -- and we don't want to split a lambda group with dumped bindings
 661
 662 specExpr subst (Case scrut case_bndr ty alts) = do
 663     (scrut', uds_scrut) <- specExpr subst scrut
 664     (alts', uds_alts) <- mapAndCombineSM spec_alt alts
 665     return (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts)
 666   where
 667     (subst_alt, case_bndr') = substBndr subst case_bndr
 668         -- No need to clone case binder; it can't float like a let(rec)
 669
 670     spec_alt (con, args, rhs) = do
 671           (rhs', uds) <- specExpr subst_rhs rhs
 672           let (uds', rhs'') = dumpUDs args uds rhs'
 673           return ((con, args', rhs''), uds')
 674         where
 675           (subst_rhs, args') = substBndrs subst_alt args
 676
 677 ---------------- Finally, let is the interesting case --------------------
 678 specExpr subst (Let bind body) = do
 679         -- Clone binders
 680     (rhs_subst, body_subst, bind') <- cloneBindSM subst bind
 681
 682         -- Deal with the body
 683     (body', body_uds) <- specExpr body_subst body
 684
 685         -- Deal with the bindings
 686     (binds', uds) <- specBind rhs_subst bind' body_uds
 687
 688         -- All done
 689     return (foldr Let body' binds', uds)
 690
 691 -- Must apply the type substitution to coerceions
 692 specNote :: Subst -> Note -> Note
 693 specNote _ note = note
 694 \end{code}
 695
 696 %************************************************************************
 697 %*                                                                      *
 698 \subsubsection{Dealing with a binding}
 699 %*                                                                      *
 700 %************************************************************************
 701
 702 \begin{code}
 703 specBind :: Subst                       -- Use this for RHSs
 704          -> CoreBind
 705          -> UsageDetails                -- Info on how the scope of the binding
 706          -> SpecM ([CoreBind],          -- New bindings
 707                    UsageDetails)        -- And info to pass upstream
 708
 709 specBind rhs_subst bind body_uds
 710   = do  { (bind', bind_uds) <- specBindItself rhs_subst bind (calls body_uds)
 711         ; return (finishSpecBind bind' bind_uds body_uds) }
 712
 713 finishSpecBind :: CoreBind -> UsageDetails -> UsageDetails -> ([CoreBind], UsageDetails)
 714 finishSpecBind bind
 715         (MkUD { dict_binds = rhs_dbs,  calls = rhs_calls,  ud_fvs = rhs_fvs })
 716         (MkUD { dict_binds = body_dbs, calls = body_calls, ud_fvs = body_fvs })
 717   | not (mkVarSet bndrs `intersectsVarSet` all_fvs)
 718                 -- Common case 1: the bound variables are not
 719                 --                mentioned in the dictionary bindings
 720   = ([bind], MkUD { dict_binds = body_dbs `unionBags` rhs_dbs
 721                         -- It's important that the `unionBags` is this way round,
 722                         -- because body_uds may bind dictionaries that are
 723                         -- used in the calls passed to specDefn.  So the
 724                         -- dictionary bindings in rhs_uds may mention
 725                         -- dictionaries bound in body_uds.
 726                   , calls  = all_calls
 727                   , ud_fvs = all_fvs })
 728
 729   | case bind of { NonRec {} -> True; Rec {} -> False }
 730                 -- Common case 2: no specialisation happened, and binding
 731                 --                is non-recursive.  But the binding may be
 732                 --                mentioned in body_dbs, so we should put it first
 733   = ([], MkUD { dict_binds = rhs_dbs `unionBags` ((bind, b_fvs) `consBag` body_dbs)
 734               , calls      = all_calls
 735               , ud_fvs     = all_fvs `unionVarSet` b_fvs })
 736
 737   | otherwise   -- General case: make a huge Rec (sigh)
 738   = ([], MkUD { dict_binds = unitBag (Rec all_db_prs, all_db_fvs)
 739               , calls      = all_calls
 740               , ud_fvs     = all_fvs `unionVarSet` b_fvs })
 741   where
 742     all_fvs = rhs_fvs `unionVarSet` body_fvs
 743     all_calls = zapCalls bndrs (rhs_calls `unionCalls` body_calls)
 744
 745     bndrs   = bindersOf bind
 746     b_fvs   = bind_fvs bind
 747
 748     (all_db_prs, all_db_fvs) = add (bind, b_fvs) $
 749                                foldrBag add ([], emptyVarSet) $
 750                                rhs_dbs `unionBags` body_dbs
 751     add (NonRec b r, b_fvs) (prs, fvs) = ((b,r)  : prs, b_fvs `unionVarSet` fvs)
 752     add (Rec b_prs,  b_fvs) (prs, fvs) = (b_prs ++ prs, b_fvs `unionVarSet` fvs)
 753
 754 ---------------------------
 755 specBindItself :: Subst -> CoreBind -> CallDetails -> SpecM (CoreBind, UsageDetails)
 756
 757 -- specBindItself deals with the RHS, specialising it according
 758 -- to the calls found in the body (if any)
 759 specBindItself rhs_subst (NonRec fn rhs) call_info
 760   = do { (rhs', rhs_uds) <- specExpr rhs_subst rhs           -- Do RHS of original fn
 761        ; (fn', spec_defns, spec_uds) <- specDefn rhs_subst call_info fn rhs
 762        ; if null spec_defns then
 763             return (NonRec fn rhs', rhs_uds)
 764          else
 765             return (Rec ((fn',rhs') : spec_defns), rhs_uds `plusUDs` spec_uds) }
 766                 -- bndr' mentions the spec_defns in its SpecEnv
 767                 -- Not sure why we couln't just put the spec_defns first
 768
 769 specBindItself rhs_subst (Rec pairs) call_info
 770        -- Note [Specialising a recursive group]
 771   = do { let (bndrs,rhss) = unzip pairs
 772        ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_subst) rhss
 773        ; let all_calls = call_info `unionCalls` calls rhs_uds
 774        ; (bndrs1, spec_defns1, spec_uds1) <- specDefns rhs_subst all_calls pairs
 775
 776        ; if null spec_defns1 then   -- Common case: no specialisation
 777             return (Rec (bndrs `zip` rhss'), rhs_uds)
 778          else do                     -- Specialisation occurred; do it again
 779        { (bndrs2, spec_defns2, spec_uds2) <-
 780                   -- pprTrace "specB" (ppr bndrs $$ ppr rhs_uds) $
 781                   specDefns rhs_subst (calls spec_uds1) (bndrs1 `zip` rhss)
 782
 783        ; let all_defns = spec_defns1 ++ spec_defns2 ++ zip bndrs2 rhss'
 784
 785        ; return (Rec all_defns, rhs_uds `plusUDs` spec_uds1 `plusUDs` spec_uds2) } }
 786
 787
 788 ---------------------------
 789 specDefns :: Subst
 790          -> CallDetails                 -- Info on how it is used in its scope
 791          -> [(Id,CoreExpr)]             -- The things being bound and their un-processed RHS
 792          -> SpecM ([Id],                -- Original Ids with RULES added
 793                    [(Id,CoreExpr)],     -- Extra, specialised bindings
 794                    UsageDetails)        -- Stuff to fling upwards from the specialised versions
 795
 796 -- Specialise a list of bindings (the contents of a Rec), but flowing usages
 797 -- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
 798 -- Then if the input CallDetails has a specialised call for 'g', whose specialisation
 799 -- in turn generates a specialised call for 'f', we catch that in this one sweep.
 800 -- But not vice versa (it's a fixpoint problem).
 801
 802 specDefns _subst _call_info []
 803   = return ([], [], emptyUDs)
 804 specDefns subst call_info ((bndr,rhs):pairs)
 805   = do { (bndrs', spec_defns, spec_uds) <- specDefns subst call_info pairs
 806        ; let all_calls = call_info `unionCalls` calls spec_uds
 807        ; (bndr', spec_defns1, spec_uds1) <- specDefn subst all_calls bndr rhs
 808        ; return (bndr' : bndrs',
 809                  spec_defns1 ++ spec_defns,
 810                  spec_uds1 `plusUDs` spec_uds) }
 811
 812 ---------------------------
 813 specDefn :: Subst
 814          -> CallDetails                 -- Info on how it is used in its scope
 815          -> Id -> CoreExpr              -- The thing being bound and its un-processed RHS
 816          -> SpecM (Id,                  -- Original Id with added RULES
 817                    [(Id,CoreExpr)],     -- Extra, specialised bindings
 818                    UsageDetails)        -- Stuff to fling upwards from the specialised versions
 819
 820 specDefn subst calls fn rhs
 821         -- The first case is the interesting one
 822   |  rhs_tyvars `lengthIs`     n_tyvars -- Rhs of fn's defn has right number of big lambdas
 823   && rhs_ids    `lengthAtLeast` n_dicts -- and enough dict args
 824   && notNull calls_for_me               -- And there are some calls to specialise
 825
 826 --   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small
 827 --      See Note [Inline specialisation] for why we do not
 828 --      switch off specialisation for inline functions
 829
 830   = do {       -- Make a specialised version for each call in calls_for_me
 831          stuff <- mapM spec_call calls_for_me
 832        ; let (spec_defns, spec_uds, spec_rules) = unzip3 (catMaybes stuff)
 833              fn' = addIdSpecialisations fn spec_rules
 834        ; return (fn', spec_defns, plusUDList spec_uds) }
 835
 836   | otherwise   -- No calls or RHS doesn't fit our preconceptions
 837   = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") <+> ppr fn )
 838           -- Note [Specialisation shape]
 839     return (fn, [], emptyUDs)
 840
 841   where
 842     fn_type            = idType fn
 843     (tyvars, theta, _) = tcSplitSigmaTy fn_type
 844     n_tyvars           = length tyvars
 845     n_dicts            = length theta
 846     inline_prag        = idInlinePragma fn
 847
 848         -- It's important that we "see past" any INLINE pragma
 849         -- else we'll fail to specialise an INLINE thing
 850     (inline_rhs, rhs_inside) = dropInline rhs
 851     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside
 852
 853     rhs_dict_ids = take n_dicts rhs_ids
 854     body         = mkLams (drop n_dicts rhs_ids) rhs_body
 855                 -- Glue back on the non-dict lambdas
 856
 857     calls_for_me = case lookupFM calls fn of
 858                         Nothing -> []
 859                         Just cs -> fmToList cs
 860
 861     already_covered :: [CoreExpr] -> Bool
 862     already_covered args          -- Note [Specialisations already covered]
 863        = isJust (lookupRule (const True) (substInScope subst)
 864                             fn args (idCoreRules fn))
 865
 866     mk_ty_args :: [Maybe Type] -> [CoreExpr]
 867     mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
 868                where
 869                   mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
 870                   mk_ty_arg _         (Just ty) = Type ty
 871
 872     ----------------------------------------------------------
 873         -- Specialise to one particular call pattern
 874     spec_call :: (CallKey, ([DictExpr], VarSet))  -- Call instance
 875               -> SpecM (Maybe ((Id,CoreExpr),     -- Specialised definition
 876                                UsageDetails,      -- Usage details from specialised body
 877                                CoreRule))         -- Info for the Id's SpecEnv
 878     spec_call (CallKey call_ts, (call_ds, _))
 879       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
 880
 881         -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs
 882         -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
 883
 884         -- Construct the new binding
 885         --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
 886         -- PLUS the usage-details
 887         --      { d1' = dx1; d2' = dx2 }
 888         -- where d1', d2' are cloned versions of d1,d2, with the type substitution
 889         -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2
 890         --
 891         -- Note that the substitution is applied to the whole thing.
 892         -- This is convenient, but just slightly fragile.  Notably:
 893         --      * There had better be no name clashes in a/b/c
 894         do { let
 895                 -- poly_tyvars = [b] in the example above
 896                 -- spec_tyvars = [a,c]
 897                 -- ty_args     = [t1,b,t3]
 898                 poly_tyvars   = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
 899                 spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
 900                 spec_ty_args  = map snd spec_tv_binds
 901                 ty_args       = mk_ty_args call_ts
 902                 rhs_subst     = extendTvSubstList subst spec_tv_binds
 903
 904            ; (rhs_subst1, inst_dict_ids) <- cloneDictBndrs rhs_subst rhs_dict_ids
 905                           -- Clone rhs_dicts, including instantiating their types
 906
 907            ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
 908                                           (my_zipEqual rhs_dict_ids inst_dict_ids call_ds)
 909                  inst_args = ty_args ++ map Var inst_dict_ids
 910
 911            ; if already_covered inst_args then
 912                 return Nothing
 913              else do
 914            {    -- Figure out the type of the specialised function
 915              let body_ty = applyTypeToArgs rhs fn_type inst_args
 916                  (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
 917                    | isUnLiftedType body_ty     -- C.f. WwLib.mkWorkerArgs
 918                    = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
 919                    | otherwise = (poly_tyvars, poly_tyvars)
 920                  spec_id_ty = mkPiTypes lam_args body_ty
 921
 922            ; spec_f <- newSpecIdSM fn spec_id_ty
 923            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
 924            ; let
 925                 -- The rule to put in the function's specialisation is:
 926                 --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
 927                 rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
 928                 spec_env_rule = mkLocalRule
 929                                   rule_name
 930                                   inline_prag   -- Note [Auto-specialisation and RULES]
 931                                   (idName fn)
 932                                   (poly_tyvars ++ inst_dict_ids)
 933                                   inst_args
 934                                   (mkVarApps (Var spec_f) app_args)
 935
 936                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
 937                 final_uds = foldr addDictBind rhs_uds dx_binds
 938
 939                 spec_pr | inline_rhs = (spec_f `setInlinePragma` inline_prag, Note InlineMe spec_rhs)
 940                         | otherwise  = (spec_f,                               spec_rhs)
 941
 942            ; return (Just (spec_pr, final_uds, spec_env_rule)) } }
 943       where
 944         my_zipEqual xs ys zs
 945          | debugIsOn && not (equalLength xs ys && equalLength ys zs)
 946              = pprPanic "my_zipEqual" (vcat [ ppr xs, ppr ys
 947                                             , ppr fn <+> ppr call_ts
 948                                             , ppr (idType fn), ppr theta
 949                                             , ppr n_dicts, ppr rhs_dict_ids
 950                                             , ppr rhs])
 951          | otherwise = zip3 xs ys zs
 952
 953 bindAuxiliaryDicts
 954         :: Subst
 955         -> [(DictId,DictId,CoreExpr)]   -- (orig_dict, inst_dict, dx)
 956         -> (Subst,                      -- Substitute for all orig_dicts
 957             [(DictId, CoreExpr)])       -- Auxiliary bindings
 958 -- Bind any dictionary arguments to fresh names, to preserve sharing
 959 -- Substitution already substitutes orig_dict -> inst_dict
 960 bindAuxiliaryDicts subst triples = go subst [] triples
 961   where
 962     go subst binds []    = (subst, binds)
 963     go subst binds ((d, dx_id, dx) : pairs)
 964       | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
 965              -- No auxiliary binding necessary
 966       | otherwise        = go subst_w_unf ((dx_id,dx) : binds) pairs
 967       where
 968         dx_id1 = dx_id `setIdUnfolding` mkUnfolding False dx
 969         subst_w_unf = extendIdSubst subst d (Var dx_id1)
 970              -- Important!  We're going to substitute dx_id1 for d
 971              -- and we want it to look "interesting", else we won't gather *any*
 972              -- consequential calls. E.g.
 973              --     f d = ...g d....
 974              -- If we specialise f for a call (f (dfun dNumInt)), we'll get
 975              -- a consequent call (g d') with an auxiliary definition
 976              --     d' = df dNumInt
 977              -- We want that consequent call to look interesting
 978 \end{code}
 979
 980 Note [Specialising a recursive group]
 981 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 982 Consider
 983     let rec { f x = ...g x'...
 984             ; g y = ...f y'.... }
 985     in f 'a'
 986 Here we specialise 'f' at Char; but that is very likely to lead to
 987 a specialisation of 'g' at Char.  We must do the latter, else the
 988 whole point of specialisation is lost.
 989
 990 But we do not want to keep iterating to a fixpoint, because in the
 991 presence of polymorphic recursion we might generate an infinite number
 992 of specialisations.
 993
 994 So we use the following heuristic:
 995   * Arrange the rec block in dependency order, so far as possible
 996     (the occurrence analyser already does this)
 997
 998   * Specialise it much like a sequence of lets
 999
1000   * Then go through the block a second time, feeding call-info from
1001     the RHSs back in the bottom, as it were
1002
1003 In effect, the ordering maxmimises the effectiveness of each sweep,
1004 and we do just two sweeps.   This should catch almost every case of
1005 monomorphic recursion -- the exception could be a very knotted-up
1006 recursion with multiple cycles tied up together.
1007
1008 This plan is implemented in the Rec case of specBindItself.
1009
1010 Note [Specialisations already covered]
1011 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1012 We obviously don't want to generate two specialisations for the same
1013 argument pattern.  There are two wrinkles
1014
1015 1. We do the already-covered test in specDefn, not when we generate
1016 the CallInfo in mkCallUDs.  We used to test in the latter place, but
1017 we now iterate the specialiser somewhat, and the Id at the call site
1018 might therefore not have all the RULES that we can see in specDefn
1019
1020 2. What about two specialisations where the second is an *instance*
1021 of the first?  If the more specific one shows up first, we'll generate
1022 specialisations for both.  If the *less* specific one shows up first,
1023 we *don't* currently generate a specialisation for the more specific
1024 one.  (See the call to lookupRule in already_covered.)  Reasons:
1025   (a) lookupRule doesn't say which matches are exact (bad reason)
1026   (b) if the earlier specialisation is user-provided, it's
1027       far from clear that we should auto-specialise further
1028
1029 Note [Auto-specialisation and RULES]
1030 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1031 Consider:
1032    g :: Num a => a -> a
1033    g = ...
1034
1035    f :: (Int -> Int) -> Int
1036    f w = ...
1037    {-# RULE f g = 0 #-}
1038
1039 Suppose that auto-specialisation makes a specialised version of
1040 g::Int->Int That version won't appear in the LHS of the RULE for f.
1041 So if the specialisation rule fires too early, the rule for f may
1042 never fire.
1043
1044 It might be possible to add new rules, to "complete" the rewrite system.
1045 Thus when adding
1046         RULE forall d. g Int d = g_spec
1047 also add
1048         RULE f g_spec = 0
1049
1050 But that's a bit complicated.  For now we ask the programmer's help,
1051 by *copying the INLINE activation pragma* to the auto-specialised rule.
1052 So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also
1053 not be active until phase 2.
1054
1055
1056 Note [Specialisation shape]
1057 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1058 We only specialise a function if it has visible top-level lambdas
1059 corresponding to its overloading.  E.g. if
1060         f :: forall a. Eq a => ....
1061 then its body must look like
1062         f = /\a. \d. ...
1063
1064 Reason: when specialising the body for a call (f ty dexp), we want to
1065 substitute dexp for d, and pick up specialised calls in the body of f.
1066
1067 This doesn't always work.  One example I came across was this:
1068         newtype Gen a = MkGen{ unGen :: Int -> a }
1069
1070         choose :: Eq a => a -> Gen a
1071         choose n = MkGen (\r -> n)
1072
1073         oneof = choose (1::Int)
1074
1075 It's a silly exapmle, but we get
1076         choose = /\a. g `cast` co
1077 where choose doesn't have any dict arguments.  Thus far I have not
1078 tried to fix this (wait till there's a real example).
1079
1080
1081 Note [Inline specialisations]
1082 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1083 We transfer to the specialised function any INLINE stuff from the
1084 original.  This means (a) the Activation in the IdInfo, and (b) any
1085 InlineMe on the RHS.
1086
1087 This is a change (Jun06).  Previously the idea is that the point of
1088 inlining was precisely to specialise the function at its call site,
1089 and that's not so important for the specialised copies.  But
1090 *pragma-directed* specialisation now takes place in the
1091 typechecker/desugarer, with manually specified INLINEs.  The
1092 specialiation here is automatic.  It'd be very odd if a function
1093 marked INLINE was specialised (because of some local use), and then
1094 forever after (including importing modules) the specialised version
1095 wasn't INLINEd.  After all, the programmer said INLINE!
1096
1097 You might wonder why we don't just not specialise INLINE functions.
1098 It's because even INLINE functions are sometimes not inlined, when
1099 they aren't applied to interesting arguments.  But perhaps the type
1100 arguments alone are enough to specialise (even though the args are too
1101 boring to trigger inlining), and it's certainly better to call the
1102 specialised version.
1103
1104 A case in point is dictionary functions, which are current marked
1105 INLINE, but which are worth specialising.
1106
1107 \begin{code}
1108 dropInline :: CoreExpr -> (Bool, CoreExpr)
1109 dropInline (Note InlineMe rhs) = (True,  rhs)
1110 dropInline rhs                 = (False, rhs)
1111 \end{code}
1112
1113 %************************************************************************
1114 %*                                                                      *
1115 \subsubsection{UsageDetails and suchlike}
1116 %*                                                                      *
1117 %************************************************************************
1118
1119 \begin{code}
1120 data UsageDetails
1121   = MkUD {
1122         dict_binds :: !(Bag DictBind),
1123                         -- Floated dictionary bindings
1124                         -- The order is important;
1125                         -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
1126                         -- (Remember, Bags preserve order in GHC.)
1127
1128         calls     :: !CallDetails,
1129
1130         ud_fvs :: !VarSet       -- A superset of the variables mentioned in
1131                                 -- either dict_binds or calls
1132     }
1133
1134 instance Outputable UsageDetails where
1135   ppr (MkUD { dict_binds = dbs, calls = calls, ud_fvs = fvs })
1136         = ptext (sLit "MkUD") <+> braces (sep (punctuate comma
1137                 [ptext (sLit "binds") <+> equals <+> ppr dbs,
1138                  ptext (sLit "calls") <+> equals <+> ppr calls,
1139                  ptext (sLit "fvs")   <+> equals <+> ppr fvs]))
1140
1141 type DictBind = (CoreBind, VarSet)
1142         -- The set is the free vars of the binding
1143         -- both tyvars and dicts
1144
1145 type DictExpr = CoreExpr
1146
1147 emptyUDs :: UsageDetails
1148 emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM, ud_fvs = emptyVarSet }
1149
1150 ------------------------------------------------------------
1151 type CallDetails  = FiniteMap Id CallInfo
1152 newtype CallKey   = CallKey [Maybe Type]                        -- Nothing => unconstrained type argument
1153
1154 -- CallInfo uses a FiniteMap, thereby ensuring that
1155 -- we record only one call instance for any key
1156 --
1157 -- The list of types and dictionaries is guaranteed to
1158 -- match the type of f
1159 type CallInfo = FiniteMap CallKey ([DictExpr], VarSet)
1160                         -- Range is dict args and the vars of the whole
1161                         -- call (including tyvars)
1162                         -- [*not* include the main id itself, of course]
1163
1164 instance Outputable CallKey where
1165   ppr (CallKey ts) = ppr ts
1166
1167 -- Type isn't an instance of Ord, so that we can control which
1168 -- instance we use.  That's tiresome here.  Oh well
1169 instance Eq CallKey where
1170   k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False }
1171
1172 instance Ord CallKey where
1173   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
1174                 where
1175                   cmp Nothing   Nothing   = EQ
1176                   cmp Nothing   (Just _)  = LT
1177                   cmp (Just _)  Nothing   = GT
1178                   cmp (Just t1) (Just t2) = tcCmpType t1 t2
1179
1180 unionCalls :: CallDetails -> CallDetails -> CallDetails
1181 unionCalls c1 c2 = plusFM_C plusFM c1 c2
1182
1183 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
1184 singleCall id tys dicts
1185   = MkUD {dict_binds = emptyBag,
1186           calls      = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)),
1187           ud_fvs     = call_fvs }
1188   where
1189     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
1190     tys_fvs  = tyVarsOfTypes (catMaybes tys)
1191         -- The type args (tys) are guaranteed to be part of the dictionary
1192         -- types, because they are just the constrained types,
1193         -- and the dictionary is therefore sure to be bound
1194         -- inside the binding for any type variables free in the type;
1195         -- hence it's safe to neglect tyvars free in tys when making
1196         -- the free-var set for this call
1197         -- BUT I don't trust this reasoning; play safe and include tys_fvs
1198         --
1199         -- We don't include the 'id' itself.
1200
1201 mkCallUDs :: Id -> [CoreExpr] -> UsageDetails
1202 mkCallUDs f args
1203   | not (isLocalId f)   -- Imported from elsewhere
1204   || null theta         -- Not overloaded
1205   || not (all isClassPred theta)
1206         -- Only specialise if all overloading is on class params.
1207         -- In ptic, with implicit params, the type args
1208         --  *don't* say what the value of the implicit param is!
1209   || not (spec_tys `lengthIs` n_tyvars)
1210   || not ( dicts   `lengthIs` n_dicts)
1211   || not (any interestingArg dicts)     -- Note [Interesting dictionary arguments]
1212   -- See also Note [Specialisations already covered]
1213   = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)])
1214     emptyUDs    -- Not overloaded, or no specialisation wanted
1215
1216   | otherwise
1217   = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingArg dicts)])
1218     singleCall f spec_tys dicts
1219   where
1220     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
1221     constrained_tyvars = tyVarsOfTheta theta
1222     n_tyvars           = length tyvars
1223     n_dicts            = length theta
1224
1225     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
1226     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
1227
1228     mk_spec_ty tyvar ty
1229         | tyvar `elemVarSet` constrained_tyvars = Just ty
1230         | otherwise                             = Nothing
1231 \end{code}
1232
1233 Note [Interesting dictionary arguments]
1234 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1235 Consider this
1236          \a.\d:Eq a.  let f = ... in ...(f d)...
1237 There really is not much point in specialising f wrt the dictionary d,
1238 because the code for the specialised f is not improved at all, because
1239 d is lambda-bound.  We simply get junk specialisations.
1240
1241 We re-use the function SimplUtils.interestingArg function to determine
1242 what sort of dictionary arguments have *some* information in them.
1243
1244
1245 \begin{code}
1246 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
1247 plusUDs (MkUD {dict_binds = db1, calls = calls1, ud_fvs = fvs1})
1248         (MkUD {dict_binds = db2, calls = calls2, ud_fvs = fvs2})
1249   = MkUD {dict_binds = d, calls = c, ud_fvs = fvs1 `unionVarSet` fvs2}
1250   where
1251     d = db1    `unionBags`   db2
1252     c = calls1 `unionCalls`  calls2
1253
1254 plusUDList :: [UsageDetails] -> UsageDetails
1255 plusUDList = foldr plusUDs emptyUDs
1256
1257 -- zapCalls deletes calls to ids from uds
1258 zapCalls :: [Id] -> CallDetails -> CallDetails
1259 zapCalls ids calls = delListFromFM calls ids
1260
1261 mkDB :: CoreBind -> DictBind
1262 mkDB bind = (bind, bind_fvs bind)
1263
1264 bind_fvs :: CoreBind -> VarSet
1265 bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
1266 bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
1267                            where
1268                              bndrs = map fst prs
1269                              rhs_fvs = unionVarSets (map pair_fvs prs)
1270
1271 pair_fvs :: (Id, CoreExpr) -> VarSet
1272 pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
1273         -- Don't forget variables mentioned in the
1274         -- rules of the bndr.  C.f. OccAnal.addRuleUsage
1275         -- Also tyvars mentioned in its type; they may not appear in the RHS
1276         --      type T a = Int
1277         --      x :: T a = 3
1278
1279 addDictBind :: (Id,CoreExpr) -> UsageDetails -> UsageDetails
1280 addDictBind (dict,rhs) uds
1281   = uds { dict_binds = db `consBag` dict_binds uds
1282         , ud_fvs = ud_fvs uds `unionVarSet` fvs }
1283   where
1284     db@(_, fvs) = mkDB (NonRec dict rhs)
1285
1286 dumpAllDictBinds :: UsageDetails -> [CoreBind] -> [CoreBind]
1287 dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
1288   = foldrBag add binds dbs
1289   where
1290     add (bind,_) binds = bind : binds
1291
1292 dumpUDs :: [CoreBndr]
1293         -> UsageDetails -> CoreExpr
1294         -> (UsageDetails, CoreExpr)
1295 dumpUDs bndrs (MkUD { dict_binds = orig_dbs
1296                     , calls = orig_calls
1297                     , ud_fvs = fvs}) body
1298   = (new_uds, foldrBag add_let body dump_dbs)
1299                 -- This may delete fewer variables
1300                 -- than in priciple possible
1301   where
1302     new_uds =
1303      MkUD { dict_binds = free_dbs
1304           , calls      = free_calls
1305           , ud_fvs     = fvs `minusVarSet` bndr_set}
1306
1307     bndr_set = mkVarSet bndrs
1308     add_let (bind,_) body = Let bind body
1309
1310     (free_dbs, dump_dbs, dump_set)
1311         = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
1312                 -- Important that it's foldl not foldr;
1313                 -- we're accumulating the set of dumped ids in dump_set
1314
1315     free_calls = filterCalls dump_set orig_calls
1316
1317     dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
1318         | dump_idset `intersectsVarSet` fvs     -- Dump it
1319         = (free_dbs, dump_dbs `snocBag` db,
1320            extendVarSetList dump_idset (bindersOf bind))
1321
1322         | otherwise     -- Don't dump it
1323         = (free_dbs `snocBag` db, dump_dbs, dump_idset)
1324
1325 filterCalls :: VarSet -> CallDetails -> CallDetails
1326 -- Remove any calls that mention the variables
1327 filterCalls bs calls
1328   = mapFM (\_ cs -> filter_calls cs) $
1329     filterFM (\k _ -> not (k `elemVarSet` bs)) calls
1330   where
1331     filter_calls :: CallInfo -> CallInfo
1332     filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
1333 \end{code}
1334
1335
1336 %************************************************************************
1337 %*                                                                      *
1338 \subsubsection{Boring helper functions}
1339 %*                                                                      *
1340 %************************************************************************
1341
1342 \begin{code}
1343 type SpecM a = UniqSM a
1344
1345 initSM :: UniqSupply -> SpecM a -> a
1346 initSM    = initUs_
1347
1348 mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
1349 mapAndCombineSM _ []     = return ([], emptyUDs)
1350 mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
1351                               (ys, uds2) <- mapAndCombineSM f xs
1352                               return (y:ys, uds1 `plusUDs` uds2)
1353
1354 cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
1355 -- Clone the binders of the bind; return new bind with the cloned binders
1356 -- Return the substitution to use for RHSs, and the one to use for the body
1357 cloneBindSM subst (NonRec bndr rhs) = do
1358     us <- getUniqueSupplyM
1359     let (subst', bndr') = cloneIdBndr subst us bndr
1360     return (subst, subst', NonRec bndr' rhs)
1361
1362 cloneBindSM subst (Rec pairs) = do
1363     us <- getUniqueSupplyM
1364     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
1365     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
1366
1367 cloneDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
1368 cloneDictBndrs subst bndrs
1369   = do { us <- getUniqueSupplyM
1370        ; return (cloneIdBndrs subst us bndrs) }
1371
1372 newSpecIdSM :: Id -> Type -> SpecM Id
1373     -- Give the new Id a similar occurrence name to the old one
1374 newSpecIdSM old_id new_ty
1375   = do  { uniq <- getUniqueM
1376         ; let
1377             name    = idName old_id
1378             new_occ = mkSpecOcc (nameOccName name)
1379             new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
1380         ; return new_id }
1381 \end{code}
1382
1383
1384                 Old (but interesting) stuff about unboxed bindings
1385                 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1386
1387 What should we do when a value is specialised to a *strict* unboxed value?
1388
1389         map_*_* f (x:xs) = let h = f x
1390                                t = map f xs
1391                            in h:t
1392
1393 Could convert let to case:
1394
1395         map_*_Int# f (x:xs) = case f x of h# ->
1396                               let t = map f xs
1397                               in h#:t
1398
1399 This may be undesirable since it forces evaluation here, but the value
1400 may not be used in all branches of the body. In the general case this
1401 transformation is impossible since the mutual recursion in a letrec
1402 cannot be expressed as a case.
1403
1404 There is also a problem with top-level unboxed values, since our
1405 implementation cannot handle unboxed values at the top level.
1406
1407 Solution: Lift the binding of the unboxed value and extract it when it
1408 is used:
1409
1410         map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
1411                                   t = map f xs
1412                               in case h of
1413                                  _Lift h# -> h#:t
1414
1415 Now give it to the simplifier and the _Lifting will be optimised away.
1416
1417 The benfit is that we have given the specialised "unboxed" values a
1418 very simplep lifted semantics and then leave it up to the simplifier to
1419 optimise it --- knowing that the overheads will be removed in nearly
1420 all cases.
1421
1422 In particular, the value will only be evaluted in the branches of the
1423 program which use it, rather than being forced at the point where the
1424 value is bound. For example:
1425
1426         filtermap_*_* p f (x:xs)
1427           = let h = f x
1428                 t = ...
1429             in case p x of
1430                 True  -> h:t
1431                 False -> t
1432    ==>
1433         filtermap_*_Int# p f (x:xs)
1434           = let h = case (f x) of h# -> _Lift h#
1435                 t = ...
1436             in case p x of
1437                 True  -> case h of _Lift h#
1438                            -> h#:t
1439                 False -> t
1440
1441 The binding for h can still be inlined in the one branch and the
1442 _Lifting eliminated.
1443
1444
1445 Question: When won't the _Lifting be eliminated?
1446
1447 Answer: When they at the top-level (where it is necessary) or when
1448 inlining would duplicate work (or possibly code depending on
1449 options). However, the _Lifting will still be eliminated if the
1450 strictness analyser deems the lifted binding strict.
1451