ghc/compiler/specialise/Specialise.lhs

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