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