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, mkInlineRule )
  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     fn_unf             = realIdUnfolding fn     -- Ignore loop-breaker-ness here
 804     (tyvars, theta, _) = tcSplitSigmaTy fn_type
 805     n_tyvars           = length tyvars
 806     n_dicts            = length theta
 807     inline_act         = idInlineActivation fn
 808
 809         -- Figure out whether the function has an INLINE pragma
 810         -- See Note [Inline specialisations]
 811     fn_has_inline_rule :: Maybe Bool    -- Derive sat-flag from existing thing
 812     fn_has_inline_rule = case isInlineRule_maybe fn_unf of
 813                            Just (_,sat) -> Just sat
 814                            Nothing      -> Nothing
 815
 816     spec_arity = unfoldingArity fn_unf - n_dicts  -- Arity of the *specialised* inline rule
 817
 818     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
 819
 820     (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
 821
 822     rhs_dict_ids = take n_dicts rhs_ids
 823     body         = mkLams (drop n_dicts rhs_ids) rhs_body
 824                 -- Glue back on the non-dict lambdas
 825
 826     already_covered :: [CoreExpr] -> Bool
 827     already_covered args          -- Note [Specialisations already covered]
 828        = isJust (lookupRule (const True) realIdUnfolding
 829                             (substInScope subst)
 830                             fn args (idCoreRules fn))
 831
 832     mk_ty_args :: [Maybe Type] -> [CoreExpr]
 833     mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
 834                where
 835                   mk_ty_arg rhs_tyvar Nothing   = Type (mkTyVarTy rhs_tyvar)
 836                   mk_ty_arg _         (Just ty) = Type ty
 837
 838     ----------------------------------------------------------
 839         -- Specialise to one particular call pattern
 840     spec_call :: CallInfo                         -- Call instance
 841               -> SpecM (Maybe ((Id,CoreExpr),     -- Specialised definition
 842                                UsageDetails,      -- Usage details from specialised body
 843                                CoreRule))         -- Info for the Id's SpecEnv
 844     spec_call (CallKey call_ts, (call_ds, _))
 845       = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
 846
 847         -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs
 848         -- Supppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
 849
 850         -- Construct the new binding
 851         --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
 852         -- PLUS the usage-details
 853         --      { d1' = dx1; d2' = dx2 }
 854         -- where d1', d2' are cloned versions of d1,d2, with the type substitution
 855         -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2
 856         --
 857         -- Note that the substitution is applied to the whole thing.
 858         -- This is convenient, but just slightly fragile.  Notably:
 859         --      * There had better be no name clashes in a/b/c
 860         do { let
 861                 -- poly_tyvars = [b] in the example above
 862                 -- spec_tyvars = [a,c]
 863                 -- ty_args     = [t1,b,t3]
 864                 poly_tyvars   = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
 865                 spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
 866                 spec_ty_args  = map snd spec_tv_binds
 867                 ty_args       = mk_ty_args call_ts
 868                 rhs_subst     = CoreSubst.extendTvSubstList subst spec_tv_binds
 869
 870            ; (rhs_subst1, inst_dict_ids) <- cloneDictBndrs rhs_subst rhs_dict_ids
 871                           -- Clone rhs_dicts, including instantiating their types
 872
 873            ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $
 874                                           (my_zipEqual rhs_dict_ids inst_dict_ids call_ds)
 875                  inst_args = ty_args ++ map Var inst_dict_ids
 876
 877            ; if already_covered inst_args then
 878                 return Nothing
 879              else do
 880            {    -- Figure out the type of the specialised function
 881              let body_ty = applyTypeToArgs rhs fn_type inst_args
 882                  (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
 883                    | isUnLiftedType body_ty     -- C.f. WwLib.mkWorkerArgs
 884                    = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [realWorldPrimId])
 885                    | otherwise = (poly_tyvars, poly_tyvars)
 886                  spec_id_ty = mkPiTypes lam_args body_ty
 887
 888            ; spec_f <- newSpecIdSM fn spec_id_ty
 889            ; let spec_f_w_arity = setIdArity spec_f (max 0 (fn_arity - n_dicts))
 890                 -- Adding arity information just propagates it a bit faster
 891                 -- See Note [Arity decrease] in Simplify
 892
 893            ; (spec_rhs, rhs_uds) <- specExpr rhs_subst2 (mkLams lam_args body)
 894            ; let
 895                 -- The rule to put in the function's specialisation is:
 896                 --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
 897                 rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
 898                 spec_env_rule = mkLocalRule
 899                                   rule_name
 900                                   inline_act    -- Note [Auto-specialisation and RULES]
 901                                   (idName fn)
 902                                   (poly_tyvars ++ inst_dict_ids)
 903                                   inst_args
 904                                   (mkVarApps (Var spec_f_w_arity) app_args)
 905
 906                 -- Add the { d1' = dx1; d2' = dx2 } usage stuff
 907                 final_uds = foldr consDictBind rhs_uds dx_binds
 908
 909                 -- See Note [Inline specialisations]
 910                 final_spec_f | Just sat <- fn_has_inline_rule
 911                              = spec_f_w_arity `setInlineActivation` inline_act
 912                                               `setIdUnfolding` mkInlineRule sat spec_rhs spec_arity
 913                                                 -- I'm not sure this should be unconditionally InlSat
 914                              | otherwise
 915                              = spec_f_w_arity
 916            ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } }
 917       where
 918         my_zipEqual xs ys zs
 919          | debugIsOn && not (equalLength xs ys && equalLength ys zs)
 920              = pprPanic "my_zipEqual" (vcat [ ppr xs, ppr ys
 921                                             , ppr fn <+> ppr call_ts
 922                                             , ppr (idType fn), ppr theta
 923                                             , ppr n_dicts, ppr rhs_dict_ids
 924                                             , ppr rhs])
 925          | otherwise = zip3 xs ys zs
 926
 927 bindAuxiliaryDicts
 928         :: Subst
 929         -> [(DictId,DictId,CoreExpr)]   -- (orig_dict, inst_dict, dx)
 930         -> (Subst,                      -- Substitute for all orig_dicts
 931             [CoreBind])                 -- Auxiliary bindings
 932 -- Bind any dictionary arguments to fresh names, to preserve sharing
 933 -- Substitution already substitutes orig_dict -> inst_dict
 934 bindAuxiliaryDicts subst triples = go subst [] triples
 935   where
 936     go subst binds []    = (subst, binds)
 937     go subst binds ((d, dx_id, dx) : pairs)
 938       | exprIsTrivial dx = go (extendIdSubst subst d dx) binds pairs
 939              -- No auxiliary binding necessary
 940       | otherwise        = go subst_w_unf (NonRec dx_id dx : binds) pairs
 941       where
 942         dx_id1 = dx_id `setIdUnfolding` mkUnfolding False False dx
 943         subst_w_unf = extendIdSubst subst d (Var dx_id1)
 944              -- Important!  We're going to substitute dx_id1 for d
 945              -- and we want it to look "interesting", else we won't gather *any*
 946              -- consequential calls. E.g.
 947              --     f d = ...g d....
 948              -- If we specialise f for a call (f (dfun dNumInt)), we'll get
 949              -- a consequent call (g d') with an auxiliary definition
 950              --     d' = df dNumInt
 951              -- We want that consequent call to look interesting
 952 \end{code}
 953
 954 Note [From non-recursive to recursive]
 955 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 956 Even in the non-recursive case, if any dict-binds depend on 'fn' we might
 957 have built a recursive knot
 958
 959       f a d x = <blah>
 960       MkUD { ud_binds = d7 = MkD ..f..
 961            , ud_calls = ...(f T d7)... }
 962
 963 The we generate
 964
 965       Rec { fs x = <blah>[T/a, d7/d]
 966             f a d x = <blah>
 967                RULE f T _ = fs
 968             d7 = ...f... }
 969
 970 Here the recursion is only through the RULE.
 971
 972
 973 Note [Specialisation of dictionary functions]
 974 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 975 Here is a nasty example that bit us badly: see Trac #3591
 976
 977      dfun a d = MkD a d (meth d)
 978      d4 = <blah>
 979      d2 = dfun T d4
 980      d1 = $p1 d2
 981      d3 = dfun T d1
 982
 983 None of these definitions is recursive. What happened was that we
 984 generated a specialisation:
 985
 986      RULE forall d. dfun T d = dT
 987      dT = (MkD a d (meth d)) [T/a, d1/d]
 988         = MkD T d1 (meth d1)
 989
 990 But now we use the RULE on the RHS of d2, to get
 991
 992     d2 = dT = MkD d1 (meth d1)
 993     d1 = $p1 d2
 994
 995 and now d1 is bottom!  The problem is that when specialising 'dfun' we
 996 should first dump "below" the binding all floated dictionary bindings
 997 that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be
 998 placed below 'dfun', and thus unavailable to it when specialising
 999 'dfun'.  That in turn means that the call (dfun T d1) must be
1000 discarded.  On the other hand, the call (dfun T d4) is fine, assuming
1001 d4 doesn't mention dfun.
1002
1003 But look at this:
1004
1005   class C a where { foo,bar :: [a] -> [a] }
1006
1007   instance C Int where
1008      foo x = r_bar x
1009      bar xs = reverse xs
1010
1011   r_bar :: C a => [a] -> [a]
1012   r_bar xs = bar (xs ++ xs)
1013
1014 That translates to:
1015
1016     r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
1017
1018     Rec { $fCInt :: C Int = MkC foo_help reverse
1019           foo_help (xs::[Int]) = r_bar Int $fCInt xs }
1020
1021 The call (r_bar $fCInt) mentions $fCInt,
1022                         which mentions foo_help,
1023                         which mentions r_bar
1024 But we DO want to specialise r_bar at Int:
1025
1026     Rec { $fCInt :: C Int = MkC foo_help reverse
1027           foo_help (xs::[Int]) = r_bar Int $fCInt xs
1028
1029           r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
1030             RULE r_bar Int _ = r_bar_Int
1031
1032           r_bar_Int xs = bar Int $fCInt (xs ++ xs)
1033            }
1034
1035 Note that, because of its RULE, r_bar joins the recursive
1036 group.  (In this case it'll unravel a short moment later.)
1037
1038
1039 Conclusion: we catch the nasty case using filter_dfuns in
1040 callsForMe To be honest I'm not 100% certain that this is 100%
1041 right, but it works.  Sigh.
1042
1043
1044 Note [Specialising a recursive group]
1045 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1046 Consider
1047     let rec { f x = ...g x'...
1048             ; g y = ...f y'.... }
1049     in f 'a'
1050 Here we specialise 'f' at Char; but that is very likely to lead to
1051 a specialisation of 'g' at Char.  We must do the latter, else the
1052 whole point of specialisation is lost.
1053
1054 But we do not want to keep iterating to a fixpoint, because in the
1055 presence of polymorphic recursion we might generate an infinite number
1056 of specialisations.
1057
1058 So we use the following heuristic:
1059   * Arrange the rec block in dependency order, so far as possible
1060     (the occurrence analyser already does this)
1061
1062   * Specialise it much like a sequence of lets
1063
1064   * Then go through the block a second time, feeding call-info from
1065     the RHSs back in the bottom, as it were
1066
1067 In effect, the ordering maxmimises the effectiveness of each sweep,
1068 and we do just two sweeps.   This should catch almost every case of
1069 monomorphic recursion -- the exception could be a very knotted-up
1070 recursion with multiple cycles tied up together.
1071
1072 This plan is implemented in the Rec case of specBindItself.
1073
1074 Note [Specialisations already covered]
1075 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1076 We obviously don't want to generate two specialisations for the same
1077 argument pattern.  There are two wrinkles
1078
1079 1. We do the already-covered test in specDefn, not when we generate
1080 the CallInfo in mkCallUDs.  We used to test in the latter place, but
1081 we now iterate the specialiser somewhat, and the Id at the call site
1082 might therefore not have all the RULES that we can see in specDefn
1083
1084 2. What about two specialisations where the second is an *instance*
1085 of the first?  If the more specific one shows up first, we'll generate
1086 specialisations for both.  If the *less* specific one shows up first,
1087 we *don't* currently generate a specialisation for the more specific
1088 one.  (See the call to lookupRule in already_covered.)  Reasons:
1089   (a) lookupRule doesn't say which matches are exact (bad reason)
1090   (b) if the earlier specialisation is user-provided, it's
1091       far from clear that we should auto-specialise further
1092
1093 Note [Auto-specialisation and RULES]
1094 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1095 Consider:
1096    g :: Num a => a -> a
1097    g = ...
1098
1099    f :: (Int -> Int) -> Int
1100    f w = ...
1101    {-# RULE f g = 0 #-}
1102
1103 Suppose that auto-specialisation makes a specialised version of
1104 g::Int->Int That version won't appear in the LHS of the RULE for f.
1105 So if the specialisation rule fires too early, the rule for f may
1106 never fire.
1107
1108 It might be possible to add new rules, to "complete" the rewrite system.
1109 Thus when adding
1110         RULE forall d. g Int d = g_spec
1111 also add
1112         RULE f g_spec = 0
1113
1114 But that's a bit complicated.  For now we ask the programmer's help,
1115 by *copying the INLINE activation pragma* to the auto-specialised rule.
1116 So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule will also
1117 not be active until phase 2.
1118
1119
1120 Note [Specialisation shape]
1121 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
1122 We only specialise a function if it has visible top-level lambdas
1123 corresponding to its overloading.  E.g. if
1124         f :: forall a. Eq a => ....
1125 then its body must look like
1126         f = /\a. \d. ...
1127
1128 Reason: when specialising the body for a call (f ty dexp), we want to
1129 substitute dexp for d, and pick up specialised calls in the body of f.
1130
1131 This doesn't always work.  One example I came across was this:
1132         newtype Gen a = MkGen{ unGen :: Int -> a }
1133
1134         choose :: Eq a => a -> Gen a
1135         choose n = MkGen (\r -> n)
1136
1137         oneof = choose (1::Int)
1138
1139 It's a silly exapmle, but we get
1140         choose = /\a. g `cast` co
1141 where choose doesn't have any dict arguments.  Thus far I have not
1142 tried to fix this (wait till there's a real example).
1143
1144
1145 Note [Inline specialisations]
1146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1147 We transfer to the specialised function any INLINE stuff from the
1148 original.  This means (a) the Activation in the IdInfo, and (b) any
1149 InlineMe on the RHS.  We do not, however, transfer the RuleMatchInfo
1150 since we do not expect the specialisation to occur in rewrite rules.
1151
1152 This is a change (Jun06).  Previously the idea is that the point of
1153 inlining was precisely to specialise the function at its call site,
1154 and that's not so important for the specialised copies.  But
1155 *pragma-directed* specialisation now takes place in the
1156 typechecker/desugarer, with manually specified INLINEs.  The
1157 specialiation here is automatic.  It'd be very odd if a function
1158 marked INLINE was specialised (because of some local use), and then
1159 forever after (including importing modules) the specialised version
1160 wasn't INLINEd.  After all, the programmer said INLINE!
1161
1162 You might wonder why we don't just not specialise INLINE functions.
1163 It's because even INLINE functions are sometimes not inlined, when
1164 they aren't applied to interesting arguments.  But perhaps the type
1165 arguments alone are enough to specialise (even though the args are too
1166 boring to trigger inlining), and it's certainly better to call the
1167 specialised version.
1168
1169 A case in point is dictionary functions, which are current marked
1170 INLINE, but which are worth specialising.
1171
1172
1173 %************************************************************************
1174 %*                                                                      *
1175 \subsubsection{UsageDetails and suchlike}
1176 %*                                                                      *
1177 %************************************************************************
1178
1179 \begin{code}
1180 data UsageDetails
1181   = MkUD {
1182         ud_binds :: !(Bag DictBind),
1183                         -- Floated dictionary bindings
1184                         -- The order is important;
1185                         -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
1186                         -- (Remember, Bags preserve order in GHC.)
1187
1188         ud_calls :: !CallDetails
1189
1190         -- INVARIANT: suppose bs = bindersOf ud_binds
1191         -- Then 'calls' may *mention* 'bs',
1192         -- but there should be no calls *for* bs
1193     }
1194
1195 instance Outputable UsageDetails where
1196   ppr (MkUD { ud_binds = dbs, ud_calls = calls })
1197         = ptext (sLit "MkUD") <+> braces (sep (punctuate comma
1198                 [ptext (sLit "binds") <+> equals <+> ppr dbs,
1199                  ptext (sLit "calls") <+> equals <+> ppr calls]))
1200
1201 type DictBind = (CoreBind, VarSet)
1202         -- The set is the free vars of the binding
1203         -- both tyvars and dicts
1204
1205 type DictExpr = CoreExpr
1206
1207 emptyUDs :: UsageDetails
1208 emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyVarEnv }
1209
1210 ------------------------------------------------------------
1211 type CallDetails  = IdEnv CallInfoSet
1212 newtype CallKey   = CallKey [Maybe Type]                        -- Nothing => unconstrained type argument
1213
1214 -- CallInfo uses a FiniteMap, thereby ensuring that
1215 -- we record only one call instance for any key
1216 --
1217 -- The list of types and dictionaries is guaranteed to
1218 -- match the type of f
1219 type CallInfoSet = FiniteMap CallKey ([DictExpr], VarSet)
1220                         -- Range is dict args and the vars of the whole
1221                         -- call (including tyvars)
1222                         -- [*not* include the main id itself, of course]
1223
1224 type CallInfo = (CallKey, ([DictExpr], VarSet))
1225
1226 instance Outputable CallKey where
1227   ppr (CallKey ts) = ppr ts
1228
1229 -- Type isn't an instance of Ord, so that we can control which
1230 -- instance we use.  That's tiresome here.  Oh well
1231 instance Eq CallKey where
1232   k1 == k2 = case k1 `compare` k2 of { EQ -> True; _ -> False }
1233
1234 instance Ord CallKey where
1235   compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
1236                 where
1237                   cmp Nothing   Nothing   = EQ
1238                   cmp Nothing   (Just _)  = LT
1239                   cmp (Just _)  Nothing   = GT
1240                   cmp (Just t1) (Just t2) = tcCmpType t1 t2
1241
1242 unionCalls :: CallDetails -> CallDetails -> CallDetails
1243 unionCalls c1 c2 = plusVarEnv_C plusFM c1 c2
1244
1245 -- plusCalls :: UsageDetails -> CallDetails -> UsageDetails
1246 -- plusCalls uds call_ds = uds { ud_calls = ud_calls uds `unionCalls` call_ds }
1247
1248 callDetailsFVs :: CallDetails -> VarSet
1249 callDetailsFVs calls = foldVarEnv (unionVarSet . callInfoFVs) emptyVarSet calls
1250
1251 callInfoFVs :: CallInfoSet -> VarSet
1252 callInfoFVs call_info = foldFM (\_ (_,fv) vs -> unionVarSet fv vs) emptyVarSet call_info
1253
1254 ------------------------------------------------------------
1255 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
1256 singleCall id tys dicts
1257   = MkUD {ud_binds = emptyBag,
1258           ud_calls = unitVarEnv id (unitFM (CallKey tys) (dicts, call_fvs)) }
1259   where
1260     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
1261     tys_fvs  = tyVarsOfTypes (catMaybes tys)
1262         -- The type args (tys) are guaranteed to be part of the dictionary
1263         -- types, because they are just the constrained types,
1264         -- and the dictionary is therefore sure to be bound
1265         -- inside the binding for any type variables free in the type;
1266         -- hence it's safe to neglect tyvars free in tys when making
1267         -- the free-var set for this call
1268         -- BUT I don't trust this reasoning; play safe and include tys_fvs
1269         --
1270         -- We don't include the 'id' itself.
1271
1272 mkCallUDs :: Id -> [CoreExpr] -> UsageDetails
1273 mkCallUDs f args
1274   | not (isLocalId f)   -- Imported from elsewhere
1275   || null theta         -- Not overloaded
1276   || not (all isClassPred theta)
1277         -- Only specialise if all overloading is on class params.
1278         -- In ptic, with implicit params, the type args
1279         --  *don't* say what the value of the implicit param is!
1280   || not (spec_tys `lengthIs` n_tyvars)
1281   || not ( dicts   `lengthIs` n_dicts)
1282   || not (any interestingDict dicts)    -- Note [Interesting dictionary arguments]
1283   -- See also Note [Specialisations already covered]
1284   = -- pprTrace "mkCallUDs: discarding" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
1285     emptyUDs    -- Not overloaded, or no specialisation wanted
1286
1287   | otherwise
1288   = -- pprTrace "mkCallUDs: keeping" (vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts, ppr (map interestingDict dicts)])
1289     singleCall f spec_tys dicts
1290   where
1291     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
1292     constrained_tyvars = tyVarsOfTheta theta
1293     n_tyvars           = length tyvars
1294     n_dicts            = length theta
1295
1296     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
1297     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
1298
1299     mk_spec_ty tyvar ty
1300         | tyvar `elemVarSet` constrained_tyvars = Just ty
1301         | otherwise                             = Nothing
1302 \end{code}
1303
1304 Note [Interesting dictionary arguments]
1305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1306 Consider this
1307          \a.\d:Eq a.  let f = ... in ...(f d)...
1308 There really is not much point in specialising f wrt the dictionary d,
1309 because the code for the specialised f is not improved at all, because
1310 d is lambda-bound.  We simply get junk specialisations.
1311
1312 What is "interesting"?  Just that it has *some* structure.
1313
1314 \begin{code}
1315 interestingDict :: CoreExpr -> Bool
1316 -- A dictionary argument is interesting if it has *some* structure
1317 interestingDict (Var v) =  hasSomeUnfolding (idUnfolding v)
1318                         || isDataConWorkId v
1319 interestingDict (Type _)          = False
1320 interestingDict (App fn (Type _)) = interestingDict fn
1321 interestingDict (Note _ a)        = interestingDict a
1322 interestingDict (Cast e _)        = interestingDict e
1323 interestingDict _                 = True
1324 \end{code}
1325
1326 \begin{code}
1327 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
1328 plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
1329         (MkUD {ud_binds = db2, ud_calls = calls2})
1330   = MkUD { ud_binds = db1    `unionBags`   db2
1331          , ud_calls = calls1 `unionCalls`  calls2 }
1332
1333 plusUDList :: [UsageDetails] -> UsageDetails
1334 plusUDList = foldr plusUDs emptyUDs
1335
1336 -----------------------------
1337 _dictBindBndrs :: Bag DictBind -> [Id]
1338 _dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
1339
1340 mkDB :: CoreBind -> DictBind
1341 mkDB bind = (bind, bind_fvs bind)
1342
1343 bind_fvs :: CoreBind -> VarSet
1344 bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
1345 bind_fvs (Rec prs)         = foldl delVarSet rhs_fvs bndrs
1346                            where
1347                              bndrs = map fst prs
1348                              rhs_fvs = unionVarSets (map pair_fvs prs)
1349
1350 pair_fvs :: (Id, CoreExpr) -> VarSet
1351 pair_fvs (bndr, rhs) = exprFreeVars rhs `unionVarSet` idFreeVars bndr
1352         -- Don't forget variables mentioned in the
1353         -- rules of the bndr.  C.f. OccAnal.addRuleUsage
1354         -- Also tyvars mentioned in its type; they may not appear in the RHS
1355         --      type T a = Int
1356         --      x :: T a = 3
1357
1358 flattenDictBinds :: Bag DictBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
1359 flattenDictBinds dbs pairs
1360   = foldrBag add pairs dbs
1361   where
1362     add (NonRec b r,_) pairs = (b,r) : pairs
1363     add (Rec prs1, _)  pairs = prs1 ++ pairs
1364
1365 snocDictBinds :: UsageDetails -> [CoreBind] -> UsageDetails
1366 -- Add ud_binds to the tail end of the bindings in uds
1367 snocDictBinds uds dbs
1368   = uds { ud_binds = ud_binds uds `unionBags`
1369                      foldr (consBag . mkDB) emptyBag dbs }
1370
1371 consDictBind :: CoreBind -> UsageDetails -> UsageDetails
1372 consDictBind bind uds = uds { ud_binds = mkDB bind `consBag` ud_binds uds }
1373
1374 snocDictBind :: UsageDetails -> CoreBind -> UsageDetails
1375 snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` mkDB bind }
1376
1377 wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
1378 wrapDictBinds dbs binds
1379   = foldrBag add binds dbs
1380   where
1381     add (bind,_) binds = bind : binds
1382
1383 wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
1384 wrapDictBindsE dbs expr
1385   = foldrBag add expr dbs
1386   where
1387     add (bind,_) expr = Let bind expr
1388
1389 ----------------------
1390 dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
1391 -- Used at a lambda or case binder; just dump anything mentioning the binder
1392 dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1393   | null bndrs = (uds, emptyBag)  -- Common in case alternatives
1394   | otherwise  = (free_uds, dump_dbs)
1395   where
1396     free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
1397     bndr_set = mkVarSet bndrs
1398     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
1399     free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor
1400                  deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be
1401                                                     -- no calls for any of the dicts in dump_dbs
1402
1403 dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
1404 -- Used at a lambda or case binder; just dump anything mentioning the binder
1405 dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1406   = (free_uds, dump_dbs, float_all)
1407   where
1408     free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
1409     bndr_set = mkVarSet bndrs
1410     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
1411     free_calls = deleteCallsFor bndrs orig_calls
1412     float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
1413
1414 callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
1415 callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
1416   = -- pprTrace ("callsForMe")
1417     --         (vcat [ppr fn,
1418     --                text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),
1419     --                text "Orig calls ="   <+> ppr orig_calls,
1420     --                text "Dep set ="      <+> ppr dep_set,
1421     --                text "Calls for me =" <+> ppr calls_for_me]) $
1422     (uds_without_me, calls_for_me)
1423   where
1424     uds_without_me = MkUD { ud_binds = orig_dbs, ud_calls = delVarEnv orig_calls fn }
1425     calls_for_me = case lookupVarEnv orig_calls fn of
1426                         Nothing -> []
1427                         Just cs -> filter_dfuns (fmToList cs)
1428
1429     dep_set = foldlBag go (unitVarSet fn) orig_dbs
1430     go dep_set (db,fvs) | fvs `intersectsVarSet` dep_set
1431                         = extendVarSetList dep_set (bindersOf db)
1432                         | otherwise = fvs
1433
1434         -- Note [Specialisation of dictionary functions]
1435     filter_dfuns | isDFunId fn = filter ok_call
1436                  | otherwise   = \cs -> cs
1437
1438     ok_call (_, (_,fvs)) = not (fvs `intersectsVarSet` dep_set)
1439
1440 ----------------------
1441 splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
1442 -- Returns (free_dbs, dump_dbs, dump_set)
1443 splitDictBinds dbs bndr_set
1444    = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs
1445                 -- Important that it's foldl not foldr;
1446                 -- we're accumulating the set of dumped ids in dump_set
1447    where
1448     split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
1449         | dump_idset `intersectsVarSet` fvs     -- Dump it
1450         = (free_dbs, dump_dbs `snocBag` db,
1451            extendVarSetList dump_idset (bindersOf bind))
1452
1453         | otherwise     -- Don't dump it
1454         = (free_dbs `snocBag` db, dump_dbs, dump_idset)
1455
1456
1457 ----------------------
1458 deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
1459 -- Remove calls *mentioning* bs
1460 deleteCallsMentioning bs calls
1461   = mapVarEnv filter_calls calls
1462   where
1463     filter_calls :: CallInfoSet -> CallInfoSet
1464     filter_calls = filterFM (\_ (_, fvs) -> not (fvs `intersectsVarSet` bs))
1465
1466 deleteCallsFor :: [Id] -> CallDetails -> CallDetails
1467 -- Remove calls *for* bs
1468 deleteCallsFor bs calls = delVarEnvList calls bs
1469 \end{code}
1470
1471
1472 %************************************************************************
1473 %*                                                                      *
1474 \subsubsection{Boring helper functions}
1475 %*                                                                      *
1476 %************************************************************************
1477
1478 \begin{code}
1479 type SpecM a = UniqSM a
1480
1481 initSM :: UniqSupply -> SpecM a -> a
1482 initSM    = initUs_
1483
1484 mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
1485 mapAndCombineSM _ []     = return ([], emptyUDs)
1486 mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
1487                               (ys, uds2) <- mapAndCombineSM f xs
1488                               return (y:ys, uds1 `plusUDs` uds2)
1489
1490 cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
1491 -- Clone the binders of the bind; return new bind with the cloned binders
1492 -- Return the substitution to use for RHSs, and the one to use for the body
1493 cloneBindSM subst (NonRec bndr rhs) = do
1494     us <- getUniqueSupplyM
1495     let (subst', bndr') = cloneIdBndr subst us bndr
1496     return (subst, subst', NonRec bndr' rhs)
1497
1498 cloneBindSM subst (Rec pairs) = do
1499     us <- getUniqueSupplyM
1500     let (subst', bndrs') = cloneRecIdBndrs subst us (map fst pairs)
1501     return (subst', subst', Rec (bndrs' `zip` map snd pairs))
1502
1503 cloneDictBndrs :: Subst -> [CoreBndr] -> SpecM (Subst, [CoreBndr])
1504 cloneDictBndrs subst bndrs
1505   = do { us <- getUniqueSupplyM
1506        ; return (cloneIdBndrs subst us bndrs) }
1507
1508 newSpecIdSM :: Id -> Type -> SpecM Id
1509     -- Give the new Id a similar occurrence name to the old one
1510 newSpecIdSM old_id new_ty
1511   = do  { uniq <- getUniqueM
1512         ; let
1513             name    = idName old_id
1514             new_occ = mkSpecOcc (nameOccName name)
1515             new_id  = mkUserLocal new_occ uniq new_ty (getSrcSpan name)
1516         ; return new_id }
1517 \end{code}
1518
1519
1520                 Old (but interesting) stuff about unboxed bindings
1521                 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1522
1523 What should we do when a value is specialised to a *strict* unboxed value?
1524
1525         map_*_* f (x:xs) = let h = f x
1526                                t = map f xs
1527                            in h:t
1528
1529 Could convert let to case:
1530
1531         map_*_Int# f (x:xs) = case f x of h# ->
1532                               let t = map f xs
1533                               in h#:t
1534
1535 This may be undesirable since it forces evaluation here, but the value
1536 may not be used in all branches of the body. In the general case this
1537 transformation is impossible since the mutual recursion in a letrec
1538 cannot be expressed as a case.
1539
1540 There is also a problem with top-level unboxed values, since our
1541 implementation cannot handle unboxed values at the top level.
1542
1543 Solution: Lift the binding of the unboxed value and extract it when it
1544 is used:
1545
1546         map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
1547                                   t = map f xs
1548                               in case h of
1549                                  _Lift h# -> h#:t
1550
1551 Now give it to the simplifier and the _Lifting will be optimised away.
1552
1553 The benfit is that we have given the specialised "unboxed" values a
1554 very simplep lifted semantics and then leave it up to the simplifier to
1555 optimise it --- knowing that the overheads will be removed in nearly
1556 all cases.
1557
1558 In particular, the value will only be evaluted in the branches of the
1559 program which use it, rather than being forced at the point where the
1560 value is bound. For example:
1561
1562         filtermap_*_* p f (x:xs)
1563           = let h = f x
1564                 t = ...
1565             in case p x of
1566                 True  -> h:t
1567                 False -> t
1568    ==>
1569         filtermap_*_Int# p f (x:xs)
1570           = let h = case (f x) of h# -> _Lift h#
1571                 t = ...
1572             in case p x of
1573                 True  -> case h of _Lift h#
1574                            -> h#:t
1575                 False -> t
1576
1577 The binding for h can still be inlined in the one branch and the
1578 _Lifting eliminated.
1579
1580
1581 Question: When won't the _Lifting be eliminated?
1582
1583 Answer: When they at the top-level (where it is necessary) or when
1584 inlining would duplicate work (or possibly code depending on
1585 options). However, the _Lifting will still be eliminated if the
1586 strictness analyser deems the lifted binding strict.
1587