ghc/compiler/specialise/Specialise.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Specialise (
  10         specProgram,
  11         initSpecData,
  12
  13         SpecialiseData(..)
  14     ) where
  15
  16 IMP_Ubiq(){-uitous-}
  17 IMPORT_1_3(List(partition))
  18
  19 import Bag              ( emptyBag, unitBag, isEmptyBag, unionBags,
  20                           partitionBag, listToBag, bagToList, Bag
  21                         )
  22 import Class            ( GenClass{-instance Eq-}, SYN_IE(Class) )
  23 import CmdLineOpts      ( opt_SpecialiseImports, opt_D_simplifier_stats,
  24                           opt_SpecialiseTrace
  25                         )
  26 import CoreLift         ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
  27 import CoreSyn
  28 import CoreUtils        ( coreExprType, squashableDictishCcExpr )
  29 import FiniteMap        ( addListToFM_C, FiniteMap )
  30 import Kind             ( mkBoxedTypeKind, isBoxedTypeKind )
  31 import Id               ( idType, isDefaultMethodId_maybe, toplevelishId,
  32                           isSuperDictSelId_maybe, isBottomingId,
  33                            isDataCon,
  34                           isImportedId, mkIdWithNewUniq,
  35                           dataConTyCon, applyTypeEnvToId,
  36                           nullIdEnv, addOneToIdEnv, growIdEnvList,
  37                           lookupIdEnv, SYN_IE(IdEnv),
  38                           emptyIdSet, mkIdSet, unitIdSet,
  39                           elementOfIdSet, minusIdSet,
  40                           unionIdSets, unionManyIdSets, SYN_IE(IdSet),
  41                           GenId{-instance Eq-}, SYN_IE(Id)
  42                         )
  43 import Literal          ( Literal{-instance Outputable-} )
  44 import Maybes           ( catMaybes, firstJust, maybeToBool )
  45 import Name             ( isLocallyDefined )
  46 import Outputable       ( PprStyle(..), interppSP, Outputable(..){-instance * []-} )
  47 import PprType          ( pprGenType, pprParendGenType, pprMaybeTy,
  48                           GenType{-instance Outputable-}, GenTyVar{-ditto-},
  49                           TyCon{-ditto-}
  50                         )
  51 import Pretty           ( hang, hsep, text, vcat, hcat, ptext, char,
  52                           int, space, empty, Doc
  53                         )
  54 import PrimOp           ( PrimOp(..) )
  55 import SpecUtils
  56 import Type             ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
  57                           tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType, isDictTy,
  58                           SYN_IE(Type)
  59                         )
  60 import TyCon            ( TyCon{-instance Eq-} )
  61 import TyVar            ( cloneTyVar, mkSysTyVar,
  62                           elementOfTyVarSet, SYN_IE(TyVarSet),
  63                           nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv),
  64                           GenTyVar{-instance Eq-}
  65                         )
  66 import TysWiredIn       ( liftDataCon )
  67 import Unique           ( Unique{-instance Eq-} )
  68 import UniqSet          ( mkUniqSet, unionUniqSets, uniqSetToList )
  69 import UniqSupply       ( splitUniqSupply, getUniques, getUnique )
  70 import Util             ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
  71                           thenCmp, panic, pprTrace, pprPanic, assertPanic
  72                         )
  73
  74 infixr 9 `thenSM`
  75
  76 specProgram = panic "SpecProgram"
  77
  78 --ToDo:kill
  79 data SpecInfo = SpecInfo [Maybe Type] Int Id
  80
  81
  82 {-
  83 lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
  84 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
  85 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
  86 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
  87 isClassOpId = panic "Specialise.isClassOpId (ToDo)"
  88 isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
  89 isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
  90 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
  91 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
  92 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
  93 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
  94 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
  95 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
  96 specialiseTy = panic "Specialise.specialiseTy (ToDo)"
  97 \end{code}
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 These notes describe how we implement specialisation to eliminate
 106 overloading, and optionally to eliminate unboxed polymorphism, and
 107 full polymorphism.
 108
 109 The specialisation pass is a partial evaluator which works on Core
 110 syntax, complete with all the explicit dictionary application,
 111 abstraction and construction as added by the type checker.  The
 112 existing type checker remains largely as it is.
 113
 114 One important thought: the {\em types} passed to an overloaded
 115 function, and the {\em dictionaries} passed are mutually redundant.
 116 If the same function is applied to the same type(s) then it is sure to
 117 be applied to the same dictionary(s)---or rather to the same {\em
 118 values}.  (The arguments might look different but they will evaluate
 119 to the same value.)
 120
 121 Second important thought: we know that we can make progress by
 122 treating dictionary arguments as static and worth specialising on.  So
 123 we can do without binding-time analysis, and instead specialise on
 124 dictionary arguments and no others.
 125
 126 The basic idea
 127 ~~~~~~~~~~~~~~
 128 Suppose we have
 129
 130         let f = <f_rhs>
 131         in <body>
 132
 133 and suppose f is overloaded.
 134
 135 STEP 1: CALL-INSTANCE COLLECTION
 136
 137 We traverse <body>, accumulating all applications of f to types and
 138 dictionaries.
 139
 140 (Might there be partial applications, to just some of its types and
 141 dictionaries?  In principle yes, but in practice the type checker only
 142 builds applications of f to all its types and dictionaries, so partial
 143 applications could only arise as a result of transformation, and even
 144 then I think it's unlikely.  In any case, we simply don't accumulate such
 145 partial applications.)
 146
 147 There's a choice of whether to collect details of all *polymorphic* functions
 148 or simply all *overloaded* ones.  How to sort this out?
 149   Pass in a predicate on the function to say if it is "interesting"?
 150   This is dependent on the user flags: SpecialiseOverloaded
 151                                        SpecialiseUnboxed
 152                                        SpecialiseAll
 153
 154 STEP 2: EQUIVALENCES
 155
 156 So now we have a collection of calls to f:
 157         f t1 t2 d1 d2
 158         f t3 t4 d3 d4
 159         ...
 160 Notice that f may take several type arguments.  To avoid ambiguity, we
 161 say that f is called at type t1/t2 and t3/t4.
 162
 163 We take equivalence classes using equality of the *types* (ignoring
 164 the dictionary args, which as mentioned previously are redundant).
 165
 166 STEP 3: SPECIALISATION
 167
 168 For each equivalence class, choose a representative (f t1 t2 d1 d2),
 169 and create a local instance of f, defined thus:
 170
 171         f@t1/t2 = <f_rhs> t1 t2 d1 d2
 172
 173 (f_rhs presumably has some big lambdas and dictionary lambdas, so lots
 174 of simplification will now result.)  Then we should recursively do
 175 everything again.
 176
 177 The new id has its own unique, but its print-name (if exported) has
 178 an explicit representation of the instance types t1/t2.
 179
 180 Add this new id to f's IdInfo, to record that f has a specialised version.
 181
 182 Before doing any of this, check that f's IdInfo doesn't already
 183 tell us about an existing instance of f at the required type/s.
 184 (This might happen if specialisation was applied more than once, or
 185 it might arise from user SPECIALIZE pragmas.)
 186
 187 Recursion
 188 ~~~~~~~~~
 189 Wait a minute!  What if f is recursive?  Then we can't just plug in
 190 its right-hand side, can we?
 191
 192 But it's ok.  The type checker *always* creates non-recursive definitions
 193 for overloaded recursive functions.  For example:
 194
 195         f x = f (x+x)           -- Yes I know its silly
 196
 197 becomes
 198
 199         f a (d::Num a) = let p = +.sel a d
 200                          in
 201                          letrec fl (y::a) = fl (p y y)
 202                          in
 203                          fl
 204
 205 We still have recusion for non-overloadd functions which we
 206 speciailise, but the recursive call should get speciailised to the
 207 same recursive version.
 208
 209
 210 Polymorphism 1
 211 ~~~~~~~~~~~~~~
 212
 213 All this is crystal clear when the function is applied to *constant
 214 types*; that is, types which have no type variables inside.  But what if
 215 it is applied to non-constant types?  Suppose we find a call of f at type
 216 t1/t2.  There are two possibilities:
 217
 218 (a) The free type variables of t1, t2 are in scope at the definition point
 219 of f.  In this case there's no problem, we proceed just as before.  A common
 220 example is as follows.  Here's the Haskell:
 221
 222         g y = let f x = x+x
 223               in f y + f y
 224
 225 After typechecking we have
 226
 227         g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
 228                                 in +.sel a d (f a d y) (f a d y)
 229
 230 Notice that the call to f is at type type "a"; a non-constant type.
 231 Both calls to f are at the same type, so we can specialise to give:
 232
 233         g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
 234                                 in +.sel a d (f@a y) (f@a y)
 235
 236
 237 (b) The other case is when the type variables in the instance types
 238 are *not* in scope at the definition point of f.  The example we are
 239 working with above is a good case.  There are two instances of (+.sel a d),
 240 but "a" is not in scope at the definition of +.sel.  Can we do anything?
 241 Yes, we can "common them up", a sort of limited common sub-expression deal.
 242 This would give:
 243
 244         g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
 245                                     f@a (x::a) = +.sel@a x x
 246                                 in +.sel@a (f@a y) (f@a y)
 247
 248 This can save work, and can't be spotted by the type checker, because
 249 the two instances of +.sel weren't originally at the same type.
 250
 251 Further notes on (b)
 252
 253 * There are quite a few variations here.  For example, the defn of
 254   +.sel could be floated ouside the \y, to attempt to gain laziness.
 255   It certainly mustn't be floated outside the \d because the d has to
 256   be in scope too.
 257
 258 * We don't want to inline f_rhs in this case, because
 259 that will duplicate code.  Just commoning up the call is the point.
 260
 261 * Nothing gets added to +.sel's IdInfo.
 262
 263 * Don't bother unless the equivalence class has more than one item!
 264
 265 Not clear whether this is all worth it.  It is of course OK to
 266 simply discard call-instances when passing a big lambda.
 267
 268 Polymorphism 2 -- Overloading
 269 ~~~~~~~~~~~~~~
 270 Consider a function whose most general type is
 271
 272         f :: forall a b. Ord a => [a] -> b -> b
 273
 274 There is really no point in making a version of g at Int/Int and another
 275 at Int/Bool, because it's only instancing the type variable "a" which
 276 buys us any efficiency. Since g is completely polymorphic in b there
 277 ain't much point in making separate versions of g for the different
 278 b types.
 279
 280 That suggests that we should identify which of g's type variables
 281 are constrained (like "a") and which are unconstrained (like "b").
 282 Then when taking equivalence classes in STEP 2, we ignore the type args
 283 corresponding to unconstrained type variable.  In STEP 3 we make
 284 polymorphic versions.  Thus:
 285
 286         f@t1/ = /\b -> <f_rhs> t1 b d1 d2
 287
 288 This seems pretty simple, and a Good Thing.
 289
 290 Polymorphism 3 -- Unboxed
 291 ~~~~~~~~~~~~~~
 292
 293 If we are speciailising at unboxed types we must speciailise
 294 regardless of the overloading constraint.  In the exaple above it is
 295 worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
 296 etc.
 297
 298 Note that specialising an overloaded type at an uboxed type requires
 299 an unboxed instance -- we cannot default to an unspecialised version!
 300
 301
 302 Dictionary floating
 303 ~~~~~~~~~~~~~~~~~~~
 304 Consider
 305
 306         f x = let g p q = p==q
 307                   h r s = (r+s, g r s)
 308               in
 309               h x x
 310
 311
 312 Before specialisation, leaving out type abstractions we have
 313
 314         f df x = let g :: Eq a => a -> a -> Bool
 315                      g dg p q = == dg p q
 316                      h :: Num a => a -> a -> (a, Bool)
 317                      h dh r s = let deq = eqFromNum dh
 318                                 in (+ dh r s, g deq r s)
 319               in
 320               h df x x
 321
 322 After specialising h we get a specialised version of h, like this:
 323
 324                     h' r s = let deq = eqFromNum df
 325                              in (+ df r s, g deq r s)
 326
 327 But we can't naively make an instance for g from this, because deq is not in scope
 328 at the defn of g.  Instead, we have to float out the (new) defn of deq
 329 to widen its scope.  Notice that this floating can't be done in advance -- it only
 330 shows up when specialisation is done.
 331
 332 DELICATE MATTER: the way we tell a dictionary binding is by looking to
 333 see if it has a Dict type.  If the type has been "undictify'd", so that
 334 it looks like a tuple, then the dictionary binding won't be floated, and
 335 an opportunity to specialise might be lost.
 336
 337 User SPECIALIZE pragmas
 338 ~~~~~~~~~~~~~~~~~~~~~~~
 339 Specialisation pragmas can be digested by the type checker, and implemented
 340 by adding extra definitions along with that of f, in the same way as before
 341
 342         f@t1/t2 = <f_rhs> t1 t2 d1 d2
 343
 344 Indeed the pragmas *have* to be dealt with by the type checker, because
 345 only it knows how to build the dictionaries d1 and d2!  For example
 346
 347         g :: Ord a => [a] -> [a]
 348         {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
 349
 350 Here, the specialised version of g is an application of g's rhs to the
 351 Ord dictionary for (Tree Int), which only the type checker can conjure
 352 up.  There might not even *be* one, if (Tree Int) is not an instance of
 353 Ord!  (All the other specialision has suitable dictionaries to hand
 354 from actual calls.)
 355
 356 Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
 357 it is buried in a complex (as-yet-un-desugared) binding group.
 358 Maybe we should say
 359
 360         f@t1/t2 = f* t1 t2 d1 d2
 361
 362 where f* is the Id f with an IdInfo which says "inline me regardless!".
 363 Indeed all the specialisation could be done in this way.
 364 That in turn means that the simplifier has to be prepared to inline absolutely
 365 any in-scope let-bound thing.
 366
 367
 368 Again, the pragma should permit polymorphism in unconstrained variables:
 369
 370         h :: Ord a => [a] -> b -> b
 371         {-# SPECIALIZE h :: [Int] -> b -> b #-}
 372
 373 We *insist* that all overloaded type variables are specialised to ground types,
 374 (and hence there can be no context inside a SPECIALIZE pragma).
 375 We *permit* unconstrained type variables to be specialised to
 376         - a ground type
 377         - or left as a polymorphic type variable
 378 but nothing in between.  So
 379
 380         {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
 381
 382 is *illegal*.  (It can be handled, but it adds complication, and gains the
 383 programmer nothing.)
 384
 385
 386 SPECIALISING INSTANCE DECLARATIONS
 387 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 388 Consider
 389
 390         instance Foo a => Foo [a] where
 391                 ...
 392         {-# SPECIALIZE instance Foo [Int] #-}
 393
 394 The original instance decl creates a dictionary-function
 395 definition:
 396
 397         dfun.Foo.List :: forall a. Foo a -> Foo [a]
 398
 399 The SPECIALIZE pragma just makes a specialised copy, just as for
 400 ordinary function definitions:
 401
 402         dfun.Foo.List@Int :: Foo [Int]
 403         dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
 404
 405 The information about what instance of the dfun exist gets added to
 406 the dfun's IdInfo in the same way as a user-defined function too.
 407
 408 In fact, matters are a little bit more complicated than this.
 409 When we make one of these specialised instances, we are defining
 410 a constant dictionary, and so we want immediate access to its constant
 411 methods and superclasses.  Indeed, these constant methods and superclasses
 412 must be in the IdInfo for the class selectors!  We need help from the
 413 typechecker to sort this out, perhaps by generating a separate IdInfo
 414 for each.
 415
 416 Automatic instance decl specialisation?
 417 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 418 Can instance decls be specialised automatically?  It's tricky.
 419 We could collect call-instance information for each dfun, but
 420 then when we specialised their bodies we'd get new call-instances
 421 for ordinary functions; and when we specialised their bodies, we might get
 422 new call-instances of the dfuns, and so on.  This all arises because of
 423 the unrestricted mutual recursion between instance decls and value decls.
 424
 425 Furthermore, instance decls are usually exported and used non-locally,
 426 so we'll want to compile enough to get those specialisations done.
 427
 428 Lastly, there's no such thing as a local instance decl, so we can
 429 survive solely by spitting out *usage* information, and then reading that
 430 back in as a pragma when next compiling the file.  So for now,
 431 we only specialise instance decls in response to pragmas.
 432
 433 That means that even if an instance decl ain't otherwise exported it
 434 needs to be spat out as with a SPECIALIZE pragma.  Furthermore, it needs
 435 something to say which module defined the instance, so the usage info
 436 can be fed into the right reqts info file.  Blegh.
 437
 438
 439 SPECIAILISING DATA DECLARATIONS
 440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 441
 442 With unboxed specialisation (or full specialisation) we also require
 443 data types (and their constructors) to be speciailised on unboxed
 444 type arguments.
 445
 446 In addition to normal call instances we gather TyCon call instances at
 447 unboxed types, determine equivalence classes for the locally defined
 448 TyCons and build speciailised data constructor Ids for each TyCon and
 449 substitute these in the Con calls.
 450
 451 We need the list of local TyCons to partition the TyCon instance info.
 452 We pass out a FiniteMap from local TyCons to Specialised Instances to
 453 give to the interface and code genertors.
 454
 455 N.B. The specialised data constructors reference the original data
 456 constructor and type constructor which do not have the updated
 457 specialisation info attached.  Any specialisation info must be
 458 extracted from the TyCon map returned.
 459
 460
 461 SPITTING OUT USAGE INFORMATION
 462 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 463
 464 To spit out usage information we need to traverse the code collecting
 465 call-instance information for all imported (non-prelude?) functions
 466 and data types. Then we equivalence-class it and spit it out.
 467
 468 This is done at the top-level when all the call instances which escape
 469 must be for imported functions and data types.
 470
 471
 472 Partial specialisation by pragmas
 473 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 474 What about partial specialisation:
 475
 476         k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
 477         {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
 478
 479 or even
 480
 481         {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
 482
 483 Seems quite reasonable.  Similar things could be done with instance decls:
 484
 485         instance (Foo a, Foo b) => Foo (a,b) where
 486                 ...
 487         {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
 488         {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
 489
 490 Ho hum.  Things are complex enough without this.  I pass.
 491
 492
 493 Requirements for the simplifer
 494 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 495 The simplifier has to be able to take advantage of the specialisation.
 496
 497 * When the simplifier finds an application of a polymorphic f, it looks in
 498 f's IdInfo in case there is a suitable instance to call instead.  This converts
 499
 500         f t1 t2 d1 d2   ===>   f_t1_t2
 501
 502 Note that the dictionaries get eaten up too!
 503
 504 * Dictionary selection operations on constant dictionaries must be
 505   short-circuited:
 506
 507         +.sel Int d     ===>  +Int
 508
 509 The obvious way to do this is in the same way as other specialised
 510 calls: +.sel has inside it some IdInfo which tells that if it's applied
 511 to the type Int then it should eat a dictionary and transform to +Int.
 512
 513 In short, dictionary selectors need IdInfo inside them for constant
 514 methods.
 515
 516 * Exactly the same applies if a superclass dictionary is being
 517   extracted:
 518
 519         Eq.sel Int d   ===>   dEqInt
 520
 521 * Something similar applies to dictionary construction too.  Suppose
 522 dfun.Eq.List is the function taking a dictionary for (Eq a) to
 523 one for (Eq [a]).  Then we want
 524
 525         dfun.Eq.List Int d      ===> dEq.List_Int
 526
 527 Where does the Eq [Int] dictionary come from?  It is built in
 528 response to a SPECIALIZE pragma on the Eq [a] instance decl.
 529
 530 In short, dfun Ids need IdInfo with a specialisation for each
 531 constant instance of their instance declaration.
 532
 533
 534 What does the specialisation IdInfo look like?
 535 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 536
 537         SpecInfo
 538                 [Maybe Type] -- Instance types
 539                 Int             -- No of dicts to eat
 540                 Id              -- Specialised version
 541
 542 For example, if f has this SpecInfo:
 543
 544         SpecInfo [Just t1, Nothing, Just t3] 2 f'
 545
 546 then
 547
 548         f t1 t2 t3 d1 d2  ===>  f t2
 549
 550 The "Nothings" identify type arguments in which the specialised
 551 version is polymorphic.
 552
 553 What can't be done this way?
 554 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 555 There is no way, post-typechecker, to get a dictionary for (say)
 556 Eq a from a dictionary for Eq [a].  So if we find
 557
 558         ==.sel [t] d
 559
 560 we can't transform to
 561
 562         eqList (==.sel t d')
 563
 564 where
 565         eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
 566
 567 Of course, we currently have no way to automatically derive
 568 eqList, nor to connect it to the Eq [a] instance decl, but you
 569 can imagine that it might somehow be possible.  Taking advantage
 570 of this is permanently ruled out.
 571
 572 Still, this is no great hardship, because we intend to eliminate
 573 overloading altogether anyway!
 574
 575
 576 Mutter mutter
 577 ~~~~~~~~~~~~~
 578 What about types/classes mentioned in SPECIALIZE pragmas spat out,
 579 but not otherwise exported.  Even if they are exported, what about
 580 their original names.
 581
 582 Suggestion: use qualified names in pragmas, omitting module for
 583 prelude and "this module".
 584
 585
 586 Mutter mutter 2
 587 ~~~~~~~~~~~~~~~
 588 Consider this
 589
 590         f a (d::Num a) = let g = ...
 591                          in
 592                          ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
 593
 594 Here, g is only called at one type, but the dictionary isn't in scope at the
 595 definition point for g.  Usually the type checker would build a
 596 definition for d1 which enclosed g, but the transformation system
 597 might have moved d1's defn inward.
 598
 599
 600 Unboxed bindings
 601 ~~~~~~~~~~~~~~~~
 602
 603 What should we do when a value is specialised to a *strict* unboxed value?
 604
 605         map_*_* f (x:xs) = let h = f x
 606                                t = map f xs
 607                            in h:t
 608
 609 Could convert let to case:
 610
 611         map_*_Int# f (x:xs) = case f x of h# ->
 612                               let t = map f xs
 613                               in h#:t
 614
 615 This may be undesirable since it forces evaluation here, but the value
 616 may not be used in all branches of the body. In the general case this
 617 transformation is impossible since the mutual recursion in a letrec
 618 cannot be expressed as a case.
 619
 620 There is also a problem with top-level unboxed values, since our
 621 implementation cannot handle unboxed values at the top level.
 622
 623 Solution: Lift the binding of the unboxed value and extract it when it
 624 is used:
 625
 626         map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
 627                                   t = map f xs
 628                               in case h of
 629                                  _Lift h# -> h#:t
 630
 631 Now give it to the simplifier and the _Lifting will be optimised away.
 632
 633 The benfit is that we have given the specialised "unboxed" values a
 634 very simple lifted semantics and then leave it up to the simplifier to
 635 optimise it --- knowing that the overheads will be removed in nearly
 636 all cases.
 637
 638 In particular, the value will only be evaluted in the branches of the
 639 program which use it, rather than being forced at the point where the
 640 value is bound. For example:
 641
 642         filtermap_*_* p f (x:xs)
 643           = let h = f x
 644                 t = ...
 645             in case p x of
 646                 True  -> h:t
 647                 False -> t
 648    ==>
 649         filtermap_*_Int# p f (x:xs)
 650           = let h = case (f x) of h# -> _Lift h#
 651                 t = ...
 652             in case p x of
 653                 True  -> case h of _Lift h#
 654                            -> h#:t
 655                 False -> t
 656
 657 The binding for h can still be inlined in the one branch and the
 658 _Lifting eliminated.
 659
 660
 661 Question: When won't the _Lifting be eliminated?
 662
 663 Answer: When they at the top-level (where it is necessary) or when
 664 inlining would duplicate work (or possibly code depending on
 665 options). However, the _Lifting will still be eliminated if the
 666 strictness analyser deems the lifted binding strict.
 667
 668
 669 A note about non-tyvar dictionaries
 670 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 671 Some Ids have types like
 672
 673         forall a,b,c. Eq a -> Ord [a] -> tau
 674
 675 This seems curious at first, because we usually only have dictionary
 676 args whose types are of the form (C a) where a is a type variable.
 677 But this doesn't hold for the functions arising from instance decls,
 678 which sometimes get arguements with types of form (C (T a)) for some
 679 type constructor T.
 680
 681 Should we specialise wrt this compound-type dictionary?  We used to say
 682 "no", saying:
 683         "This is a heuristic judgement, as indeed is the fact that we
 684         specialise wrt only dictionaries.  We choose *not* to specialise
 685         wrt compound dictionaries because at the moment the only place
 686         they show up is in instance decls, where they are simply plugged
 687         into a returned dictionary.  So nothing is gained by specialising
 688         wrt them."
 689
 690 But it is simpler and more uniform to specialise wrt these dicts too;
 691 and in future GHC is likely to support full fledged type signatures
 692 like
 693         f ;: Eq [(a,b)] => ...
 694
 695
 696 %************************************************************************
 697 %*                                                                      *
 698 \subsubsection[CallInstances]{@CallInstances@ data type}
 699 %*                                                                      *
 700 %************************************************************************
 701
 702 \begin{code}
 703 type FreeVarsSet   = IdSet
 704 type FreeTyVarsSet = TyVarSet
 705
 706 data CallInstance
 707   = CallInstance
 708                 Id                -- This Id; *new* ie *cloned* id
 709                 [Maybe Type]      -- Specialised at these types (*new*, cloned)
 710                                   -- Nothing => no specialisation on this type arg
 711                                   --          is required (flag dependent).
 712                 [CoreArg]         -- And these dictionaries; all ValArgs
 713                 FreeVarsSet       -- Free vars of the dict-args in terms of *new* ids
 714                 (Maybe SpecInfo)  -- For specialisation with explicit SpecId
 715 \end{code}
 716
 717 \begin{code}
 718 pprCI :: CallInstance -> Doc
 719 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
 720   = hang (hsep [ptext SLIT("Call inst for"), ppr PprDebug id])
 721          4 (vcat [hsep (text "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
 722                       case maybe_specinfo of
 723                         Nothing -> hsep (text "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
 724                         Just (SpecInfo _ _ spec_id)
 725                                 -> hsep [ptext SLIT("Explicit SpecId"), ppr PprDebug spec_id]
 726                      ])
 727
 728 -- ToDo: instance Outputable CoreArg?
 729 ppr_arg sty (TyArg  t) = ppr sty t
 730 ppr_arg sty (LitArg i) = ppr sty i
 731 ppr_arg sty (VarArg v) = ppr sty v
 732
 733 isUnboxedCI :: CallInstance -> Bool
 734 isUnboxedCI (CallInstance _ spec_tys _ _ _)
 735   = any isUnboxedType (catMaybes spec_tys)
 736
 737 isExplicitCI :: CallInstance -> Bool
 738 isExplicitCI (CallInstance _ _ _ _ (Just _))
 739   = True
 740 isExplicitCI (CallInstance _ _ _ _ Nothing)
 741   = False
 742 \end{code}
 743
 744 Comparisons are based on the {\em types}, ignoring the dictionary args:
 745
 746 \begin{code}
 747
 748 cmpCI :: CallInstance -> CallInstance -> TAG_
 749 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
 750   = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
 751
 752 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
 753 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
 754   = cmpUniTypeMaybeList tys1 tys2
 755
 756 eqCI_tys :: CallInstance -> CallInstance -> Bool
 757 eqCI_tys c1 c2
 758   = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
 759
 760 isCIofTheseIds :: [Id] -> CallInstance -> Bool
 761 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
 762   = any ((==) ci_id) ids
 763
 764 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
 765 singleCI id tys dicts
 766   = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
 767                  emptyBag [] emptyIdSet 0 0
 768   where
 769     fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
 770
 771 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
 772 explicitCI id tys specinfo
 773   = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
 774   where
 775     call_inst = CallInstance id tys dicts fv_set (Just specinfo)
 776     dicts  = panic "Specialise:explicitCI:dicts"
 777     fv_set = unitIdSet id
 778
 779 -- We do not process the CIs for top-level dfuns or defms
 780 -- Instead we require an explicit SPEC inst pragma for dfuns
 781 -- and an explict method within any instances for the defms
 782
 783 getCIids :: Bool -> [Id] -> [Id]
 784 getCIids True ids = filter not_dict_or_defm ids
 785 getCIids _    ids = ids
 786
 787 not_dict_or_defm id
 788   = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
 789
 790 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
 791 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
 792   = let
 793         (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
 794         cis_here_list = bagToList cis_here
 795     in
 796     -- pprTrace "getCIs:"
 797     -- (hang (hcat [char '{',
 798     --                     interppSP PprDebug ids,
 799     --                     char '}'])
 800     --       4 (vcat (map pprCI cis_here_list)))
 801     (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
 802
 803 dumpCIs :: Bag CallInstance     -- The call instances
 804         -> Bool                 -- True <=> top level bound Ids
 805         -> Bool                 -- True <=> dict bindings to be floated (specBind only)
 806         -> [CallInstance]       -- Call insts for bound ids (instBind only)
 807         -> [Id]                 -- Bound ids *new*
 808         -> [Id]                 -- Full bound ids: includes dumped dicts
 809         -> Bag CallInstance     -- Kept call instances
 810
 811         -- CIs are dumped if:
 812         --   1) they are a CI for one of the bound ids, or
 813         --   2) they mention any of the dicts in a local unfloated binding
 814         --
 815         -- For top-level bindings we allow the call instances to
 816         -- float past a dict bind and place all the top-level binds
 817         -- in a *global* Rec.
 818         -- We leave it to the simplifier will sort it all out ...
 819
 820 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
 821  = (if not (isEmptyBag cis_of_bound_id) &&
 822        not (isEmptyBag cis_of_bound_id_without_inst_cis)
 823     then
 824        pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
 825                  "         (may be a non-HM recursive call)\n")
 826        (hang (hcat [char '{',
 827                            interppSP PprDebug bound_ids,
 828                            char '}'])
 829              4 (vcat [ptext SLIT("Dumping CIs:"),
 830                           vcat (map pprCI (bagToList cis_of_bound_id)),
 831                           ptext SLIT("Instantiating CIs:"),
 832                           vcat (map pprCI inst_cis)]))
 833     else id) (
 834    if top_lev || floating then
 835        cis_not_bound_id
 836    else
 837        (if not (isEmptyBag cis_dump_unboxed)
 838         then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
 839              (hang (hcat [char '{',
 840                                  interppSP PprDebug full_ids,
 841                                  char '}'])
 842                    4 (vcat (map pprCI (bagToList cis_dump))))
 843         else id)
 844        cis_keep_not_bound_id
 845    )
 846  where
 847    (cis_of_bound_id, cis_not_bound_id)
 848       = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
 849
 850    (cis_dump, cis_keep_not_bound_id)
 851       = partitionBag ok_to_dump_ci cis_not_bound_id
 852
 853    ok_to_dump_ci (CallInstance _ _ _ fv_set _)
 854         = any (\ i -> i `elementOfIdSet` fv_set) full_ids
 855
 856    (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
 857    have_inst_ci ci = any (eqCI_tys ci) inst_cis
 858
 859    (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
 860
 861 \end{code}
 862
 863 Any call instances of a bound_id can be safely dumped, because any
 864 recursive calls should be at the same instance as the parent instance.
 865
 866    letrec f = /\a -> \x::a -> ...(f t x')...
 867
 868 Here, the type, t, at which f is used in its own RHS should be
 869 just "a"; that is, the recursive call is at the same type as
 870 the original call. That means that when specialising f at some
 871 type, say Int#, we shouldn't find any *new* instances of f
 872 arising from specialising f's RHS.  The only instance we'll find
 873 is another call of (f Int#).
 874
 875 We check this in dumpCIs by passing in all the instantiated call
 876 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
 877 for which there is no such instance.
 878
 879 We also report CIs dumped due to a bound dictionary arg if they
 880 contain unboxed types.
 881
 882 %************************************************************************
 883 %*                                                                      *
 884 \subsubsection[TyConInstances]{@TyConInstances@ data type}
 885 %*                                                                      *
 886 %************************************************************************
 887
 888 \begin{code}
 889 data TyConInstance
 890   = TyConInstance TyCon                 -- Type Constructor
 891                   [Maybe Type]  -- Applied to these specialising types
 892
 893 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
 894 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
 895   = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
 896
 897 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
 898 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
 899   = cmpUniTypeMaybeList tys1 tys2
 900
 901 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
 902 singleTyConI ty_con spec_tys
 903   = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
 904
 905 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
 906 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
 907
 908 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
 909 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
 910
 911 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
 912 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
 913   = let
 914         (tycon_cis_local, tycon_cis_global)
 915           = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
 916         tycon_cis_local_list = bagToList tycon_cis_local
 917     in
 918     (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
 919 \end{code}
 920
 921
 922 %************************************************************************
 923 %*                                                                      *
 924 \subsubsection[UsageDetails]{@UsageDetails@ data type}
 925 %*                                                                      *
 926 %************************************************************************
 927
 928 \begin{code}
 929 data UsageDetails
 930   = UsageDetails
 931         (Bag CallInstance)      -- The collection of call-instances
 932         (Bag TyConInstance)     -- Constructor call-instances
 933         [DictBindDetails]       -- Dictionary bindings in data-dependence order!
 934         FreeVarsSet             -- Free variables (excl imported ones, incl top level) (cloned)
 935         Int                     -- no. of spec calls
 936         Int                     -- no. of spec insts
 937 \end{code}
 938
 939 The DictBindDetails are fully processed; their call-instance
 940 information is incorporated in the call-instances of the UsageDetails
 941 which includes the DictBindDetails.  The free vars in a usage details
 942 will *include* the binders of the DictBind details.
 943
 944 A @DictBindDetails@ contains bindings for dictionaries *only*.
 945
 946 \begin{code}
 947 data DictBindDetails
 948   = DictBindDetails
 949         [Id]                    -- Main binders, originally visible in scope of binding (cloned)
 950         CoreBinding     -- Fully processed
 951         FreeVarsSet             -- Free in binding group (cloned)
 952         FreeTyVarsSet           -- Free in binding group
 953 \end{code}
 954
 955 \begin{code}
 956 emptyUDs    :: UsageDetails
 957 unionUDs    :: UsageDetails -> UsageDetails -> UsageDetails
 958 unionUDList :: [UsageDetails] -> UsageDetails
 959
 960 -- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
 961 tickSpecInsts :: UsageDetails -> UsageDetails
 962
 963 -- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
 964 -- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
 965
 966 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
 967  = UsageDetails cis ty_cis dbs fvs c (i+1)
 968
 969 emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
 970
 971 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
 972  = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
 973                 (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
 974         -- The append here is really redundant, since the bindings don't
 975         -- scope over each other.  ToDo.
 976
 977 unionUDList = foldr unionUDs emptyUDs
 978
 979 singleFvUDs (VarArg v) | not (isImportedId v)
 980  = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
 981 singleFvUDs other
 982  = emptyUDs
 983
 984 singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
 985
 986 dumpDBs :: [DictBindDetails]
 987         -> Bool                 -- True <=> top level bound Ids
 988         -> [TyVar]              -- TyVars being bound (cloned)
 989         -> [Id]                 -- Ids being bound (cloned)
 990         -> FreeVarsSet          -- Fvs of body
 991         -> ([CoreBinding],      -- These ones have to go here
 992             [DictBindDetails],  -- These can float further
 993             [Id],               -- Incoming list + names of dicts bound here
 994             FreeVarsSet         -- Incoming fvs + fvs of dicts bound here
 995            )
 996
 997         -- It is just to complex to try to float top-level
 998         -- dict bindings with constant methods, inst methods,
 999         -- auxillary derived instance defns and user instance
1000         -- defns all getting in the way.
1001         -- So we dump all dbinds as soon as we get to the top
1002         -- level and place them in a *global* Rec.
1003         -- We leave it to the simplifier will sort it all out ...
1004
1005 dumpDBs [] top_lev bound_tyvars bound_ids fvs
1006   = ([], [], bound_ids, fvs)
1007
1008 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
1009         top_lev bound_tyvars bound_ids fvs
1010   | top_lev
1011     || any (\ i -> i `elementOfIdSet`    db_fvs) bound_ids
1012     || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
1013   = let         -- Ha!  Dump it!
1014         (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1015            = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
1016     in
1017     (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1018
1019   | otherwise   -- This one can float out further
1020   = let
1021         (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1022            = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
1023     in
1024     (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
1025
1026
1027
1028 dumpUDs :: UsageDetails
1029         -> Bool                 -- True <=> top level bound Ids
1030         -> Bool                 -- True <=> dict bindings to be floated (specBind only)
1031         -> [CallInstance]       -- Call insts for bound Ids (instBind only)
1032         -> [Id]                 -- Ids which are just being bound; *new*
1033         -> [TyVar]              -- TyVars which are just being bound
1034         -> ([CoreBinding],      -- Bindings from UsageDetails which mention the ids
1035             UsageDetails)       -- The above bindings removed, and
1036                                 -- any call-instances which mention the ids dumped too
1037
1038 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
1039   = let
1040         (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
1041                   = dumpDBs dbs top_lev tvs bound_ids fvs
1042         cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
1043         fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
1044     in
1045     (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
1046 \end{code}
1047
1048 \begin{code}
1049 addDictBinds :: [Id] -> CoreBinding -> UsageDetails     -- Dict binding and RHS usage
1050              -> UsageDetails                                    -- The usage to augment
1051              -> UsageDetails
1052 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
1053                             (UsageDetails cis    tycon_cis    dbs    fvs    c    i)
1054   = UsageDetails (db_cis `unionBags` cis)
1055                  (db_tycon_cis `unionBags` tycon_cis)
1056                  (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
1057                  fvs c i
1058                  -- NB: We ignore counts from dictbinds since it is not user code
1059   where
1060         -- The free tyvars of the dictionary bindings should really be
1061         -- gotten from the RHSs, but I'm pretty sure it's good enough just
1062         -- to look at the type of the dictionary itself.
1063         -- Doing the proper job would entail keeping track of free tyvars as
1064         -- well as free vars, which would be a bore.
1065     db_ftvs = tyVarsOfTypes (map idType dbinders)
1066 \end{code}
1067
1068 %************************************************************************
1069 %*                                                                      *
1070 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
1071 %*                                                                      *
1072 %************************************************************************
1073
1074 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
1075
1076 1) (NoLift LitArg l) : an Id which is bound to a literal
1077
1078 2) (NoLift LitArg l) : an Id bound to a "new" Id
1079    The new Id is a possibly-type-specialised clone of the original
1080
1081 3) Lifted lifted_id unlifted_id :
1082
1083    This indicates that the original Id has been specialised to an
1084    unboxed value which must be lifted (see "Unboxed bindings" above)
1085      @unlifted_id@ is the unboxed clone of the original Id
1086      @lifted_id@ is a *lifted* version of the original Id
1087
1088    When you lookup Ids which are Lifted, you have to insert a case
1089    expression to un-lift the value (done with @bindUnlift@)
1090
1091    You also have to insert a case to lift the value in the binding
1092    (done with @liftExpr@)
1093
1094
1095 \begin{code}
1096 type SpecIdEnv = IdEnv CloneInfo
1097
1098 data CloneInfo
1099  = NoLift CoreArg       -- refers to cloned id or literal
1100
1101  | Lifted Id            -- lifted, cloned id
1102           Id            -- unlifted, cloned id
1103
1104 \end{code}
1105
1106 %************************************************************************
1107 %*                                                                      *
1108 \subsection[specialise-data]{Data returned by specialiser}
1109 %*                                                                      *
1110 %************************************************************************
1111
1112 \begin{code}
1113 -}
1114
1115 data SpecialiseData
1116  = SpecData Bool
1117                 -- True <=> Specialisation performed
1118             Bool
1119                 -- False <=> Specialisation completed with errors
1120
1121             [TyCon]
1122                 -- Local tycons declared in this module
1123
1124             [TyCon]
1125                 -- Those in-scope data types for which we want to
1126                 -- generate code for their constructors.
1127                 -- Namely: data types declared in this module +
1128                 --         any big tuples used in this module
1129                 -- The initial (and default) value is the local tycons
1130
1131             (FiniteMap TyCon [(Bool, [Maybe Type])])
1132                 -- TyCon specialisations to be generated
1133                 -- We generate specialialised code (Bool=True) for data types
1134                 -- defined in this module and any tuples used in this module
1135                 -- The initial (and default) value is the specialisations
1136                 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1137                 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1138
1139             (Bag (Id,[Maybe Type]))
1140                 -- Imported specialisation errors
1141             (Bag (Id,[Maybe Type]))
1142                 -- Imported specialisation warnings
1143             (Bag (TyCon,[Maybe Type]))
1144                 -- Imported TyCon specialisation errors
1145
1146 initSpecData local_tycons tycon_specs
1147  = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1148
1149 {-
1150 \end{code}
1151
1152 ToDo[sansom]: Transformation data to process specialisation requests.
1153
1154 %************************************************************************
1155 %*                                                                      *
1156 \subsection[specProgram]{Specialising a core program}
1157 %*                                                                      *
1158 %************************************************************************
1159
1160 \begin{code}
1161 specProgram :: UniqSupply
1162             -> [CoreBinding]    -- input ...
1163             -> SpecialiseData
1164             -> ([CoreBinding],  -- main result
1165                 SpecialiseData)         -- result specialise data
1166
1167 specProgram uniqs binds
1168            (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1169   = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
1170       (final_binds, tycon_specs_list,
1171         UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1172          -> let
1173                 used_conids   = filter isDataCon (uniqSetToList fvs)
1174                 used_tycons   = map dataConTyCon used_conids
1175                 used_gen      = filter isLocalGenTyCon used_tycons
1176                 gen_tycons    = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
1177
1178                 result_specs  = addListToFM_C (++) init_specs tycon_specs_list
1179
1180                 uniq_cis      = map head (equivClasses cmpCI (bagToList import_cis))
1181                 cis_list      = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1182                 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1183                 cis_warn      = init_warn `unionBags` listToBag cis_other
1184                 cis_errs      = init_errs `unionBags` listToBag cis_unboxed
1185
1186                 uniq_tycis    = map head (equivClasses cmpTyConI (bagToList import_tycis))
1187                 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1188                 tycis_errs    = init_tyerrs `unionBags` listToBag tycis_unboxed
1189
1190                 no_errs       = isEmptyBag cis_errs && isEmptyBag tycis_errs
1191                                   && (not opt_SpecialiseImports || isEmptyBag cis_warn)
1192             in
1193             (if opt_D_simplifier_stats then
1194                 pprTrace "\nSpecialiser Stats:\n" (vcat [
1195                                         hcat [ptext SLIT("SpecCalls  "), int spec_calls],
1196                                         hcat [ptext SLIT("SpecInsts  "), int spec_insts],
1197                                         space])
1198              else id)
1199
1200             (final_binds,
1201              SpecData True no_errs local_tycons gen_tycons result_specs
1202                                    cis_errs cis_warn tycis_errs)
1203
1204 specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
1205   = panic "Specialise:specProgram: specialiser called more than once"
1206
1207 -- It may be possible safely to call the specialiser more than once,
1208 -- but I am not sure there is any benefit in doing so (Patrick)
1209
1210 -- ToDo: What about unfoldings performed after specialisation ???
1211 \end{code}
1212
1213 %************************************************************************
1214 %*                                                                      *
1215 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1216 %*                                                                      *
1217 %************************************************************************
1218
1219 In the specialiser we just collect up the specialisations which will
1220 be required. We don't create the specialised constructors in
1221 Core. These are only introduced when we convert to StgSyn.
1222
1223 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1224
1225 \begin{code}
1226 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1227                    -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1228
1229 specTyConsAndScope scopeM
1230   = scopeM                      `thenSM` \ (binds, scope_uds) ->
1231     let
1232        (tycons_cis, gotci_scope_uds)
1233          = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds
1234
1235        tycon_specs_list = collectTyConSpecs tycons_cis
1236     in
1237     (if opt_SpecialiseTrace && not (null tycon_specs_list) then
1238          pprTrace "Specialising TyCons:\n"
1239          (vcat [ if not (null specs) then
1240                          hang (hsep [(ppr PprDebug tycon), ptext SLIT("at types")])
1241                               4 (vcat (map pp_specs specs))
1242                      else empty
1243                    | (tycon, specs) <- tycon_specs_list])
1244     else id) (
1245     returnSM (binds, tycon_specs_list, gotci_scope_uds)
1246     )
1247   where
1248     collectTyConSpecs []
1249       = []
1250     collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1251       = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1252       where
1253         (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1254         uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1255         tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1256
1257     pp_specs (False, spec_tys) = hsep [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
1258
1259 \end{code}
1260
1261 %************************************************************************
1262 %*                                                                      *
1263 \subsection[specTopBinds]{Specialising top-level bindings}
1264 %*                                                                      *
1265 %************************************************************************
1266
1267 \begin{code}
1268 specTopBinds :: [CoreBinding]
1269              -> SpecM ([CoreBinding], UsageDetails)
1270
1271 specTopBinds binds
1272   = spec_top_binds binds    `thenSM`  \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1273     let
1274         -- Add bindings for floated dbinds and collect fvs
1275         -- In actual fact many of these bindings are dead code since dict
1276         -- arguments are dropped when a specialised call is created
1277         -- The simplifier should be able to cope ...
1278
1279         (dbinders_s, dbinds, dfvs_s)
1280            = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1281
1282         full_fvs  = fvs `unionIdSets` unionManyIdSets dfvs_s
1283         fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
1284
1285         -- It is just to complex to try to sort out top-level dependencies
1286         -- So we just place all the top-level binds in a *global* Rec and
1287         -- leave it to the simplifier to sort it all out ...
1288     in
1289     ASSERT(null dbinds)
1290     returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1291
1292   where
1293     spec_top_binds (first_bind:rest_binds)
1294       = specBindAndScope True first_bind (
1295             spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1296             returnSM (ItsABinds rest_binds, rest_uds)
1297         )                       `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1298         returnSM (first_binds ++ rest_binds, all_uds)
1299
1300     spec_top_binds []
1301       = returnSM ([], emptyUDs)
1302 \end{code}
1303
1304 %************************************************************************
1305 %*                                                                      *
1306 \subsection[specExpr]{Specialising expressions}
1307 %*                                                                      *
1308 %************************************************************************
1309
1310 \begin{code}
1311 specExpr :: CoreExpr
1312          -> [CoreArg]           -- The arguments:
1313                                 --    TypeArgs are speced
1314                                 --    ValArgs are unprocessed
1315          -> SpecM (CoreExpr,    -- Result expression with specialised versions installed
1316                    UsageDetails)-- Details of usage of enclosing binders in the result
1317                                 -- expression.
1318
1319 specExpr (Var v) args
1320   = specId v            $ \ v_arg ->
1321     case v_arg of
1322        LitArg lit -> ASSERT( null args )
1323                      returnSM (Lit lit, emptyUDs)
1324
1325        VarArg new_v -> mkCallInstance v new_v args      `thenSM` \ uds ->
1326                        returnSM (mkGenApp (Var new_v) args, uds)
1327
1328 specExpr expr@(Lit _) null_args
1329   = ASSERT (null null_args)
1330     returnSM (expr, emptyUDs)
1331
1332 specExpr (Con con args) null_args
1333   = ASSERT (null null_args)
1334     specArgs args               $ \ args' ->
1335     mkTyConInstance con args'   `thenSM` \ con_uds ->
1336     returnSM (Con con args', con_uds)
1337
1338 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
1339   = ASSERT (null null_args)
1340     specArgs args               $ \ args' ->
1341     mapSM specTy arg_tys        `thenSM` \ arg_tys' ->
1342     specTy res_ty               `thenSM` \ res_ty' ->
1343     returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs)
1344
1345 specExpr (Prim prim args) null_args
1346   = ASSERT (null null_args)
1347     specArgs args               $ \ args' ->
1348     -- specPrimOp prim tys              `thenSM` \ (prim, tys, prim_uds) ->
1349     returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
1350
1351 {- ToDo: specPrimOp
1352
1353 specPrimOp :: PrimOp
1354            -> [Type]
1355            -> SpecM (PrimOp,
1356                      [Type],
1357                      UsageDetails)
1358
1359 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1360 --   and/or chooses PrimOp specialised to any unboxed tys
1361 -- Errors are dealt with by returning a PrimOp call instance
1362 --   which will result in a cis_errs message
1363
1364 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1365 -}
1366
1367
1368 specExpr (App fun arg) args
1369   = specArg arg                         `thenSM` \ new_arg    ->
1370     specExpr fun (new_arg : args)       `thenSM` \ (expr,uds) ->
1371     returnSM (expr, uds)
1372
1373 specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
1374   = lookup_arg arg `thenSM` \ arg ->
1375     bindId binder arg (specExpr body args)
1376   where
1377     lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1378     lookup_arg (VarArg v) = lookupId v
1379
1380 specExpr (Lam (ValBinder binder) body) []
1381   = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1382     returnSM (Lam (ValBinder binder) body, uds)
1383
1384 specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
1385   =     -- Type lambda with argument; argument already spec'd
1386     bindTyVar tyvar ty ( specExpr body args )
1387
1388 specExpr (Lam (TyBinder tyvar) body) []
1389   =     -- No arguments
1390     cloneTyVarSM tyvar          `thenSM` \ new_tyvar ->
1391     bindTyVar tyvar (mkTyVarTy new_tyvar) (
1392         specExpr body []        `thenSM` \ (body, body_uds) ->
1393         let
1394             (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1395         in
1396         returnSM (Lam (TyBinder new_tyvar)
1397                       (mkCoLetsNoUnboxed binds_here body),
1398                   final_uds)
1399     )
1400
1401 specExpr (Case scrutinee alts) args
1402   = specExpr scrutinee []               `thenSM` \ (scrutinee, scrut_uds) ->
1403     specAlts alts scrutinee_type args   `thenSM` \ (alts, alts_uds) ->
1404     returnSM (Case scrutinee alts, scrut_uds `unionUDs`  alts_uds)
1405   where
1406     scrutinee_type = coreExprType scrutinee
1407
1408 specExpr (Let bind body) args
1409   = specBindAndScope False bind (
1410         specExpr body args      `thenSM` \ (body, body_uds) ->
1411         returnSM (ItsAnExpr body, body_uds)
1412     )                           `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1413     returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1414
1415 specExpr (SCC cc expr) args
1416   = specExpr expr []                `thenSM` \ (expr, expr_uds) ->
1417     mapAndUnzip3SM specOutArg args  `thenSM` \ (args, args_uds_s, unlifts) ->
1418     let
1419         scc_expr
1420           = if squashableDictishCcExpr cc expr -- can toss the _scc_
1421             then expr
1422             else SCC cc expr
1423     in
1424     returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1425               unionUDList args_uds_s `unionUDs` expr_uds)
1426
1427 specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
1428
1429 -- ToDo: This may leave some unspec'd dictionaries!!
1430 \end{code}
1431
1432 %************************************************************************
1433 %*                                                                      *
1434 \subsubsection{Specialising a lambda}
1435 %*                                                                      *
1436 %************************************************************************
1437
1438 \begin{code}
1439 specLambdaOrCaseBody :: [Id]                    -- The binders
1440                      -> CoreExpr                -- The body
1441                      -> [CoreArg]               -- Its args
1442                      -> SpecM ([Id],            -- New binders
1443                                CoreExpr,        -- New body
1444                                UsageDetails)
1445
1446 specLambdaOrCaseBody bound_ids body args
1447  = cloneLambdaOrCaseBinders bound_ids   `thenSM` \ (new_ids, clone_infos) ->
1448    bindIds bound_ids clone_infos (
1449
1450         specExpr body args      `thenSM` \ (body, body_uds) ->
1451
1452         let
1453             -- Dump any dictionary bindings (and call instances)
1454             -- from the scope which mention things bound here
1455             (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1456         in
1457         returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1458    )
1459
1460 -- ToDo: Opportunity here to common-up dictionaries with same type,
1461 -- thus avoiding recomputation.
1462 \end{code}
1463
1464 A variable bound in a lambda or case is normally monomorphic so no
1465 specialised versions will be required. This is just as well since we
1466 do not know what code to specialise!
1467
1468 Unfortunately this is not always the case. For example a class Foo
1469 with polymorphic methods gives rise to a dictionary with polymorphic
1470 components as follows:
1471
1472 \begin{verbatim}
1473 class Foo a where
1474   op1 :: a -> b -> a
1475   op2 :: a -> c -> a
1476
1477 instance Foo Int where
1478   op1 = op1Int
1479   op2 = op2Int
1480
1481 ... op1 1 3# ...
1482
1483 ==>
1484
1485 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1486 d.Foo.Int = (op1_Int, op2_Int)
1487
1488 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1489
1490 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1491 \end{verbatim}
1492
1493 N.B. The type of the dictionary is not Hindley Milner!
1494
1495 Now we must specialise op1 at {* Int#} which requires a version of
1496 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1497 not have access to its code to create the specialised version.
1498
1499 If we specialise on overloaded types as well we specialise op1 at
1500 {Int Int#} d.Foo.Int:
1501
1502 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1503
1504 Though this is still invalid, after further simplification we get:
1505
1506 op1_Int_Int# = opInt1 {Int#}
1507
1508 Another round of specialisation will result in the specialised
1509 version of op1Int being called directly.
1510
1511 For now we PANIC if a polymorphic lambda/case bound variable is found
1512 in a call instance with an unboxed type. Other call instances, arising
1513 from overloaded type arguments, are discarded since the unspecialised
1514 version extracted from the method can be called as normal.
1515
1516 ToDo: Implement and test second round of specialisation.
1517
1518
1519 %************************************************************************
1520 %*                                                                      *
1521 \subsubsection{Specialising case alternatives}
1522 %*                                                                      *
1523 %************************************************************************
1524
1525
1526 \begin{code}
1527 specAlts (AlgAlts alts deflt) scrutinee_ty args
1528   = mapSM specTy ty_args                        `thenSM` \ ty_args ->
1529     mapAndUnzipSM (specAlgAlt ty_args) alts     `thenSM` \ (alts, alts_uds_s) ->
1530     specDeflt deflt args                        `thenSM` \ (deflt, deflt_uds) ->
1531     returnSM (AlgAlts alts deflt,
1532               unionUDList alts_uds_s `unionUDs` deflt_uds)
1533   where
1534     -- We use ty_args of scrutinee type to identify specialisation of
1535     -- alternatives:
1536
1537     (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
1538                       getAppDataTyConExpandingDicts scrutinee_ty
1539
1540     specAlgAlt ty_args (con,binders,rhs)
1541       = specLambdaOrCaseBody binders rhs args   `thenSM` \ (binders, rhs, rhs_uds) ->
1542         mkTyConInstance con ty_args             `thenSM` \ con_uds ->
1543         returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1544
1545 specAlts (PrimAlts alts deflt) scrutinee_ty args
1546   = mapAndUnzipSM specPrimAlt alts      `thenSM` \ (alts, alts_uds_s) ->
1547     specDeflt deflt args                `thenSM` \ (deflt, deflt_uds) ->
1548     returnSM (PrimAlts alts deflt,
1549               unionUDList alts_uds_s `unionUDs` deflt_uds)
1550   where
1551     specPrimAlt (lit,rhs) = specExpr rhs args   `thenSM` \ (rhs, uds) ->
1552                             returnSM ((lit,rhs), uds)
1553
1554
1555 specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
1556 specDeflt (BindDefault binder rhs) args
1557  = specLambdaOrCaseBody [binder] rhs args       `thenSM` \ ([binder], rhs, uds) ->
1558    returnSM (BindDefault binder rhs, uds)
1559 \end{code}
1560
1561
1562 %************************************************************************
1563 %*                                                                      *
1564 \subsubsection{Specialising an atom}
1565 %*                                                                      *
1566 %************************************************************************
1567
1568 \begin{code}
1569 partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
1570 partition_args args
1571   = span is_ty_arg args
1572   where
1573     is_ty_arg (TyArg _) = True
1574     is_ty_arg _         = False
1575
1576 ----------
1577 specId :: Id
1578        -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
1579        -> SpecM (CoreExpr, UsageDetails)
1580 specId v
1581   = lookupId v          `thenSM` \ vlookup ->
1582     case vlookup of
1583
1584       Lifted vl vu
1585          -> thing_inside (VarArg vu)    `thenSM` \ (expr, uds) ->
1586             returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
1587
1588       NoLift vatom
1589          -> thing_inside vatom          `thenSM` \ (expr, uds) ->
1590             returnSM (expr, singleFvUDs vatom `unionUDs` uds)
1591
1592 specArg :: CoreArg
1593         -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
1594         -> SpecM (CoreExpr, UsageDetails))
1595
1596 specArg (TyArg ty) thing_inside
1597   = specTy ty   `thenSM` \ new_ty ->
1598     thing_inside (TyArg new_ty)
1599
1600 specArg (LitArg lit)
1601   = thing_inside (LitArg lit)
1602
1603 specArg (VarArg v)
1604
1605
1606 specArgs [] thing_inside
1607   = thing_inside []
1608
1609 specArgs (arg:args) thing_inside
1610   = specArg arg         $ \ arg' ->
1611     specArgs args       $ \ args' ->
1612     thing_inside (arg' : args')
1613 \end{code}
1614
1615
1616 %************************************************************************
1617 %*                                                                      *
1618 \subsubsection{Specialising bindings}
1619 %*                                                                      *
1620 %************************************************************************
1621
1622 A classic case of when having a polymorphic recursive function would help!
1623
1624 \begin{code}
1625 data BindsOrExpr = ItsABinds [CoreBinding]
1626                  | ItsAnExpr CoreExpr
1627 \end{code}
1628
1629 \begin{code}
1630 specBindAndScope
1631         :: Bool                                 -- True <=> a top level group
1632         -> CoreBinding                  -- As yet unprocessed
1633         -> SpecM (BindsOrExpr, UsageDetails)    -- Something to do the scope of the bindings
1634         -> SpecM ([CoreBinding],                -- Processed
1635                   BindsOrExpr,                  -- Combined result
1636                   UsageDetails)                 -- Usage details of the whole lot
1637
1638 specBindAndScope top_lev bind scopeM
1639   = cloneLetBinders top_lev (is_rec bind) binders
1640                                 `thenSM` \ (new_binders, clone_infos) ->
1641
1642         -- Two cases now: either this is a bunch of local dictionaries,
1643         -- in which case we float them; or its a bunch of other values,
1644         -- in which case we see if they correspond to any call-instances
1645         -- we have from processing the scope
1646
1647     if not top_lev && all (isDictTy . idType) binders
1648     then
1649         -- Ha! A group of local dictionary bindings
1650
1651       bindIds binders clone_infos (
1652
1653                 -- Process the dictionary bindings themselves
1654         specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
1655
1656                 -- Process their scope
1657         scopeM                                  `thenSM` \ (thing, scope_uds) ->
1658         let
1659                 -- Add the bindings to the current stuff
1660             final_uds = addDictBinds new_binders bind rhs_uds scope_uds
1661         in
1662         returnSM ([], thing, final_uds)
1663       )
1664     else
1665         -- Ho! A group of bindings
1666
1667       fixSM (\ ~(_, _, _, rec_spec_infos) ->
1668
1669         bindSpecIds binders clone_infos rec_spec_infos (
1670                 -- It's ok to have new binders in scope in
1671                 -- non-recursive decls too, cos name shadowing is gone by now
1672
1673                 -- Do the scope of the bindings
1674           scopeM                                `thenSM` \ (thing, scope_uds) ->
1675           let
1676              (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
1677
1678              equiv_ciss = equivClasses cmpCI_tys call_insts
1679              inst_cis   = map head equiv_ciss
1680           in
1681
1682                 -- Do the bindings themselves
1683           specBind top_lev False new_binders inst_cis bind
1684                                                 `thenSM` \ (spec_bind, spec_uds) ->
1685
1686                 -- Create any necessary instances
1687           instBind top_lev new_binders bind equiv_ciss inst_cis
1688                                                 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
1689
1690           let
1691                 -- NB: dumpUDs only worries about new_binders since the free var
1692                 --     stuff only records free new_binders
1693                 --     The spec_ids only appear in SpecInfos and final speced calls
1694
1695                 -- Build final binding group and usage details
1696                 (final_binds, final_uds)
1697                   = if top_lev then
1698                         -- For a top-level binding we have to dumpUDs from
1699                         -- spec_uds and inst_uds and scope_uds creating
1700                         -- *global* dict bindings
1701                         let
1702                             (scope_dict_binds, final_scope_uds)
1703                               = dumpUDs gotci_scope_uds True False [] new_binders []
1704                             (spec_dict_binds, final_spec_uds)
1705                               = dumpUDs spec_uds True False inst_cis new_binders []
1706                             (inst_dict_binds, final_inst_uds)
1707                               = dumpUDs inst_uds True False inst_cis new_binders []
1708                         in
1709                         ([spec_bind] ++ inst_binds ++ scope_dict_binds
1710                            ++ spec_dict_binds ++ inst_dict_binds,
1711                          final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
1712                     else
1713                         -- For a local binding we only have to dumpUDs from
1714                         -- scope_uds since the UDs from spec_uds and inst_uds
1715                         -- have already been dumped by specBind and instBind
1716                         let
1717                             (scope_dict_binds, final_scope_uds)
1718                               = dumpUDs gotci_scope_uds False False [] new_binders []
1719                         in
1720                         ([spec_bind] ++ inst_binds ++ scope_dict_binds,
1721                          spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
1722
1723                 -- inst_uds comes last, because there may be dict bindings
1724                 -- floating outward in scope_uds which are mentioned
1725                 -- in the call-instances, and hence in spec_uds.
1726                 -- This ordering makes sure that the precedence order
1727                 -- among the dict bindings finally floated out is maintained.
1728           in
1729           returnSM (final_binds, thing, final_uds, spec_infos)
1730         )
1731       )                 `thenSM`        \ (binds, thing, final_uds, spec_infos) ->
1732       returnSM (binds, thing, final_uds)
1733   where
1734     binders = bindersOf bind
1735
1736     is_rec (NonRec _ _) = False
1737     is_rec _              = True
1738 \end{code}
1739
1740 \begin{code}
1741 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
1742          -> CoreBinding
1743          -> SpecM (CoreBinding, UsageDetails)
1744         -- The UsageDetails returned has already had stuff to do with this group
1745         -- of binders deleted; that's why new_binders is passed in.
1746 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
1747   = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
1748                                                         `thenSM` \ ((binder,rhs), rhs_uds) ->
1749     returnSM (NonRec binder rhs, rhs_uds)
1750
1751 specBind top_lev floating new_binders inst_cis (Rec pairs)
1752   = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
1753                                                         `thenSM` \ (pairs, rhs_uds_s) ->
1754     returnSM (Rec pairs, unionUDList rhs_uds_s)
1755
1756
1757 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
1758                -> (Id,CoreExpr)
1759                -> SpecM ((Id,CoreExpr), UsageDetails)
1760
1761 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
1762   = lookupId binder             `thenSM` \ blookup ->
1763     specExpr rhs []             `thenSM` \ (rhs, rhs_uds) ->
1764     let
1765         specid_maybe_maybe  = isSpecPragmaId_maybe binder
1766         is_specid           = maybeToBool specid_maybe_maybe
1767         Just specinfo_maybe = specid_maybe_maybe
1768         specid_with_info    = maybeToBool specinfo_maybe
1769         Just spec_info      = specinfo_maybe
1770
1771         -- If we have a SpecInfo stored in a SpecPragmaId binder
1772         -- it will contain a SpecInfo with an explicit SpecId
1773         -- We add the explicit ci to the usage details
1774         -- Any ordinary cis for orig_id (there should only be one)
1775         -- will be ignored later
1776
1777         pragma_uds
1778           = if is_specid && specid_with_info then
1779                 let
1780                     (SpecInfo spec_tys _ spec_id) = spec_info
1781                     Just (orig_id, _) = isSpecId_maybe spec_id
1782                 in
1783                 ASSERT(toplevelishId orig_id)     -- must not be cloned!
1784                 explicitCI orig_id spec_tys spec_info
1785             else
1786                 emptyUDs
1787
1788         -- For a local binding we dump the usage details, creating
1789         -- any local dict bindings required
1790         -- At the top-level the uds will be dumped in specBindAndScope
1791         -- and the dict bindings made *global*
1792
1793         (local_dict_binds, final_uds)
1794           = if not top_lev then
1795                 dumpUDs rhs_uds False floating inst_cis new_binders []
1796             else
1797                 ([], rhs_uds)
1798     in
1799     case blookup of
1800         Lifted lift_binder unlift_binder
1801           ->    -- We may need to record an unboxed instance of
1802                 -- the _Lift data type in the usage details
1803              mkTyConInstance liftDataCon [idType unlift_binder]
1804                                                 `thenSM` \ lift_uds ->
1805              returnSM ((lift_binder,
1806                         mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
1807                        final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
1808
1809         NoLift (VarArg binder)
1810           -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
1811                        final_uds `unionUDs` pragma_uds)
1812 \end{code}
1813
1814
1815 %************************************************************************
1816 %*                                                                      *
1817 \subsection{@instBind@}
1818 %*                                                                      *
1819 %************************************************************************
1820
1821 \begin{code}
1822 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
1823  | null equiv_ciss
1824  = returnSM ([], emptyUDs, [])
1825
1826  | all same_overloading other_binders
1827  =      -- For each call_inst, build an instance
1828    mapAndUnzip3SM do_this_class equiv_ciss
1829         `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
1830
1831         -- Add in the remaining UDs
1832    returnSM (catMaybes inst_binds,
1833              unionUDList inst_uds_s,
1834              spec_infos
1835             )
1836
1837  | otherwise            -- Incompatible overloadings; see below by same_overloading
1838  = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
1839     then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
1840     else if top_lev
1841     then pprTrace "dumpCIs: not same overloading ... top level \n"
1842     else (\ x y -> y)
1843    ) (hang (hcat [ptext SLIT("{"),
1844                          interppSP PprDebug new_ids,
1845                          ptext SLIT("}")])
1846            4 (vcat [vcat (map (pprGenType PprDebug . idType) new_ids),
1847                         vcat (map pprCI (concat equiv_ciss))]))
1848    (returnSM ([], emptyUDs, []))
1849
1850  where
1851     (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
1852     tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
1853
1854     no_of_tyvars = length tyvar_tmpls
1855     no_of_dicts  = length class_tyvar_pairs
1856
1857     do_this_class equiv_cis
1858       = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
1859       where
1860         (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
1861         do_cis = head (normal_cis ++ explicit_cis)
1862         -- must choose a normal_cis in preference since dict_args will
1863         -- not be defined for an explicit_cis
1864
1865         -- same_overloading tests whether the types of all the binders
1866         -- are "compatible"; ie have the same type and dictionary abstractions
1867         -- Almost always this is the case, because a recursive group is abstracted
1868         -- all together.  But, it can happen that it ain't the case, because of
1869         -- code generated from instance decls:
1870         --
1871         --      rec
1872         --        dfun.Foo.Int :: (forall a. a -> Int, Int)
1873         --        dfun.Foo.Int = (const.op1.Int, const.op2.Int)
1874         --
1875         --        const.op1.Int :: forall a. a -> Int
1876         --        const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
1877         --
1878         --        const.op2.Int :: Int
1879         --        const.op2.Int = 3
1880         --
1881         -- Note that the first two defns have different polymorphism, but they are
1882         -- mutually recursive!
1883
1884     same_overloading :: Id -> Bool
1885     same_overloading id
1886       = no_of_tyvars == length this_id_tyvars
1887         -- Same no of tyvars
1888         && no_of_dicts == length this_id_class_tyvar_pairs
1889         -- Same no of vdicts
1890         && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
1891         && length class_tyvar_pairs == length this_id_class_tyvar_pairs
1892         -- Same overloading
1893       where
1894         (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
1895         tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
1896
1897         same_ov (clas1,tyvar1) (clas2,tyvar2)
1898           = clas1  == clas2 &&
1899             tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
1900 \end{code}
1901
1902 OK, so we have:
1903         - a call instance                               eg f [t1,t2,t3] [d1,d2]
1904         - the rhs of the function                       eg orig_rhs
1905         - a constraint vector, saying which of          eg [T,F,T]
1906           the functions type args are constrained
1907           (ie overloaded)
1908
1909 We return a new definition
1910
1911         $f1 = /\a -> orig_rhs t1 a t3 d1 d2
1912
1913 The SpecInfo for f will be:
1914
1915         SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
1916
1917 Based on this SpecInfo, a call instance of f
1918
1919         ...(f t1 t2 t3)...
1920
1921 should get replaced by
1922
1923         ...(\d1 d2 -> $f1 t2)...
1924
1925 (But that is the business of the simplifier.)
1926
1927 \begin{code}
1928 mkOneInst :: CallInstance
1929           -> [CallInstance]                     -- Any explicit cis for this inst
1930           -> Int                                -- No of dicts to specialise
1931           -> Bool                               -- Top level binders?
1932           -> [CallInstance]                     -- Instantiated call insts for binders
1933           -> [Id]                               -- New binders
1934           -> CoreBinding                        -- Unprocessed
1935           -> SpecM (Maybe CoreBinding,  -- Instantiated version of input
1936                     UsageDetails,
1937                     [Maybe SpecInfo]            -- One for each id in the original binding
1938                    )
1939
1940 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
1941           no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
1942   = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
1943                                                         `thenSM` \ spec_ids ->
1944     newTyVars (length [() | Nothing <- spec_tys])       `thenSM` \ poly_tyvars ->
1945     let
1946         -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
1947         -- which correspond to unspecialised args
1948         arg_tys  :: [Type]
1949         (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
1950
1951         args :: [CoreArg]
1952         args = map TyArg arg_tys ++ dict_args
1953
1954         (new_id:_) = new_ids
1955         (spec_id:_) = spec_ids
1956
1957         do_bind (NonRec orig_id rhs)
1958           = do_one_rhs (spec_id, new_id, (orig_id,rhs))
1959                                         `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
1960             case maybe_spec of
1961                 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
1962                 Nothing             -> returnSM (Nothing, rhs_uds, [spec_info])
1963
1964         do_bind (Rec pairs)
1965           = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
1966                                         `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
1967             returnSM (Just (Rec (catMaybes maybe_pairs)),
1968                       unionUDList rhss_uds_s, spec_infos)
1969
1970         do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
1971
1972                 -- Avoid duplicating a spec which has already been created ...
1973                 -- This can arise in a Rec involving a dfun for which a
1974                 -- a specialised instance has been created but specialisation
1975                 -- "required" by one of the other Ids in the Rec
1976           | top_lev && maybeToBool lookup_orig_spec
1977           = (if opt_SpecialiseTrace
1978              then trace_nospec "  Exists: " orig_id
1979              else id) (
1980
1981             returnSM (Nothing, emptyUDs, Nothing)
1982             )
1983
1984                 -- Check for a (single) explicit call instance for this id
1985           | not (null explicit_cis_for_this_id)
1986           = ASSERT (length explicit_cis_for_this_id == 1)
1987             (if opt_SpecialiseTrace
1988              then trace_nospec "  Explicit: " explicit_id
1989              else id) (
1990
1991             returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
1992             )
1993
1994                 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
1995           | otherwise
1996           = ASSERT (no_of_dicts_to_specialise == length dict_args)
1997             specExpr orig_rhs args      `thenSM` \ (inst_rhs, inst_uds) ->
1998             let
1999                 -- For a local binding we dump the usage details, creating
2000                 -- any local dict bindings required
2001                 -- At the top-level the uds will be dumped in specBindAndScope
2002                 -- and the dict bindings made *global*
2003
2004                 (local_dict_binds, final_uds)
2005                   = if not top_lev then
2006                         dumpUDs inst_uds False False inst_cis new_ids []
2007                     else
2008                         ([], inst_uds)
2009
2010                 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
2011             in
2012             if isUnboxedType (idType spec_id) then
2013                 ASSERT (null poly_tyvars)
2014                 liftId spec_id          `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2015                 mkTyConInstance liftDataCon [idType unlift_spec_id]
2016                                         `thenSM` \ lift_uds ->
2017                 returnSM (Just (lift_spec_id,
2018                                 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
2019                           tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
2020             else
2021                 returnSM (Just (spec_id,
2022                                 mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
2023                           tickSpecInsts final_uds, spec_info)
2024           where
2025             lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
2026
2027             explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
2028             [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
2029             SpecInfo _ _ explicit_id = explicit_spec_info
2030
2031             trace_nospec :: String -> Id -> a -> a
2032             trace_nospec str spec_id
2033               = pprTrace str
2034                 (hsep [ppr PprDebug new_id, hsep (map pp_ty arg_tys),
2035                         ptext SLIT("==>"), ppr PprDebug spec_id])
2036     in
2037     (if opt_SpecialiseTrace then
2038         pprTrace "Specialising:"
2039         (hang (hcat [char '{',
2040                             interppSP PprDebug new_ids,
2041                             char '}'])
2042               4 (vcat [
2043                  hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)],
2044                  if isExplicitCI do_cis then empty else
2045                  hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)],
2046                  hcat [ptext SLIT("specs: "), ppr PprDebug spec_ids]]))
2047      else id) (
2048
2049     do_bind orig_bind           `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
2050
2051     returnSM (maybe_inst_bind, inst_uds, spec_infos)
2052     )
2053   where
2054     pp_dict d = ppr_arg PprDebug d
2055     pp_ty t   = pprParendGenType PprDebug t
2056
2057     do_the_wotsit (tyvar:tyvars) Nothing   = (tyvars, mkTyVarTy tyvar)
2058     do_the_wotsit tyvars         (Just ty) = (tyvars, ty)
2059
2060 \end{code}
2061
2062 %************************************************************************
2063 %*                                                                      *
2064 \subsection[Misc]{Miscellaneous junk}
2065 %*                                                                      *
2066 %************************************************************************
2067
2068 \begin{code}
2069 mkCallInstance :: Id
2070                -> Id
2071                -> [CoreArg]
2072                -> SpecM UsageDetails
2073
2074 mkCallInstance id new_id args
2075   | null args             ||            -- No args at all
2076     idWantsToBeINLINEd id ||            -- It's going to be inlined anyway
2077     not enough_args       ||            -- Not enough type and dict args
2078     not interesting_overloading         -- Overloaded types are just tyvars
2079   = returnSM emptyUDs
2080
2081   | otherwise
2082   = returnSM (singleCI new_id spec_tys dicts)
2083
2084   where
2085     (tyvars, theta, _)  = splitSigmaTy (idType id)
2086     constrained_tyvars  = tyvarsOfTypes (map snd class_tyvar_pairs)
2087
2088     arg_res                        = take_type_args tyvars class_tyvar_pairs args
2089     enough_args                    = maybeToBool arg_res
2090     (Just (tys, dicts, rest_args)) = arg_res
2091
2092     interesting_overloading = not (null (catMaybes spec_tys))
2093     spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys
2094
2095     ---------------------------------------------------------------
2096         -- Should we specialise on this type argument?
2097     spec_ty tyvar ty | isTyVarTy ty = Nothing
2098
2099     spec_ty tyvar ty |  opt_SpecialiseAll
2100                      || (opt_SpecialiseUnboxed
2101                         && isUnboxedType ty
2102                         && isBoxedTypeKind (tyVarKind tyvar))
2103                      || (opt_SpecialiseOverloaded
2104                         && tyvar `elemTyVarSet` constrained_tyvars)
2105                      = Just ty
2106
2107                      | otherwise = Nothing
2108
2109     ----------------- Rather a gruesome help-function ---------------
2110     take_type_args (_:tyvars) (TyArg ty : args)
2111         = case (take_type_args tyvars args) of
2112             Nothing                   -> Nothing
2113             Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2114
2115     take_type_args (_:tyvars) [] = Nothing
2116
2117     take_type_args [] args
2118         = case (take_dict_args class_tyvar_pairs args) of
2119             Nothing              -> Nothing
2120             Just (dicts, others) -> Just ([], dicts, others)
2121
2122     take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
2123         = case (take_dict_args class_tyvar_pairs args) of
2124             Nothing              -> Nothing
2125             Just (dicts, others) -> Just (dict:dicts, others)
2126
2127     take_dict_args (_:class_tyvar_pairs) args = Nothing
2128
2129     take_dict_args [] args = Just ([], args)
2130 \end{code}
2131
2132
2133 \begin{code}
2134 mkTyConInstance :: Id
2135                 -> [Type]
2136                 -> SpecM UsageDetails
2137 mkTyConInstance con tys
2138   = recordTyConInst con tys     `thenSM` \ record_inst ->
2139     case record_inst of
2140       Nothing                           -- No TyCon instance
2141         -> -- pprTrace "NoTyConInst:"
2142            -- (hsep [ppr PprDebug tycon, ptext SLIT("at"),
2143            --         ppr PprDebug con, hsep (map (ppr PprDebug) tys)])
2144            (returnSM (singleConUDs con))
2145
2146       Just spec_tys                     -- Record TyCon instance
2147         -> -- pprTrace "TyConInst:"
2148            -- (hsep [ppr PprDebug tycon, ptext SLIT("at"),
2149            --         ppr PprDebug con, hsep (map (ppr PprDebug) tys),
2150            --         hcat [char '(',
2151            --                    hsep [pprMaybeTy PprDebug ty | ty <- spec_tys],
2152            --                    char ')']])
2153            (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2154   where
2155     tycon = dataConTyCon con
2156 \end{code}
2157
2158 \begin{code}
2159 recordTyConInst :: Id
2160                 -> [Type]
2161                 -> SpecM (Maybe [Maybe Type])
2162
2163 recordTyConInst con tys
2164   = let
2165         spec_tys = specialiseConstrTys tys
2166
2167         do_tycon_spec = maybeToBool (firstJust spec_tys)
2168
2169         spec_exists = maybeToBool (lookupSpecEnv
2170                                       (getIdSpecialisation con)
2171                                       tys)
2172     in
2173     -- pprTrace "ConSpecExists?: "
2174     -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")),
2175     --            ppr PprShowAll con, hsep (map (ppr PprDebug) tys)])
2176     (if (not spec_exists && do_tycon_spec)
2177      then returnSM (Just spec_tys)
2178      else returnSM Nothing)
2179 \end{code}
2180
2181 %************************************************************************
2182 %*                                                                      *
2183 \subsection[monad-Specialise]{Monad used in specialisation}
2184 %*                                                                      *
2185 %************************************************************************
2186
2187 Monad has:
2188
2189  inherited: control flags and
2190             recordInst functions with flags cached
2191
2192             environment mapping tyvars to types
2193             environment mapping Ids to Atoms
2194
2195  threaded in and out: unique supply
2196
2197 \begin{code}
2198 type TypeEnv = TyVarEnv Type
2199
2200 type SpecM result
2201   =  TypeEnv
2202   -> SpecIdEnv
2203   -> UniqSupply
2204   -> result
2205
2206 initSM m uniqs = m nullTyVarEnv nullIdEnv uniqs
2207
2208 returnSM :: a -> SpecM a
2209 thenSM   :: SpecM a -> (a -> SpecM b) -> SpecM b
2210 fixSM    :: (a -> SpecM a) -> SpecM a
2211
2212 thenSM m k tvenv idenv us
2213   = case splitUniqSupply us        of { (s1, s2) ->
2214     case (m tvenv idenv s1) of { r ->
2215     k r tvenv idenv s2 }}
2216
2217 returnSM r tvenv idenv us = r
2218
2219 fixSM k tvenv idenv us
2220  = r
2221  where
2222    r = k r tvenv idenv us       -- Recursive in r!
2223 \end{code}
2224
2225 The only interesting bit is figuring out the type of the SpecId!
2226
2227 \begin{code}
2228 newSpecIds :: [Id]              -- The id of which to make a specialised version
2229            -> [Maybe Type]      -- Specialise to these types
2230            -> Int               -- No of dicts to specialise
2231            -> SpecM [Id]
2232
2233 newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
2234   = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2235     | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
2236   where
2237     uniqs = getUniques (length new_ids) us
2238     spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2239
2240 newTyVars :: Int -> SpecM [TyVar]
2241 newTyVars n tvenv idenv us
2242   = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
2243 \end{code}
2244
2245 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2246 binders, and build ``clones'' for them.  The clones differ from the
2247 originals in three ways:
2248
2249         (a) they have a fresh unique
2250         (b) they have the current type environment applied to their type
2251         (c) for Let binders which have been specialised to unboxed values
2252             the clone will have a lifted type
2253
2254 As well as returning the list of cloned @Id@s they also return a list of
2255 @CloneInfo@s which the original binders should be bound to.
2256
2257 \begin{code}
2258 cloneLambdaOrCaseBinders :: [Id]                        -- Old binders
2259                          -> SpecM ([Id], [CloneInfo])   -- New ones
2260
2261 cloneLambdaOrCaseBinders old_ids tvenv idenv us
2262   = let
2263         uniqs = getUniques (length old_ids) us
2264     in
2265     unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
2266   where
2267     clone_it old_id uniq
2268       = (new_id, NoLift (VarArg new_id))
2269       where
2270         new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2271
2272 cloneLetBinders :: Bool                         -- Top level ?
2273                 -> Bool                         -- Recursice
2274                 -> [Id]                         -- Old binders
2275                 -> SpecM ([Id], [CloneInfo])    -- New ones
2276
2277 cloneLetBinders top_lev is_rec old_ids tvenv idenv us
2278   = let
2279         uniqs = getUniques (2 * length old_ids) us
2280     in
2281     unzip (clone_them old_ids uniqs)
2282   where
2283     clone_them [] [] = []
2284
2285     clone_them (old_id:olds) (u1:u2:uniqs)
2286       | top_lev
2287         = (old_id,
2288            NoLift (VarArg old_id)) : clone_rest
2289
2290          -- Don't clone if it is a top-level thing. Why not?
2291          -- (a) we don't want to change the uniques
2292          --     on such things
2293          -- (b) we don't have to be paranoid about name capture
2294          -- (c) the thing is polymorphic so no need to subst
2295
2296       | otherwise
2297         = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
2298           then (lifted_id,
2299                 Lifted lifted_id unlifted_id) : clone_rest
2300           else (new_id,
2301                 NoLift (VarArg new_id)) : clone_rest
2302
2303       where
2304         clone_rest = clone_them olds uniqs
2305
2306         new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2307         new_ty = idType new_id
2308         old_ty = idType old_id
2309
2310         (lifted_id, unlifted_id) = mkLiftedId new_id u2
2311
2312
2313 cloneTyVarSM :: TyVar -> SpecM TyVar
2314
2315 cloneTyVarSM old_tyvar tvenv idenv us
2316   = let
2317         uniq = getUnique us
2318     in
2319     cloneTyVar old_tyvar uniq -- new_tyvar
2320
2321 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2322
2323 bindId id val specm tvenv idenv us
2324  = specm tvenv (addOneToIdEnv idenv id val) us
2325
2326 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2327
2328 bindIds olds news specm tvenv idenv us
2329  = specm tvenv (growIdEnvList idenv (zip olds news)) us
2330
2331 bindSpecIds :: [Id]                     -- Old
2332             -> [(CloneInfo)]            -- New
2333             -> [[Maybe SpecInfo]]       -- Corresponding specialisations
2334                                         -- Each sub-list corresponds to a different type,
2335                                         -- and contains one Maybe spec_info for each id
2336             -> SpecM thing
2337             -> SpecM thing
2338
2339 bindSpecIds olds clones spec_infos specm tvenv idenv us
2340  = specm tvenv (growIdEnvList idenv old_to_clone) us
2341  where
2342    old_to_clone = mk_old_to_clone olds clones spec_infos
2343
2344    -- The important thing here is that we are *lazy* in spec_infos
2345    mk_old_to_clone [] [] _ = []
2346    mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2347      = (old, add_spec_info clone) :
2348        mk_old_to_clone rest_olds rest_clones spec_infos_rest
2349      where
2350        add_spec_info (NoLift (VarArg new))
2351          = NoLift (VarArg (new `addIdSpecialisation`
2352                                   (mkSpecEnv spec_infos_this_id)))
2353        add_spec_info lifted
2354          = lifted               -- no specialised instances for unboxed lifted values
2355
2356        spec_infos_this_id = catMaybes (map head spec_infos)
2357        spec_infos_rest    = map tail spec_infos
2358
2359
2360 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2361
2362 bindTyVar tyvar ty specm tvenv idenv us
2363  = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2364 \end{code}
2365
2366 \begin{code}
2367 lookupId :: Id -> SpecM CloneInfo
2368
2369 lookupId id tvenv idenv us
2370   = case lookupIdEnv idenv id of
2371       Nothing   -> NoLift (VarArg id)
2372       Just info -> info
2373 \end{code}
2374
2375 \begin{code}
2376 specTy :: Type -> SpecM Type    -- Apply the current type envt to the type
2377
2378 specTy ty tvenv idenv us
2379   = applyTypeEnvToTy tvenv ty
2380 \end{code}
2381
2382 \begin{code}
2383 liftId :: Id -> SpecM (Id, Id)
2384 liftId id tvenv idenv us
2385   = let
2386         uniq = getUnique us
2387     in
2388     mkLiftedId id uniq
2389 \end{code}
2390
2391 In other monads these @mapSM@ things are usually called @listM@.
2392 I think @mapSM@ is a much better name.  The `2' and `3' variants are
2393 when you want to return two or three results, and get at them
2394 separately.  It saves you having to do an (unzip stuff) right after.
2395
2396 \begin{code}
2397 mapSM          :: (a -> SpecM b)            -> [a] -> SpecM [b]
2398 mapAndUnzipSM  :: (a -> SpecM (b1, b2))     -> [a] -> SpecM ([b1],[b2])
2399 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2400 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2401
2402 mapSM f [] = returnSM []
2403 mapSM f (x:xs) = f x            `thenSM` \ r ->
2404                  mapSM f xs     `thenSM` \ rs ->
2405                  returnSM (r:rs)
2406
2407 mapAndUnzipSM f [] = returnSM ([],[])
2408 mapAndUnzipSM f (x:xs) = f x                    `thenSM` \ (r1, r2) ->
2409                          mapAndUnzipSM f xs     `thenSM` \ (rs1,rs2) ->
2410                          returnSM ((r1:rs1),(r2:rs2))
2411
2412 mapAndUnzip3SM f [] = returnSM ([],[],[])
2413 mapAndUnzip3SM f (x:xs) = f x                   `thenSM` \ (r1,r2,r3) ->
2414                           mapAndUnzip3SM f xs   `thenSM` \ (rs1,rs2,rs3) ->
2415                           returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2416
2417 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2418 mapAndUnzip4SM f (x:xs) = f x                   `thenSM` \ (r1,r2,r3,r4) ->
2419                           mapAndUnzip4SM f xs   `thenSM` \ (rs1,rs2,rs3,rs4) ->
2420                           returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
2421 -}
2422 \end{code}
2423
2424
2425
2426 =====================   OLD CODE, scheduled for deletion  =================
2427
2428 \begin{code}
2429 {-
2430 mkCall :: Id
2431        -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2432        -> SpecM CoreExpr
2433
2434 mkCall new_id arg_infos = returnSM (
2435
2436   | maybeToBool (isSuperDictSelId_maybe new_id)
2437     && any isUnboxedType ty_args
2438         -- No specialisations for super-dict selectors
2439         -- Specialise unboxed calls to SuperDictSelIds by extracting
2440         -- the super class dictionary directly form the super class
2441         -- NB: This should be dead code since all uses of this dictionary should
2442         --     have been specialised. We only do this to keep core-lint happy.
2443     = let
2444          Just (_, super_class) = isSuperDictSelId_maybe new_id
2445          super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2446                          Nothing -> panic "Specialise:mkCall:SuperDictId"
2447                          Just id -> id
2448       in
2449       returnSM (False, Var super_dict_id)
2450
2451   | otherwise
2452     = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2453         Nothing -> checkUnspecOK new_id ty_args (
2454                    returnSM (False, unspec_call)
2455                    )
2456
2457         Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2458                 -> let
2459                         -- It may be necessary to specialsie a constant method spec_id again
2460                        (spec_id, tys_left, dicts_to_toss) =
2461                             case (maybeToBool (isConstMethodId_maybe spec_id_1),
2462                                   lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2463                                  (False, _ )     -> spec_1_details
2464                                  (True, Nothing) -> spec_1_details
2465                                  (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2466                                                  -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2467
2468                        args_left = toss_dicts dicts_to_toss val_args
2469                    in
2470                    checkSpecOK new_id ty_args spec_id tys_left (
2471
2472                         -- The resulting spec_id may be a top-level unboxed value
2473                         -- This can arise for:
2474                         -- 1) constant method values
2475                         --    eq: class Num a where pi :: a
2476                         --        instance Num Double# where pi = 3.141#
2477                         -- 2) specilised overloaded values
2478                         --    eq: i1 :: Num a => a
2479                         --        i1 Int# d.Num.Int# ==> i1.Int#
2480                         -- These top level defns should have been lifted.
2481                         -- We must add code to unlift such a spec_id.
2482
2483                    if isUnboxedType (idType spec_id) then
2484                        ASSERT (null tys_left && null args_left)
2485                        if toplevelishId spec_id then
2486                            liftId spec_id       `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2487                            returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2488                                                       (Var unlift_spec_id))
2489                        else
2490                            pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2491                                     (hsep [ppr PprDebug new_id,
2492                                             hsep (map (pprParendGenType PprDebug) ty_args),
2493                                             ptext SLIT("==>"),
2494                                             ppr PprDebug spec_id])
2495                    else
2496                    let
2497                        (vals_left, _, unlifts_left) = unzip3 args_left
2498                        applied_tys  = mkTyApp (Var spec_id) tys_left
2499                        applied_vals = mkGenApp applied_tys vals_left
2500                    in
2501                    returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2502                    )
2503   where
2504     (tys_and_vals, _, unlifts) = unzip3 args
2505     unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2506
2507
2508         -- ty_args is the types at the front of the arg list
2509         -- val_args is the rest of the arg-list
2510
2511     (ty_args, val_args) = get args
2512       where
2513         get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2514         get args                    = ([],       args)
2515
2516
2517         -- toss_dicts chucks away dict args, checking that they ain't types!
2518     toss_dicts 0 args               = args
2519     toss_dicts n ((a,_,_) : args)
2520       | isValArg a                  = toss_dicts (n-1) args
2521
2522 \end{code}
2523
2524 \begin{code}
2525 checkUnspecOK :: Id -> [Type] -> a -> a
2526 checkUnspecOK check_id tys
2527   = if isLocallyDefined check_id && any isUnboxedType tys
2528     then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2529                   (hsep [ppr PprDebug check_id,
2530                           hsep (map (pprParendGenType PprDebug) tys)])
2531     else id
2532
2533 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2534 checkSpecOK check_id tys spec_id tys_left
2535   = if any isUnboxedType tys_left
2536     then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2537                   (vcat [hsep [ppr PprDebug check_id,
2538                                     hsep (map (pprParendGenType PprDebug) tys)],
2539                              hsep [ppr PprDebug spec_id,
2540                                     hsep (map (pprParendGenType PprDebug) tys_left)]])
2541     else id
2542 -}
2543 \end{code}