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