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 isCIofTheseIds :: [Id] -> CallInstance -> Bool
 674 isCIofTheseIds ids (CallInstance ci_id _ _ _ _) = any (eqId ci_id) ids
 675
 676 singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails
 677 singleCI id tys dicts
 678   = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
 679                  emptyBag [] emptyUniqSet
 680   where
 681     fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts])
 682
 683 explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails
 684 explicitCI id tys specinfo
 685   = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet
 686   where
 687     call_inst = CallInstance id tys dicts fv_set (Just specinfo)
 688     dicts  = panic "Specialise:explicitCI:dicts"
 689     fv_set = singletonUniqSet id
 690
 691 getCIs :: [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
 692 getCIs ids (UsageDetails cis tycon_cis dbs fvs)
 693   = let
 694         (cis_here, cis_not_here) = partitionBag (isCIofTheseIds ids) cis
 695         cis_here_list = bagToList cis_here
 696     in
 697     -- pprTrace "getCIs:"
 698     --     (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"])
 699     --           4 (ppAboves (map pprCI cis_here_list)))
 700     (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs)
 701
 702 dumpCIs :: Bag CallInstance     -- The call instances
 703         -> [Id]                 -- Bound ids *new*
 704         -> Bag CallInstance     -- Kept call instances
 705 dumpCIs cis bound_ids
 706  = (if not (isEmptyBag cis_dict_bound_arg) then
 707         (if isEmptyBag unboxed_cis_dict_bound_arg
 708          then (\ x y -> y) -- pprTrace "dumpCIs: bound dictionary arg ... \n"
 709          else pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n")
 710                   (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
 711                         4 (ppAboves (map pprCI (bagToList cis_dump))))
 712     else id)
 713    cis_keep
 714  where
 715    (cis_dump, cis_keep) = partitionBag mentions_bound_ids cis
 716
 717    mentions_bound_ids (CallInstance _ _ _ fv_set _)
 718         = or [i `elementOfUniqSet` fv_set | i <- bound_ids]
 719
 720    (cis_of_bound_id, cis_dict_bound_arg) = partitionBag (isCIofTheseIds bound_ids) cis_dump
 721    (unboxed_cis_dict_bound_arg, _)       = partitionBag isUnboxedCI cis_dict_bound_arg
 722
 723 \end{code}
 724
 725 Any call instances of a bound_id can be safely dumped, because any
 726 recursive calls should be at the same instance as the parent instance.
 727
 728    letrec f = /\a -> \x::a -> ...(f t x')...
 729
 730 Here, the type, t, at which f is used in its own RHS should be
 731 just "a"; that is, the recursive call is at the same type as
 732 the original call. That means that when specialising f at some
 733 type, say Int#, we shouldn't find any *new* instances of f
 734 arising from specialising f's RHS.  The only instance we'll find
 735 is another call of (f Int#).
 736
 737 ToDo: We should check this rather than just dumping them.
 738
 739 However, we do report any call instances which are mysteriously dumped
 740 because they have a dictionary argument which is bound here ...
 741
 742 ToDo: Under what circumstances does this occur, if at all?
 743
 744 %************************************************************************
 745 %*                                                                      *
 746 \subsubsection[TyConInstances]{@TyConInstances@ data type}
 747 %*                                                                      *
 748 %************************************************************************
 749
 750 \begin{code}
 751 data TyConInstance
 752   = TyConInstance TyCon                 -- Type Constructor
 753                   [Maybe UniType]       -- Applied to these specialising types
 754
 755 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
 756 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
 757   = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
 758
 759 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
 760 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
 761   = cmpUniTypeMaybeList tys1 tys2
 762
 763 singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails
 764 singleTyConI ty_con spec_tys
 765   = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet
 766
 767 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
 768 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con
 769
 770 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
 771 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
 772
 773 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
 774 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs)
 775   = let
 776         (tycon_cis_local, tycon_cis_global)
 777           = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
 778         tycon_cis_local_list = bagToList tycon_cis_local
 779     in
 780     (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs)
 781 \end{code}
 782
 783
 784 %************************************************************************
 785 %*                                                                      *
 786 \subsubsection[UsageDetails]{@UsageDetails@ data type}
 787 %*                                                                      *
 788 %************************************************************************
 789
 790 \begin{code}
 791 data UsageDetails
 792   = UsageDetails
 793         (Bag CallInstance)      -- The collection of call-instances
 794         (Bag TyConInstance)     -- Constructor call-instances
 795         [DictBindDetails]       -- Dictionary bindings in data-dependence order!
 796         FreeVarsSet             -- Free variables (excl imported ones, incl top level) (cloned)
 797 \end{code}
 798
 799 The DictBindDetails are fully processed; their call-instance information is
 800 incorporated in the call-instances of the
 801 UsageDetails which includes the DictBindDetails.  The free vars in a usage details
 802 will *include* the binders of the DictBind details.
 803
 804 A @DictBindDetails@ contains bindings for dictionaries *only*.
 805
 806 \begin{code}
 807 data DictBindDetails
 808   = DictBindDetails
 809         [Id]                    -- Main binders, originally visible in scope of binding (cloned)
 810         PlainCoreBinding        -- Fully processed
 811         FreeVarsSet             -- Free in binding group (cloned)
 812         FreeTyVarsSet           -- Free in binding group
 813 \end{code}
 814
 815 \begin{code}
 816 emptyUDs    :: UsageDetails
 817 unionUDs    :: UsageDetails -> UsageDetails -> UsageDetails
 818 unionUDList :: [UsageDetails] -> UsageDetails
 819
 820 emptyUDs      = UsageDetails emptyBag emptyBag [] emptyUniqSet
 821
 822 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2)
 823  = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
 824                 (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2)
 825         -- The append here is really redundant, since the bindings don't
 826         -- scope over each other.  ToDo.
 827
 828 unionUDList = foldr unionUDs emptyUDs
 829
 830 singleFvUDs (CoVarAtom v) | not (isImportedId v)
 831  = UsageDetails emptyBag emptyBag [] (singletonUniqSet v)
 832 singleFvUDs other
 833  = emptyUDs
 834
 835 singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con)
 836
 837 dumpDBs :: [DictBindDetails]
 838         -> [TyVar]              -- TyVars being bound (cloned)
 839         -> [Id]                 -- Ids being bound (cloned)
 840         -> FreeVarsSet          -- Fvs of body
 841         -> ([PlainCoreBinding], -- These ones have to go here
 842             [DictBindDetails],  -- These can float further
 843             [Id],               -- Incoming list + names of dicts bound here
 844             FreeVarsSet         -- Incominf fvs + fvs of dicts bound here
 845            )
 846 dumpDBs [] bound_tyvars bound_ids fvs = ([], [], bound_ids, fvs)
 847
 848 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
 849         bound_tyvars bound_ids fvs
 850   | or [i `elementOfUniqSet` db_fvs  | i <- bound_ids]
 851     ||
 852     or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars]
 853   = let         -- Ha!  Dump it!
 854         (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
 855            = dumpDBs dbs bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs)
 856     in
 857     (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
 858
 859   | otherwise   -- This one can float out further
 860   = let
 861         (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
 862            = dumpDBs dbs bound_tyvars bound_ids fvs
 863     in
 864     (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
 865
 866
 867
 868 dumpUDs :: UsageDetails
 869         -> [Id]                 -- Ids which are just being bound; *new*
 870         -> [TyVar]              -- TyVars which are just being bound
 871         -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids
 872             UsageDetails)       -- The above bindings removed, and
 873                                 -- any call-instances which mention the ids dumped too
 874
 875 dumpUDs (UsageDetails cis tycon_cis dbs fvs) bound_ids tvs
 876   = let
 877         (dict_binds_here, dbs_outer, full_bound_ids, full_fvs) = dumpDBs dbs tvs bound_ids fvs
 878         cis_outer = dumpCIs cis full_bound_ids
 879         fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids)
 880     in
 881     (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer)
 882 \end{code}
 883
 884 \begin{code}
 885 addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails        -- Dict binding and RHS usage
 886              -> UsageDetails                                    -- The usage to augment
 887              -> UsageDetails
 888 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs)
 889                             (UsageDetails cis    tycon_cis    dbs    fvs)
 890   = UsageDetails (db_cis `unionBags` cis)
 891                  (db_tycon_cis `unionBags` tycon_cis)
 892                  (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
 893                  fvs
 894   where
 895         -- The free tyvars of the dictionary bindings should really be
 896         -- gotten from the RHSs, but I'm pretty sure it's good enough just
 897         -- to look at the type of the dictionary itself.
 898         -- Doing the proper job would entail keeping track of free tyvars as
 899         -- well as free vars, which would be a bore.
 900     db_ftvs = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders))
 901 \end{code}
 902
 903 %************************************************************************
 904 %*                                                                      *
 905 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
 910
 911 1) (NoLift CoLitAtom l) : an Id which is bound to a literal
 912
 913 2) (NoLift CoLitAtom l) : an Id bound to a "new" Id
 914    The new Id is a possibly-type-specialised clone of the original
 915
 916 3) Lifted lifted_id unlifted_id :
 917
 918    This indicates that the original Id has been specialised to an
 919    unboxed value which must be lifted (see "Unboxed bindings" above)
 920      @unlifted_id@ is the unboxed clone of the original Id
 921      @lifted_id@ is a *lifted* version of the original Id
 922
 923    When you lookup Ids which are Lifted, you have to insert a case
 924    expression to un-lift the value (done with @bindUnlift@)
 925
 926    You also have to insert a case to lift the value in the binding
 927    (done with @liftExpr@)
 928
 929
 930 \begin{code}
 931 type SpecIdEnv = IdEnv CloneInfo
 932
 933 data CloneInfo
 934  = NoLift PlainCoreAtom -- refers to cloned id or literal
 935
 936  | Lifted Id            -- lifted, cloned id
 937           Id            -- unlifted, cloned id
 938
 939 \end{code}
 940
 941 %************************************************************************
 942 %*                                                                      *
 943 \subsection[specialise-data]{Data returned by specialiser}
 944 %*                                                                      *
 945 %************************************************************************
 946
 947 \begin{code}
 948 data SpecialiseData
 949  = SpecData Bool
 950                 -- True <=> Specialisation performed
 951             Bool
 952                 -- False <=> Specialisation completed with errors
 953
 954             [TyCon]
 955                 -- Local tycons declared in this module
 956
 957             [TyCon]
 958                 -- Those in-scope data types for which we want to
 959                 -- generate code for their constructors.
 960                 -- Namely: data types declared in this module +
 961                 --         any big tuples used in this module
 962                 -- The initial (and default) value is the local tycons
 963
 964             (FiniteMap TyCon [[Maybe UniType]])
 965                 -- TyCon specialisations to be generated
 966                 -- We generate specialisations for data types defined
 967                 -- in this module and any tuples used in this module
 968                 -- The initial (and default) value is the specialisations
 969                 -- requested by source-level SPECIALIZE data pragmas
 970                 -- and _SPECIALISE_ pragmas in the interface files
 971
 972             (Bag (Id,[Maybe UniType]))
 973                 -- Imported specialisation errors
 974             (Bag (Id,[Maybe UniType]))
 975                 -- Imported specialisation warnings
 976             (Bag (TyCon,[Maybe UniType]))
 977                 -- Imported TyCon specialisation errors
 978
 979 initSpecData local_tycons tycon_specs
 980  = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
 981 \end{code}
 982
 983 ToDo[sansom]: Transformation data to process specialisation requests.
 984
 985 %************************************************************************
 986 %*                                                                      *
 987 \subsection[specProgram]{Specialising a core program}
 988 %*                                                                      *
 989 %************************************************************************
 990
 991 \begin{code}
 992 specProgram :: (GlobalSwitch -> Bool)
 993             -> SplitUniqSupply
 994             -> [PlainCoreBinding]       -- input ...
 995             -> SpecialiseData
 996             -> ([PlainCoreBinding],     -- main result
 997                 SpecialiseData)         -- result specialise data
 998
 999 specProgram sw_chker uniqs binds
1000            (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1001   = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of
1002       (final_binds, tycon_specs_list,
1003         UsageDetails import_cis import_tycis _ fvs)
1004          -> let
1005                 used_conids   = filter isDataCon (uniqSetToList fvs)
1006                 used_tycons   = map getDataConTyCon used_conids
1007                 used_gen      = filter isLocalGenTyCon used_tycons
1008                 gen_tycons    = setToList (mkSet local_tycons `union` mkSet used_gen)
1009
1010                 result_specs  = addListToFM_C (++) init_specs tycon_specs_list
1011
1012                 uniq_cis      = map head (equivClasses cmpCI (bagToList import_cis))
1013                 cis_list      = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1014                 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1015                 cis_warn      = init_warn `unionBags` listToBag cis_other
1016                 cis_errs      = init_errs `unionBags` listToBag cis_unboxed
1017
1018                 uniq_tycis    = map head (equivClasses cmpTyConI (bagToList import_tycis))
1019                 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1020                 tycis_errs    = init_tyerrs `unionBags` listToBag tycis_unboxed
1021
1022                 no_errs       = isEmptyBag cis_errs && isEmptyBag tycis_errs
1023                                   && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn)
1024             in
1025             (final_binds,
1026              SpecData True no_errs local_tycons gen_tycons result_specs
1027                                    cis_errs cis_warn tycis_errs)
1028
1029 specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _)
1030   = panic "Specialise:specProgram: specialiser called more than once"
1031
1032 -- It may be possible safely to call the specialiser more than once,
1033 -- but I am not sure there is any benefit in doing so (Patrick)
1034
1035 -- ToDo: What about unfoldings performed after specialisation ???
1036 \end{code}
1037
1038 %************************************************************************
1039 %*                                                                      *
1040 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1041 %*                                                                      *
1042 %************************************************************************
1043
1044 In the specialiser we just collect up the specialisations which will
1045 be required. We don't create the specialised constructors in
1046 Core. These are only introduced when we convert to StgSyn.
1047
1048 ToDo: Perhaps this should be done in CoreToStg to ensure no inconsistencies!
1049
1050 \begin{code}
1051 specTyConsAndScope :: SpecM ([PlainCoreBinding], UsageDetails)
1052                    -> SpecM ([PlainCoreBinding], [(TyCon,[[Maybe UniType]])], UsageDetails)
1053
1054 specTyConsAndScope scopeM
1055   = scopeM                      `thenSM` \ (binds, scope_uds) ->
1056     getSwitchCheckerSM          `thenSM` \ sw_chkr ->
1057     let
1058        (tycons_cis, gotci_scope_uds)
1059          = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
1060
1061        tycon_specs_list = collectTyConSpecs tycons_cis
1062     in
1063     (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then
1064          pprTrace "Specialising TyCons:\n"
1065                   (ppAboves [ if not (null specs) then
1066                                   ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
1067                                        4 (ppAboves (map pp_specs specs))
1068                               else ppNil
1069                             | (tycon, specs) <- tycon_specs_list])
1070     else id) (
1071     returnSM (binds, tycon_specs_list, gotci_scope_uds)
1072     )
1073   where
1074     collectTyConSpecs []
1075       = []
1076     collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1077       = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1078       where
1079         (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1080         uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1081         tycon_specs = [spec_tys | TyConInstance _ spec_tys <- uniq_cis]
1082
1083     pp_specs specs = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- specs]
1084
1085
1086 {- UNUSED: create specialised constructors in Core
1087
1088 NB: this code may have some bitrot (Andy & Will 95/06)
1089
1090 specTyConsAndScope spec_tycons scopeM
1091   = fixSM (\ ~(_, _, _, rec_spec_infos) ->
1092       bindConIds cons_tospec rec_spec_infos (
1093         scopeM                  `thenSM` \ (binds, scope_uds) ->
1094         let
1095            (tycons_cis, gotci_scope_uds)
1096              = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
1097         in
1098         mapAndUnzipSM (inst_tycon tycons_cis) spec_tycons
1099                                 `thenSM` \ (tycon_specs_list, spec_infoss) ->
1100         returnSM (binds, tycon_specs_list, gotci_scope_uds, concat spec_infoss)
1101       )
1102
1103     ) `thenSM` \ (binds, tycon_specs_list, final_uds, spec_infos) ->
1104     returnSM (binds, tycon_specs_list, final_uds)
1105
1106   where
1107     conss_tospec  = map getTyConDataCons spec_tycons
1108     cons_tospec   = concat conss_tospec
1109
1110     inst_tycon tycons_cis tycon
1111       = mapSM mk_con_specs (getTyConDataCons tycon) `thenSM` \ spec_infos ->
1112         getSwitchCheckerSM                          `thenSM` \ sw_chkr ->
1113         (if sw_chkr SpecialiseTrace && not (null tycon_cis) then
1114          pprTrace "Specialising:"
1115                   (ppHang (ppCat [ppr PprDebug tycon, ppStr "at types"])
1116                         4 (ppAboves (map pp_inst uniq_cis)))
1117         else id) (
1118         returnSM ((tycon, tycon_specs), spec_infos)
1119         )
1120       where
1121         tycon_cis = filter (isTyConIofThisTyCon tycon) tycons_cis
1122         uniq_cis  = map head (equivClasses cmpTyConI_tys tycon_cis)
1123
1124         tycon_specs = [spec_tys | TyConInstance _ spec_tys <- uniq_cis]
1125
1126         mk_con_specs con_id
1127           = mapSM (mk_con_spec con_id) uniq_cis
1128         mk_con_spec con_id (TyConInstance _ spec_tys)
1129           = newSpecIds [con_id] spec_tys 0 copy_arity_info_and `thenSM` \ [spec_id] ->
1130             returnSM (SpecInfo spec_tys 0 spec_id)
1131
1132         copy_arity_info old new = addIdArity new (getDataConArity old)
1133
1134         pp_inst (TyConInstance _ spec_tys)
1135           = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- spec_tys]
1136 -}
1137 \end{code}
1138
1139 %************************************************************************
1140 %*                                                                      *
1141 \subsection[specTopBinds]{Specialising top-level bindings}
1142 %*                                                                      *
1143 %************************************************************************
1144
1145 \begin{code}
1146 specTopBinds :: [PlainCoreBinding]
1147              -> SpecM ([PlainCoreBinding], UsageDetails)
1148
1149 specTopBinds binds
1150   = spec_top_binds binds    `thenSM`  \ (binds, UsageDetails cis tycis dbind_details fvs) ->
1151     let
1152         -- Add bindings for floated dbinds and collect fvs
1153         -- In actual fact many of these bindings are dead code since dict
1154         -- arguments are dropped when a specialised call is created
1155         -- The simplifier should be able to cope ...
1156
1157         (dbinders_s, dbinds, dfvs_s)
1158            = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1159
1160         full_fvs  = fvs `unionUniqSets` unionManyUniqSets dfvs_s
1161         fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s))
1162     in
1163     returnSM (dbinds ++ binds, UsageDetails cis tycis [] fvs_outer)
1164
1165   where
1166     spec_top_binds (first_bind:rest_binds)
1167       = specBindAndScope True {- top level -} first_bind (
1168             spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1169             returnSM (ItsABinds rest_binds, rest_uds)
1170         )                       `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1171         returnSM (first_binds ++ rest_binds, all_uds)
1172
1173     spec_top_binds []
1174       = returnSM ([], emptyUDs)
1175 \end{code}
1176
1177 %************************************************************************
1178 %*                                                                      *
1179 \subsection[specExpr]{Specialising expressions}
1180 %*                                                                      *
1181 %************************************************************************
1182
1183 \begin{code}
1184 specExpr :: PlainCoreExpr
1185          -> [PlainCoreArg]              -- The arguments:
1186                                         --    TypeArgs are speced
1187                                         --    ValArgs are unprocessed
1188          -> SpecM (PlainCoreExpr,       -- Result expression with specialised versions installed
1189                    UsageDetails)        -- Details of usage of enclosing binders in the result
1190                                         -- expression.
1191
1192 specExpr (CoVar v) args
1193   = lookupId v                  `thenSM` \ vlookup ->
1194     case vlookup of
1195        Lifted vl vu
1196              -> -- Binding has been lifted, need to extract un-lifted value
1197                 -- NB: a function binding will never be lifted => args always null
1198                 --     i.e. no call instance required or call to be constructed
1199                 ASSERT (null args)
1200                 returnSM (bindUnlift vl vu (CoVar vu), singleFvUDs (CoVarAtom vl))
1201
1202        NoLift vatom@(CoVarAtom new_v)
1203              -> mapSM specArg args              `thenSM` \ arg_info ->
1204                 mkCallInstance v new_v arg_info `thenSM` \ uds ->
1205                 mkCall new_v arg_info           `thenSM` \ call ->
1206                 returnSM (call, uds)
1207
1208 specExpr expr@(CoLit _) null_args
1209   = ASSERT (null null_args)
1210     returnSM (expr, emptyUDs)
1211
1212 specExpr (CoCon con tys args) null_args
1213   = ASSERT (null null_args)
1214     mapSM specTy tys                    `thenSM` \ tys ->
1215     mapAndUnzip3SM specAtom args        `thenSM` \ (args, args_uds_s, unlifts) ->
1216     mkTyConInstance con tys             `thenSM` \ con_uds ->
1217     returnSM (applyBindUnlifts unlifts (CoCon con tys args),
1218               unionUDList args_uds_s `unionUDs` con_uds)
1219
1220 {- UNUSED: create specialised constructors in CoCon
1221 specExpr (CoCon con tys args) null_args
1222   = ASSERT (null null_args)
1223     mapSM specTy tys            `thenSM` \ tys ->
1224     mapAndUnzipSM specAtom args `thenSM` \ (args, args_uds_s) ->
1225     mkTyConInstance con tys     `thenSM` \ con_con ->
1226     lookupId con                `thenSM` \ con ->
1227     mkConstrCall con tys        `thenSM` \ ~(spec_con, spec_tys) ->
1228     returnSM (CoCon spec_con spec_tys args,
1229               unionUDList args_uds_s `unionUDs` con_uds)
1230 -}
1231
1232 specExpr (CoPrim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
1233   = ASSERT (null null_args)
1234     ASSERT (null tys)
1235     mapSM specTy arg_tys                `thenSM` \ arg_tys ->
1236     specTy res_ty                       `thenSM` \ res_ty ->
1237     mapAndUnzip3SM specAtom args        `thenSM` \ (args, args_uds_s, unlifts) ->
1238     returnSM (applyBindUnlifts unlifts (CoPrim (CCallOp str is_asm may_gc arg_tys res_ty) tys args),
1239               unionUDList args_uds_s)
1240
1241 specExpr (CoPrim prim tys args) null_args
1242   = ASSERT (null null_args)
1243     mapSM specTy tys                    `thenSM` \ tys ->
1244     mapAndUnzip3SM specAtom args        `thenSM` \ (args, args_uds_s, unlifts) ->
1245     -- specPrimOp prim tys              `thenSM` \ (prim, tys, prim_uds) ->
1246     returnSM (applyBindUnlifts unlifts (CoPrim prim tys args),
1247               unionUDList args_uds_s {-`unionUDs` prim_uds-} )
1248
1249 {- ToDo: specPrimOp
1250
1251 specPrimOp :: PrimOp
1252            -> [UniType]
1253            -> SpecM (PrimOp,
1254                      [UniType],
1255                      UsageDetails)
1256
1257 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1258 --   and/or chooses PrimOp specialised to any unboxed tys
1259 -- Errors are dealt with by returning a PrimOp call instance
1260 --   which will result in a cis_errs message
1261
1262 -- ToDo: Deal with checkSpecTyApp for CoPrim in CoreLint
1263 -}
1264
1265
1266 specExpr (CoApp fun arg) args
1267   =     -- Arg is passed on unprocessed
1268     specExpr fun (ValArg arg : args)    `thenSM` \ (expr,uds) ->
1269     returnSM (expr, uds)
1270
1271 specExpr (CoTyApp fun ty) args
1272   =     -- Spec the tyarg and pass it on
1273     specTy ty                           `thenSM` \ ty ->
1274     specExpr fun (TypeArg ty : args)
1275
1276 specExpr (CoLam bound_ids body) args
1277   = specLam bound_ids body args
1278
1279 specExpr (CoTyLam tyvar body) (TypeArg ty : args)
1280   =     -- Type lambda with argument; argument already spec'd
1281     bindTyVar tyvar ty (
1282         specExpr body args
1283     )
1284
1285 specExpr (CoTyLam tyvar body) []
1286   =     -- No arguments
1287     cloneTyVarSM tyvar          `thenSM` \ new_tyvar ->
1288     bindTyVar tyvar (mkTyVarTy new_tyvar) (
1289         specExpr body []        `thenSM` \ (body, body_uds) ->
1290         let
1291             (binds_here, final_uds) = dumpUDs body_uds [] [new_tyvar]
1292         in
1293         returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds)
1294     )
1295
1296 specExpr (CoCase scrutinee alts) args
1297   = specExpr scrutinee []               `thenSM` \ (scrutinee, scrut_uds) ->
1298     specAlts alts scrutinee_type args   `thenSM` \ (alts, alts_uds) ->
1299     returnSM (CoCase scrutinee alts, scrut_uds `unionUDs`  alts_uds)
1300   where
1301     scrutinee_type = typeOfCoreExpr scrutinee
1302
1303
1304 specExpr (CoLet bind body) args
1305   = specBindAndScope False {- not top level -} bind (
1306         specExpr body args      `thenSM` \ (body, body_uds) ->
1307         returnSM (ItsAnExpr body, body_uds)
1308     )                           `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1309     returnSM (mkCoLetsNoUnboxed binds body, all_uds)
1310
1311 specExpr (CoSCC cc expr) args
1312   = specExpr expr []            `thenSM` \ (expr, expr_uds) ->
1313     mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1314     let
1315         scc_expr
1316           = if squashableDictishCcExpr cc expr -- can toss the _scc_
1317             then expr
1318             else CoSCC cc expr
1319     in
1320     returnSM (applyBindUnlifts unlifts (applyToArgs scc_expr args),
1321               unionUDList args_uds_s `unionUDs` expr_uds)
1322
1323 -- ToDo:DPH: add stuff here!
1324 \end{code}
1325
1326 %************************************************************************
1327 %*                                                                      *
1328 \subsubsection{Specialising a lambda}
1329 %*                                                                      *
1330 %************************************************************************
1331
1332 \begin{code}
1333 specLam :: [Id] -> PlainCoreExpr -> [PlainCoreArg]
1334         -> SpecM (PlainCoreExpr, UsageDetails)
1335
1336 specLam [] body args
1337   =     -- All lambdas saturated
1338     specExpr body args
1339
1340 specLam (binder:binders) body (ValArg arg : args)
1341   =     -- Lambda with an unprocessed argument
1342     lookup_arg arg                              `thenSM` \ arg ->
1343     bindId binder arg (
1344         specLam binders body args
1345     )
1346   where
1347     lookup_arg (CoLitAtom l) = returnSM (NoLift (CoLitAtom l))
1348     lookup_arg (CoVarAtom v) = lookupId v
1349
1350 specLam bound_ids body []
1351   =     -- Lambda with no arguments
1352     specLambdaOrCaseBody bound_ids body []      `thenSM` \ (bound_ids, body, uds) ->
1353     returnSM (CoLam bound_ids body, uds)
1354 \end{code}
1355
1356 \begin{code}
1357 specLambdaOrCaseBody :: [Id]                    -- The binders
1358                      -> PlainCoreExpr           -- The body
1359                      -> [PlainCoreArg]          -- Its args
1360                      -> SpecM ([Id],            -- New binders
1361                                PlainCoreExpr,   -- New body
1362                                UsageDetails)
1363
1364 specLambdaOrCaseBody bound_ids body args
1365  = cloneLambdaOrCaseBinders bound_ids   `thenSM` \ (new_ids, clone_infos) ->
1366    bindIds bound_ids clone_infos (
1367
1368         specExpr body args      `thenSM` \ (body, body_uds) ->
1369
1370         let
1371             -- Dump any dictionary bindings (and call instances)
1372             -- from the scope which mention things bound here
1373             (binds_here, final_uds) = dumpUDs body_uds new_ids []
1374         in
1375         returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1376    )
1377
1378 -- ToDo: Opportunity here to common-up dictionaries with same type,
1379 -- thus avoiding recomputation.
1380 \end{code}
1381
1382 A variable bound in a lambda or case is normally monomorphic so no
1383 specialised versions will be required. This is just as well since we
1384 do not know what code to specialise!
1385
1386 Unfortunately this is not always the case. For example a class Foo
1387 with polymorphic methods gives rise to a dictionary with polymorphic
1388 components as follows:
1389
1390 \begin{verbatim}
1391 class Foo a where
1392   op1 :: a -> b -> a
1393   op2 :: a -> c -> a
1394
1395 instance Foo Int where
1396   op1 = op1Int
1397   op2 = op2Int
1398
1399 ... op1 1 3# ...
1400
1401 ==>
1402
1403 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1404 d.Foo.Int = (op1_Int, op2_Int)
1405
1406 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1407
1408 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1409 \end{verbatim}
1410
1411 N.B. The type of the dictionary is not Hindley Milner!
1412
1413 Now we must specialise op1 at {* Int#} which requires a version of
1414 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1415 not have access to its code to create the specialised version.
1416
1417
1418 If we specialise on overloaded types as well we specialise op1 at
1419 {Int Int#} d.Foo.Int:
1420
1421 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1422
1423 Though this is still invalid, after further simplification we get:
1424
1425 op1_Int_Int# = opInt1 {Int#}
1426
1427 Another round of specialisation will result in the specialised
1428 version of op1Int being called directly.
1429
1430 For now we PANIC if a polymorphic lambda/case bound variable is found
1431 in a call instance with an unboxed type. Other call instances, arising
1432 from overloaded type arguments, are discarded since the unspecialised
1433 version extracted from the method can be called as normal.
1434
1435 ToDo: Implement and test second round of specialisation.
1436
1437
1438 %************************************************************************
1439 %*                                                                      *
1440 \subsubsection{Specialising case alternatives}
1441 %*                                                                      *
1442 %************************************************************************
1443
1444
1445 \begin{code}
1446 specAlts (CoAlgAlts alts deflt) scrutinee_ty args
1447   = mapSM specTy ty_args                        `thenSM` \ ty_args ->
1448     mapAndUnzipSM (specAlgAlt ty_args) alts     `thenSM` \ (alts, alts_uds_s) ->
1449     specDeflt deflt args                        `thenSM` \ (deflt, deflt_uds) ->
1450     returnSM (CoAlgAlts alts deflt,
1451               unionUDList alts_uds_s `unionUDs` deflt_uds)
1452
1453   where
1454     -- We use ty_args of scrutinee type to identify specialisation of alternatives
1455     (_, ty_args, _) = getUniDataTyCon scrutinee_ty
1456
1457     specAlgAlt ty_args (con,binders,rhs)
1458       = specLambdaOrCaseBody binders rhs args   `thenSM` \ (binders, rhs, rhs_uds) ->
1459         mkTyConInstance con ty_args             `thenSM` \ con_uds ->
1460         returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1461
1462 {- UNUSED: creating specialised constructors in case alts
1463     specAlgAlt ty_args (con,binders,rhs)
1464       = specLambdaOrCaseBody binders rhs args   `thenSM` \ (binders, rhs, rhs_uds) ->
1465         mkTyConInstance con ty_args             `thenSM` \ con_uds ->
1466         lookupId con                            `thenSM` \ con ->
1467         mkConstrCall con ty_args                `thenSM` \ ~(spec_con, _) ->
1468         returnSM ((spec_con,binders,rhs), rhs_uds `unionUDs` con_uds)
1469 -}
1470
1471 specAlts (CoPrimAlts alts deflt) scrutinee_ty args
1472   = mapAndUnzipSM specPrimAlt alts      `thenSM` \ (alts, alts_uds_s) ->
1473     specDeflt deflt args                `thenSM` \ (deflt, deflt_uds) ->
1474     returnSM (CoPrimAlts alts deflt,
1475               unionUDList alts_uds_s `unionUDs` deflt_uds)
1476   where
1477     specPrimAlt (lit,rhs) = specExpr rhs args   `thenSM` \ (rhs, uds) ->
1478                             returnSM ((lit,rhs), uds)
1479
1480
1481 specDeflt CoNoDefault args = returnSM (CoNoDefault, emptyUDs)
1482 specDeflt (CoBindDefault binder rhs) args
1483  = specLambdaOrCaseBody [binder] rhs args       `thenSM` \ ([binder], rhs, uds) ->
1484    returnSM (CoBindDefault binder rhs, uds)
1485 \end{code}
1486
1487
1488 %************************************************************************
1489 %*                                                                      *
1490 \subsubsection{Specialising an atom}
1491 %*                                                                      *
1492 %************************************************************************
1493
1494 \begin{code}
1495 specAtom :: PlainCoreAtom -> SpecM (PlainCoreAtom, UsageDetails,
1496                                     PlainCoreExpr -> PlainCoreExpr)
1497
1498 specAtom (CoLitAtom lit)
1499   = returnSM (CoLitAtom lit, emptyUDs, id)
1500
1501 specAtom (CoVarAtom v)
1502   = lookupId v          `thenSM` \ vlookup ->
1503     case vlookup of
1504       Lifted vl vu
1505          -> returnSM (CoVarAtom vu, singleFvUDs (CoVarAtom vl), bindUnlift vl vu)
1506
1507       NoLift vatom
1508          -> returnSM (vatom, singleFvUDs vatom, id)
1509
1510
1511 specArg :: PlainCoreArg -> SpecM (PlainCoreArg, UsageDetails,
1512                                   PlainCoreExpr -> PlainCoreExpr)
1513
1514 specArg (ValArg arg)    -- unprocessed; spec the atom
1515   = specAtom arg        `thenSM` \ (arg, uds, unlift) ->
1516     returnSM (ValArg arg, uds, unlift)
1517
1518 specArg (TypeArg ty)    -- already speced; no action
1519   = returnSM (TypeArg ty, emptyUDs, id)
1520 \end{code}
1521
1522
1523 %************************************************************************
1524 %*                                                                      *
1525 \subsubsection{Specialising bindings}
1526 %*                                                                      *
1527 %************************************************************************
1528
1529 A classic case of when having a polymorphic recursive function would help!
1530
1531 \begin{code}
1532 data BindsOrExpr = ItsABinds [PlainCoreBinding]
1533                  | ItsAnExpr PlainCoreExpr
1534 \end{code}
1535
1536 \begin{code}
1537 specBindAndScope
1538         :: Bool                                 -- True <=> a top level group
1539         -> PlainCoreBinding                     -- As yet unprocessed
1540         -> SpecM (BindsOrExpr, UsageDetails)    -- Something to do the scope of the bindings
1541         -> SpecM ([PlainCoreBinding],           -- Processed
1542                   BindsOrExpr,                  -- Combined result
1543                   UsageDetails)                 -- Usage details of the whole lot
1544
1545 specBindAndScope is_top_level_group bind scopeM
1546   = cloneLetrecBinders binders  `thenSM`        \ (new_binders, clone_infos) ->
1547
1548         -- Two cases now: either this is a bunch of dictionaries, in
1549         -- which case we float them; or its a bunch of other values,
1550         -- in which case we see if they correspond to any
1551         -- call-instances we have in hand.
1552
1553     if all (\id -> isDictTy (getIdUniType id) || isConstMethodId id) binders then
1554         -- Ha! A group of dictionary bindings, or constant methods.
1555         -- The reason for the latter is interesting.  Consider
1556         --
1557         --      dfun.Eq.Foo = /\a \ d -> ...
1558         --
1559         --      constmeth1 = ...
1560         --      constmeth2 = ...
1561         --      dict = (constmeth1,constmeth2)
1562         --
1563         --      ...(dfun.Eq.Foo dict)...
1564         --
1565         -- Now, the defn of dict can't float above the constant-method
1566         -- decls, so the call-instance for dfun.Eq.Foo will be dropped.
1567         --
1568         -- Solution: float the constant methods in the same way as dictionaries
1569         --
1570         -- The other interesting bit is the test for dictionary-hood.
1571         -- Constant dictionaries, like dict above, are sometimes built
1572         -- as zero-arity dfuns, so isDictId alone won't work.
1573
1574       bindIds binders clone_infos (
1575
1576                 -- Process the dictionary bindings themselves
1577         specBind new_binders bind       `thenSM` \ (bind, rhs_uds) ->
1578
1579                 -- Process their scope
1580         scopeM                          `thenSM` \ (thing, scope_uds) ->
1581         let
1582                 -- Add the bindings to the current stuff
1583             final_uds = addDictBinds new_binders bind rhs_uds scope_uds
1584         in
1585         returnSM ([], thing, final_uds)
1586       )
1587     else
1588         -- Ho! A group of ordinary (non-dict) bindings
1589       fixSM (\ ~(_, _, _, rec_spec_infos) ->
1590
1591         bindSpecIds binders clone_infos rec_spec_infos (
1592                 -- It's ok to have new binders in scope in
1593                 -- non-recursive decls too, cos name shadowing is gone by now
1594
1595                 -- Do the scope of the bindings
1596           scopeM                                `thenSM` \ (thing, scope_uds) ->
1597           let
1598              (call_insts_these_binders, gotci_scope_uds) = getCIs new_binders scope_uds
1599           in
1600
1601                 -- Do the bindings themselves
1602           specBind new_binders bind             `thenSM` \ (spec_bind, spec_uds) ->
1603
1604                 -- Create any necessary instances
1605           instBind new_binders bind call_insts_these_binders
1606                                                 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
1607
1608           let
1609                 -- Dump any dictionary bindings from the scope
1610                 -- which mention things bound here
1611                 (dict_binds, final_scope_uds) = dumpUDs gotci_scope_uds new_binders []
1612                         -- The spec_ids can't appear anywhere in uds, because they only
1613                         -- appear in SpecInfos.
1614
1615                 -- Build final binding group
1616                 -- see note below about dependecies
1617                 final_binds = [spec_bind,
1618                                CoRec (pairsFromCoreBinds (inst_binds ++ dict_binds))
1619                               ]
1620
1621           in
1622                 -- Combine the results together
1623           returnSM (final_binds,
1624                     thing,
1625                     spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds,
1626                         -- inst_uds comes last, because there may be dict bindings
1627                         -- floating outward in final_scope_uds which are mentioned
1628                         -- in the call-instances, and hence in spec_uds.
1629                         -- This ordering makes sure that the precedence order
1630                         -- among the dict bindings finally floated out is maintained.
1631                     spec_infos)
1632         )
1633       )                 `thenSM`        \ (binds, thing, final_uds, spec_infos) ->
1634       returnSM (binds, thing, final_uds)
1635   where
1636     binders = bindersOf bind
1637 \end{code}
1638
1639 We place the spec_binds and dict_binds in a CoRec as there may be some
1640 nasty dependencies. These don't actually require a CoRec, but its the
1641 simplest solution. (The alternative would require some tricky dependency
1642 analysis.) We leave it to the real dependency analyser to sort it all
1643 out during a subsequent simplification pass.
1644
1645 Where do these dependencies arise?  Consider this case:
1646
1647         data Foo a = ...
1648
1649         {- instance Eq a => Eq (Foo a) where ... -}
1650         dfun.Eq.(Foo *) d.eq.a = <wurble>
1651
1652         d2 = dfun.Eq.(Foo *) Char# d.Eq.Char#
1653         d1 = dfun.Eq.(Foo *) (Foo Char#) d2
1654
1655 Now, when specialising we must write the Char# instance of dfun.Eq.(Foo *) before
1656 that for the (Foo Char#) instance:
1657
1658         dfun.Eq.(Foo *) d.eq.a = <wurble>
1659
1660         dfun.Eq.(Foo *)@Char# = <wurble>[d.Eq.Char#/d.eq.a]
1661         d2 = dfun.Eq.(Foo *)@Char#
1662
1663         dfun.Eq.(Foo *)@(Foo Char#) = <wurble>[d2/d.eq.a]
1664         d1 = dfun.Eq.(Foo *)@(Foo Char#)
1665
1666 The definition of dfun.Eq.(Foo *)@(Foo Char#) uses d2!!!  So it must
1667 come after the definition of dfun.Eq.(Foo *)@Char#.
1668 AAARGH!
1669
1670
1671
1672 \begin{code}
1673 specBind :: [Id] -> PlainCoreBinding -> 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 new_binders (CoNonRec binder rhs)
1677   = specOneBinding new_binders (binder,rhs)     `thenSM` \ ((binder,rhs), rhs_uds) ->
1678     returnSM (CoNonRec binder rhs, rhs_uds)
1679
1680 specBind new_binders (CoRec pairs)
1681   = mapAndUnzipSM (specOneBinding new_binders) pairs    `thenSM` \ (pairs, rhs_uds_s) ->
1682     returnSM (CoRec pairs, unionUDList rhs_uds_s)
1683
1684
1685 specOneBinding :: [Id] -> (Id,PlainCoreExpr) -> SpecM ((Id,PlainCoreExpr), UsageDetails)
1686
1687 specOneBinding new_binders (binder, rhs)
1688   = lookupId binder             `thenSM` \ blookup ->
1689     specExpr rhs []             `thenSM` \ (rhs, rhs_uds) ->
1690     let
1691         specid_maybe_maybe  = isSpecPragmaId_maybe binder
1692         is_specid           = maybeToBool specid_maybe_maybe
1693         Just specinfo_maybe = specid_maybe_maybe
1694         specid_with_info    = maybeToBool specinfo_maybe
1695         Just spec_info      = specinfo_maybe
1696
1697         pragma_uds
1698           = if is_specid && specid_with_info then
1699                 -- Have a SpecInfo stored in a SpecPragmaId binder
1700                 -- This contains the SpecInfo for a specialisation pragma
1701                 -- with an explicit SpecId specified
1702                 -- We remove any cis for orig_id (there should only be one)
1703                 -- and add the explicit ci to the usage details
1704                 let
1705                     (SpecInfo spec_tys _ spec_id) = spec_info
1706                     Just (orig_id, _) = isSpecId_maybe spec_id
1707                 in
1708                 ASSERT(toplevelishId orig_id)     -- must not be cloned!
1709                 explicitCI orig_id spec_tys spec_info
1710             else
1711                 emptyUDs
1712
1713         (binds_here, final_uds) = dumpUDs rhs_uds new_binders []
1714     in
1715     case blookup of
1716         Lifted lift_binder unlift_binder
1717           ->    -- We may need to record an unboxed instance of
1718                 -- the _Lift data type in the usage details
1719              mkTyConInstance liftDataCon [getIdUniType unlift_binder]
1720                                                 `thenSM` \ lift_uds ->
1721              returnSM ((lift_binder,
1722                         mkCoLetsNoUnboxed binds_here (liftExpr unlift_binder rhs)),
1723                        final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
1724
1725         NoLift (CoVarAtom binder)
1726           -> returnSM ((binder, mkCoLetsNoUnboxed binds_here rhs),
1727                        final_uds `unionUDs` pragma_uds)
1728 \end{code}
1729
1730
1731 %************************************************************************
1732 %*                                                                      *
1733 \subsection{@instBind@}
1734 %*                                                                      *
1735 %************************************************************************
1736
1737 \begin{code}
1738 instBind main_ids@(first_binder:other_binders) bind call_insts_for_main_ids
1739  | all same_overloading other_binders
1740  = let
1741         -- Collect up identical call instances
1742         equiv_classes = equivClasses cmpCI_tys call_insts_for_main_ids
1743    in
1744         -- For each equivalence class, build an instance
1745    mapAndUnzip3SM do_this_class equiv_classes   `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
1746
1747         -- Add in the remaining UDs
1748    returnSM (catMaybes inst_binds,
1749              unionUDList inst_uds_s,
1750              spec_infos
1751             )
1752
1753  | otherwise            -- Incompatible overloadings; see below by same_overloading
1754  = (if null (filter isUnboxedCI call_insts_for_main_ids)
1755     then (\ x y -> y) -- pprTrace "dumpCIs: not same overloading ... \n"
1756     else pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n")
1757              (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"])
1758                    4 (ppAboves (map pprCI call_insts_for_main_ids)))
1759    (returnSM ([], emptyUDs, []))
1760
1761  where
1762     (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
1763     tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls
1764
1765     no_of_tyvars = length tyvar_tmpls
1766     no_of_dicts  = length class_tyvar_pairs
1767
1768     do_this_class equiv_cis
1769       | not (null explicit_cis)
1770       = if (length main_ids > 1 || length explicit_cis > 1) then
1771             -- ToDo: If this situation arose we would need to go through
1772             --       checking cis for each main_id and only creating an
1773             --       instantiation if we had no explicit_cis for that main_id
1774             pprPanic "Specialise:instBind:explicit call instances\n"
1775                      (ppAboves [ppCat [ppStr "{", ppr PprDebug main_ids, ppStr "}"],
1776                                 ppAboves (map pprCI equiv_cis)])
1777         else
1778             getSwitchCheckerSM          `thenSM` \ sw_chkr ->
1779             (if sw_chkr SpecialiseTrace then
1780              let
1781                 SpecInfo spec_tys _ spec_id = explicit_spec_info
1782              in
1783              pprTrace "Specialising:"
1784                  (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"])
1785                        4 (ppAboves [
1786                           ppCat (ppStr "at types:" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
1787                           ppCat [ppStr "spec ids:", ppr PprDebug [spec_id], ppStr "(explicit)"]]))
1788              else id) (
1789
1790             returnSM (Nothing, emptyUDs, [explicit_spec_info])
1791             )
1792       | otherwise
1793       = mkOneInst (head equiv_cis) no_of_dicts main_ids bind
1794       where
1795         explicit_cis = filter isExplicitCI equiv_cis
1796         [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis
1797
1798
1799         -- same_overloading tests whether the types of all the binders
1800         -- are "compatible"; ie have the same type and dictionary abstractions
1801         -- Almost always this is the case, because a recursive group is abstracted
1802         -- all together.  But, it can happen that it ain't the case, because of
1803         -- code generated from instance decls:
1804         --
1805         --      rec
1806         --        dfun.Foo.Int :: (forall a. a -> Int, Int)
1807         --        dfun.Foo.Int = (const.op1.Int, const.op2.Int)
1808         --
1809         --        const.op1.Int :: forall a. a -> Int
1810         --        const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
1811         --
1812         --        const.op2.Int :: Int
1813         --        const.op2.Int = 3
1814         --
1815         -- Note that the first two defns have different polymorphism, but they are
1816         -- mutually recursive!
1817
1818     same_overloading :: Id -> Bool
1819     same_overloading id
1820       = no_of_tyvars == length this_id_tyvars                                   -- Same no of tyvars
1821         &&
1822         no_of_dicts == length this_id_class_tyvar_pairs                         -- Same no of vdicts
1823         &&
1824         and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)       -- Same overloading
1825       where
1826         (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
1827         tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
1828
1829         same_ov (clas1,tyvar1) (clas2,tyvar2)
1830           = clas1  == clas2 &&
1831             tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
1832 \end{code}
1833
1834 OK, so we have:
1835         - a call instance                               eg f [t1,t2,t3] [d1,d2]
1836         - the rhs of the function                       eg orig_rhs
1837         - a constraint vector, saying which of          eg [T,F,T]
1838           the functions type args are constrained
1839           (ie overloaded)
1840
1841 We return a new definition
1842
1843         f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2
1844
1845 The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
1846
1847         SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
1848
1849 Based on this SpecInfo, a call instance of f
1850
1851         ...(f t1 t2 t3 d1 d2)...
1852
1853 should get replaced by
1854
1855         ...(f@t1//t3 t2)...
1856
1857 (But that is the business of @mkCall@.)
1858
1859 \begin{code}
1860 mkOneInst :: CallInstance
1861           -> Int                                -- No of dicts to specialise
1862           -> [Id]                               -- New binders
1863           -> PlainCoreBinding                   -- Unprocessed
1864           -> SpecM (Maybe PlainCoreBinding,     -- Instantiated version of input
1865                     UsageDetails,
1866                     [SpecInfo]                  -- One for each id in the original binding
1867                    )
1868
1869 mkOneInst (CallInstance _ spec_tys dict_args _ _) no_of_dicts_to_specialise main_ids orig_bind
1870   = ASSERT (no_of_dicts_to_specialise == length dict_args)
1871     newSpecIds main_ids spec_tys no_of_dicts_to_specialise copy_inline_info
1872                                                         `thenSM` \ spec_ids ->
1873     newTyVars (length [() | Nothing <- spec_tys])       `thenSM` \ poly_tyvars ->
1874     let
1875         -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
1876         -- which correspond to unspeciailsed args
1877         arg_tys  :: [UniType]
1878         (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
1879
1880         args :: [PlainCoreArg]
1881         args = map TypeArg arg_tys ++ dict_args
1882
1883         (one_spec_id:_) = spec_ids
1884
1885         do_bind (CoNonRec binder rhs)
1886           = do_one_rhs rhs      `thenSM` \ (rhs, rhs_uds) ->
1887             returnSM (CoNonRec one_spec_id rhs, rhs_uds)
1888
1889         do_bind (CoRec pairs)
1890           = mapAndUnzipSM do_one_rhs [rhs | (_,rhs) <- pairs]   `thenSM` \ (rhss, rhss_uds_s) ->
1891             returnSM (CoRec (spec_ids `zip` rhss), unionUDList rhss_uds_s)
1892
1893         -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
1894         do_one_rhs orig_rhs = specExpr orig_rhs args    `thenSM` \ (inst_rhs, inst_uds) ->
1895                               let
1896                                 (binds_here, final_uds) = dumpUDs inst_uds main_ids []
1897                                 -- NB: main_ids!! not spec_ids!! Why? Because the free-var
1898                                 -- stuff knows nowt about spec_ids; it'll just have the
1899                                 -- original polymorphic main_ids as free.  Belgh
1900                               in
1901                               returnSM (mkCoLetsNoUnboxed binds_here (mkCoTyLam poly_tyvars inst_rhs),
1902                                         final_uds)
1903     in
1904     getSwitchCheckerSM          `thenSM` \ sw_chkr ->
1905     (if sw_chkr SpecialiseTrace then
1906         pprTrace "Specialising:"
1907                  (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"])
1908                        4 (ppAboves [
1909                           ppBesides [ppStr "with args: ", ppInterleave ppNil (map pp_arg args)],
1910                           ppBesides [ppStr "spec ids: ", ppr PprDebug spec_ids]]))
1911      else id) (
1912
1913     do_bind orig_bind           `thenSM` \ (inst_bind, inst_uds) ->
1914
1915     returnSM (Just inst_bind,
1916               inst_uds,
1917               [SpecInfo spec_tys no_of_dicts_to_specialise spec_id | spec_id <- spec_ids]
1918               )
1919     )
1920   where
1921     -- debugging
1922     pp_arg (ValArg  a) = ppBesides [ppLparen, ppStr "ValArg ", ppr PprDebug a, ppRparen]
1923     pp_arg (TypeArg t) = ppBesides [ppLparen, ppStr "TypeArg ", ppr PprDebug t, ppRparen]
1924
1925     do_the_wotsit (tyvar:tyvars) Nothing   = (tyvars, mkTyVarTy tyvar)
1926     do_the_wotsit tyvars         (Just ty) = (tyvars, ty)
1927
1928     copy_inline_info new_id old_uf_info = addIdUnfolding new_id old_uf_info
1929 \end{code}
1930
1931 %************************************************************************
1932 %*                                                                      *
1933 \subsection[Misc]{Miscellaneous junk}
1934 %*                                                                      *
1935 %************************************************************************
1936
1937 @getIdOverloading@ grabs the type of an Id, and returns a
1938 list of its polymorphic variables, and the initial segment of
1939 its ThetaType, in which the classes constrain only type variables.
1940 For example, if the Id's type is
1941
1942         forall a,b,c. Eq a -> Ord [a] -> tau
1943
1944 we'll return
1945
1946         ([a,b,c], [(Eq,a)])
1947
1948 This seems curious at first.  For a start, the type above looks odd,
1949 because we usually only have dictionary args whose types are of
1950 the form (C a) where a is a type variable.  But this doesn't hold for
1951 the functions arising from instance decls, which sometimes get
1952 arguements with types of form (C (T a)) for some type constructor T.
1953
1954 Should we specialise wrt this compound-type dictionary?  This is
1955 a heuristic judgement, as indeed is the fact that we specialise wrt
1956 only dictionaries.  We choose *not* to specialise wrt compound dictionaries
1957 because at the moment the only place they show up is in instance decls,
1958 where they are simply plugged into a returned dictionary.  So nothing is
1959 gained by specialising wrt them.
1960
1961 \begin{code}
1962 getIdOverloading :: Id
1963                  -> ([TyVarTemplate], [(Class,TyVarTemplate)])
1964 getIdOverloading id
1965   = (tyvars, tyvar_part_of theta)
1966   where
1967     (tyvars, theta, _) = splitType (getIdUniType id)
1968
1969     tyvar_part_of []                  = []
1970     tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
1971                                             Nothing    -> []
1972                                             Just tyvar -> (clas, tyvar) : tyvar_part_of theta
1973 \end{code}
1974
1975 \begin{code}
1976 mkCallInstance :: Id
1977                -> Id
1978                -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
1979                -> SpecM UsageDetails
1980
1981 mkCallInstance old_id new_id args
1982   = recordCallInst old_id args  `thenSM` \ record_call ->
1983     case record_call of
1984       Nothing                                           -- No specialisation required
1985         -> -- pprTrace "NoSpecReqd:"
1986            --       (ppCat [ppr PprDebug old_id, ppStr "at", ppCat (map (ppr PprDebug) args)])
1987
1988            (returnSM call_fv_uds)
1989
1990       Just (True, spec_tys, dict_args, rest_args)       -- Requires specialisation: spec already exists
1991         -> -- pprTrace "SpecExists:"
1992            --       (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args),
1993            --               ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
1994            --                                     ppCat [ppr PprDebug dict | dict <- dict_args],
1995            --                          ppStr ")"]])
1996
1997            (returnSM call_fv_uds)
1998
1999       Just (False, spec_tys, dict_args, rest_args)      -- Requires specialisation: record call-instance
2000         -> -- pprTrace "CallInst:"
2001            --       (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args),
2002            --               ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
2003            --                                     ppCat [ppr PprDebug dict | dict <- dict_args],
2004            --                          ppStr ")"]])
2005
2006            (returnSM (singleCI new_id spec_tys dict_args `unionUDs` call_fv_uds))
2007   where
2008     call_fv_uds = singleFvUDs (CoVarAtom new_id) `unionUDs` unionUDList [uds | (_,uds,_) <- args]
2009 \end{code}
2010
2011 \begin{code}
2012 recordCallInst :: Id
2013                -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
2014                -> SpecM (Maybe (Bool, [Maybe UniType], [PlainCoreArg],
2015                                 [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]))
2016
2017 recordCallInst id []            -- No args => no call instance
2018   = returnSM Nothing
2019
2020 recordCallInst id args
2021   | isBottomingId id            -- No specialised versions for "error" and friends are req'd.
2022   = returnSM Nothing            -- This is a special case in core lint etc.
2023
2024         -- No call instances for Ids associated with a Class declaration,
2025         -- i.e. default methods, super-dict selectors and class ops.
2026         -- We rely on the instance declarations to provide suitable specialisations.
2027         -- These are dealt with in mkCall.
2028
2029   | isDefaultMethodId id
2030   = returnSM Nothing
2031
2032   | maybeToBool (isSuperDictSelId_maybe id)
2033   = returnSM Nothing
2034
2035   | isClassOpId id
2036   = returnSM Nothing
2037
2038         -- Finally, the default case ...
2039
2040   | otherwise
2041   = getSwitchCheckerSM          `thenSM` \ sw_chkr ->
2042     let
2043         spec_overloading = sw_chkr SpecialiseOverloaded
2044         spec_unboxed     = sw_chkr SpecialiseUnboxed
2045         spec_all         = sw_chkr SpecialiseAll
2046
2047         (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading id
2048         constraint_vec = mkConstraintVector tyvar_tmpls class_tyvar_pairs
2049
2050         arg_res = take_type_args tyvar_tmpls class_tyvar_pairs args
2051         enough_args = maybeToBool arg_res
2052
2053         (Just (inst_tys, dict_args, rest_args)) = arg_res
2054         spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
2055                                      constraint_vec inst_tys
2056
2057         spec_exists = maybeToBool (lookupSpecEnv
2058                                      (getIdSpecialisation id)
2059                                      inst_tys)
2060
2061         -- We record the call instance if there is some meaningful
2062         -- type which we want to specialise on ...
2063         record_spec = any (not . isTyVarTy) (catMaybes spec_tys)
2064     in
2065     if (not enough_args) then
2066         pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
2067                  (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
2068     else
2069     if record_spec then
2070         returnSM (Just (spec_exists, spec_tys, dict_args, rest_args))
2071     else
2072         returnSM Nothing
2073
2074
2075 take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
2076         = case take_type_args tyvars class_tyvar_pairs args of
2077                 Nothing                   -> Nothing
2078                 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2079 take_type_args (_:tyvars) class_tyvar_pairs []
2080         = Nothing
2081 take_type_args [] class_tyvar_pairs args
2082         = case take_dict_args class_tyvar_pairs args of
2083                 Nothing              -> Nothing
2084                 Just (dicts, others) -> Just ([], dicts, others)
2085
2086 take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
2087         = case take_dict_args class_tyvar_pairs args of
2088                 Nothing              -> Nothing
2089                 Just (dicts, others) -> Just (dict:dicts, others)
2090 take_dict_args (_:class_tyvar_pairs) []
2091         = Nothing
2092 take_dict_args [] args
2093         = Just ([], args)
2094 \end{code}
2095
2096 \begin{code}
2097 mkCall :: Id
2098        -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
2099        -> SpecM PlainCoreExpr
2100
2101 mkCall main_id args
2102   | isDefaultMethodId main_id
2103     && any isUnboxedDataType ty_args
2104         -- No specialisations for default methods
2105         -- Unboxed calls to DefaultMethodIds should not occur
2106         -- The method should be specified in the instance declaration
2107     = panic "Specialise:mkCall:DefaultMethodId"
2108
2109   | maybeToBool (isSuperDictSelId_maybe main_id)
2110     && any isUnboxedDataType ty_args
2111         -- No specialisations for super-dict selectors
2112         -- Specialise unboxed calls to SuperDictSelIds by extracting
2113         -- the super class dictionary directly form the super class
2114         -- NB: This should be dead code since all uses of this dictionary should
2115         --     have been specialised. We only do this to keep keep core-lint happy.
2116     = let
2117          Just (_, super_class) = isSuperDictSelId_maybe main_id
2118          super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2119                          Nothing -> panic "Specialise:mkCall:SuperDictId"
2120                          Just id -> id
2121       in
2122       returnSM (CoVar super_dict_id)
2123
2124   | otherwise
2125     = case lookupSpecEnv (getIdSpecialisation main_id) ty_args of
2126         Nothing -> checkUnspecOK main_id ty_args (
2127                    returnSM unspec_call
2128                    )
2129
2130         Just (spec_id, tys_left, dicts_to_toss)
2131                 -> checkSpecOK main_id ty_args spec_id tys_left (
2132                    let
2133                        args_left = toss_dicts dicts_to_toss val_args
2134                    in
2135
2136                         -- The resulting spec_id may be an unboxed constant method
2137                         --   eg: pi Double# d.Floating.Double# ==> pi.Double#
2138                         -- Since it is a top level id pi.Double# will have been lifted.
2139                         -- We must add code to unlift such a spec_id
2140
2141                    if isUnboxedDataType (getIdUniType spec_id) then
2142                        ASSERT (null tys_left && null args_left)
2143                        if isConstMethodId spec_id then
2144                            liftId spec_id       `thenSM` \ (lifted_spec_id, unlifted_spec_id) ->
2145                            returnSM (bindUnlift lifted_spec_id unlifted_spec_id
2146                                                 (CoVar unlifted_spec_id))
2147                        else
2148                            -- ToDo: Are there other cases where we have an unboxed spec_id ???
2149                            pprPanic "Specialise:mkCall: unboxed spec_id ...\n"
2150                                     (ppCat [ppr PprDebug main_id,
2151                                             ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args),
2152                                             ppStr "==>",
2153                                             ppr PprDebug spec_id])
2154                    else
2155                    let
2156                        (vals_left, _, unlifts_left) = unzip3 args_left
2157                        applied_tys  = mkCoTyApps (CoVar spec_id) tys_left
2158                        applied_vals = applyToArgs applied_tys vals_left
2159                    in
2160                    returnSM (applyBindUnlifts unlifts_left applied_vals)
2161                    )
2162   where
2163     (tys_and_vals, _, unlifts) = unzip3 args
2164     unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar main_id) tys_and_vals)
2165
2166
2167         -- ty_args is the types at the front of the arg list
2168         -- val_args is the rest of the arg-list
2169
2170     (ty_args, val_args) = get args
2171       where
2172         get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2173         get args                      = ([],       args)
2174
2175         -- toss_dicts chucks away dict args, checking that they ain't types!
2176     toss_dicts 0 args                    = args
2177     toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args
2178 \end{code}
2179
2180 \begin{code}
2181 checkUnspecOK :: Id -> [UniType] -> a -> a
2182 checkUnspecOK check_id tys
2183   = if isLocallyDefined check_id && any isUnboxedDataType tys
2184     then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2185                   (ppCat [ppr PprDebug check_id,
2186                           ppInterleave ppNil (map (pprParendUniType PprDebug) tys)])
2187     else id
2188
2189 checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a
2190 checkSpecOK check_id tys spec_id tys_left
2191   = if any isUnboxedDataType tys_left
2192     then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2193                   (ppAboves [ppCat [ppr PprDebug check_id,
2194                                     ppInterleave ppNil (map (pprParendUniType PprDebug) tys)],
2195                              ppCat [ppr PprDebug spec_id,
2196                                     ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]])
2197     else id
2198 \end{code}
2199
2200 \begin{code}
2201 mkTyConInstance :: Id
2202                 -> [UniType]
2203                 -> SpecM UsageDetails
2204 mkTyConInstance con tys
2205   = recordTyConInst con tys     `thenSM` \ record_inst ->
2206     case record_inst of
2207       Nothing                           -- No TyCon instance
2208         -> -- pprTrace "NoTyConInst:"
2209            --       (ppCat [ppr PprDebug tycon, ppStr "at",
2210            --               ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
2211            (returnSM (singleConUDs con))
2212
2213       Just spec_tys                     -- Record TyCon instance
2214         -> -- pprTrace "TyConInst:"
2215            --       (ppCat [ppr PprDebug tycon, ppStr "at",
2216            --               ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
2217            --               ppBesides [ppStr "(",
2218            --                          ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
2219            --                          ppStr ")"]])
2220            (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2221   where
2222     tycon = getDataConTyCon con
2223 \end{code}
2224
2225 \begin{code}
2226 recordTyConInst :: Id
2227                 -> [UniType]
2228                 -> SpecM (Maybe [Maybe UniType])
2229
2230 recordTyConInst con tys
2231   = let
2232         spec_tys = specialiseConstrTys tys
2233
2234         do_tycon_spec = maybeToBool (firstJust spec_tys)
2235
2236         spec_exists = maybeToBool (lookupSpecEnv
2237                                       (getIdSpecialisation con)
2238                                       tys)
2239     in
2240     -- pprTrace "ConSpecExists?: "
2241     --       (ppAboves [ppStr (if spec_exists then "True" else "False"),
2242     --                  ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
2243     (if (not spec_exists && do_tycon_spec)
2244      then returnSM (Just spec_tys)
2245      else returnSM Nothing)
2246 \end{code}
2247
2248 \begin{code}
2249 {- UNUSED: create specilaised constructor calls in Core
2250 mkConstrCall :: PlainCoreAtom -> [UniType]      -- This constructor at these types
2251              -> SpecM (Id, [UniType])           -- The specialised constructor and reduced types
2252
2253 mkConstrCall (CoVarAtom con_id) tys
2254   = case lookupSpecEnv (getIdSpecialisation con_id) tys of
2255         Nothing -> checkUnspecOK con_id tys (
2256                    returnSM (con_id, tys)
2257                    )
2258         Just (spec_id, tys_left, 0)
2259                 -> checkSpecOK con_id tys spec_id tys_left (
2260                    returnSM (spec_id, tys_left)
2261                    )
2262 -}
2263 \end{code}
2264
2265 %************************************************************************
2266 %*                                                                      *
2267 \subsection[monad-Specialise]{Monad used in specialisation}
2268 %*                                                                      *
2269 %************************************************************************
2270
2271 Monad has:
2272
2273  inherited: control flags and
2274             recordInst functions with flags cached
2275
2276             environment mapping tyvars to types
2277             environment mapping Ids to Atoms
2278
2279  threaded in and out: unique supply
2280
2281 \begin{code}
2282 type SpecM result
2283   =  (GlobalSwitch -> Bool)
2284   -> TypeEnv
2285   -> SpecIdEnv
2286   -> SplitUniqSupply
2287   -> result
2288
2289 initSM m sw_chker uniqs
2290   = m sw_chker nullTyVarEnv nullIdEnv uniqs
2291
2292 returnSM :: a -> SpecM a
2293 thenSM   :: SpecM a -> (a -> SpecM b) -> SpecM b
2294 fixSM    :: (a -> SpecM a) -> SpecM a
2295
2296 thenSM m k sw_chkr tvenv idenv us
2297   = case splitUniqSupply us        of { (s1, s2) ->
2298     case (m sw_chkr tvenv idenv s1) of { r ->
2299     k r sw_chkr tvenv idenv s2 }}
2300
2301 returnSM r sw_chkr tvenv idenv us = r
2302
2303 fixSM k sw_chkr tvenv idenv us
2304  = r
2305  where
2306    r = k r sw_chkr tvenv idenv us       -- Recursive in r!
2307 \end{code}
2308
2309 \begin{code}
2310 getSwitchCheckerSM sw_chkr tvenv idenv us = sw_chkr
2311 \end{code}
2312
2313 The only interesting bit is figuring out the type of the SpecId!
2314
2315 \begin{code}
2316 newSpecIds :: [Id]              -- The id of which to make a specialised version
2317            -> [Maybe UniType]   -- Specialise to these types
2318            -> Int               -- No of dicts to specialise
2319            -> (Id -> UnfoldingDetails -> Id)  -- copies any arity info required
2320            -> SpecM [Id]
2321
2322 newSpecIds main_ids maybe_tys dicts_to_ignore copy_id_info sw_chkr tvenv idenv us
2323   = spec_ids
2324   where
2325     uniqs = getSUniques (length main_ids) us
2326     spec_id_ty id = specialiseTy (getIdUniType id) maybe_tys dicts_to_ignore
2327     spec_ids = [ copy_id_info (mkSpecId uniq id maybe_tys (spec_id_ty id) noIdInfo) (getIdUnfolding id)
2328                | (id,uniq) <- main_ids `zip` uniqs
2329                ]
2330
2331 newTyVars :: Int -> SpecM [TyVar]
2332 newTyVars n sw_chkr tvenv idenv us
2333  = map mkPolySysTyVar uniqs
2334  where
2335    uniqs = getSUniques n us
2336 \end{code}
2337
2338 @cloneLambdaOrCaseBinders@ and @cloneLetrecBinders@ take a bunch of
2339 binders, and build ``clones'' for them.  The clones differ from the
2340 originals in three ways:
2341
2342         (a) they have a fresh unique
2343         (b) they have the current type environment applied to their type
2344         (c) for letrec binders which have been specialised to unboxed values
2345             the clone will have a lifted type
2346
2347 As well as returning the list of cloned @Id@s they also return a list of
2348 @CloneInfo@s which the original binders should be bound to.
2349
2350 \begin{code}
2351 cloneLambdaOrCaseBinders :: [Id]                        -- Old binders
2352                          -> SpecM ([Id], [CloneInfo])   -- New ones
2353
2354 cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us
2355   = let
2356         uniqs = getSUniques (length old_ids) us
2357     in
2358     unzip (zipWith clone_it old_ids uniqs)
2359   where
2360     clone_it old_id uniq
2361       = (new_id, NoLift (CoVarAtom new_id))
2362       where
2363         new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2364
2365 cloneLetrecBinders :: [Id]                              -- Old binders
2366                    -> SpecM ([Id], [CloneInfo]) -- New ones
2367
2368 cloneLetrecBinders old_ids sw_chkr tvenv idenv us
2369   = let
2370         uniqs = getSUniques (2 * length old_ids) us
2371     in
2372     unzip (clone_them old_ids uniqs)
2373   where
2374     clone_them [] [] = []
2375
2376     clone_them (old_id:olds) (u1:u2:uniqs)
2377       | toplevelishId old_id
2378         = (old_id,
2379            NoLift (CoVarAtom old_id)) : clone_rest
2380
2381          -- Don't clone if it is a top-level thing. Why not?
2382          -- (a) we don't want to change the uniques
2383          --     on such things (see TopLevId in Id.lhs)
2384          -- (b) we don't have to be paranoid about name capture
2385          -- (c) the thing is polymorphic so no need to subst
2386
2387       | otherwise
2388         = if (isUnboxedDataType new_ty && not (isUnboxedDataType old_ty))
2389           then (lifted_id,
2390                 Lifted lifted_id unlifted_id) : clone_rest
2391           else (new_id,
2392                 NoLift (CoVarAtom new_id)) : clone_rest
2393
2394       where
2395         clone_rest = clone_them olds uniqs
2396
2397         new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2398         new_ty = getIdUniType new_id
2399         old_ty = getIdUniType old_id
2400
2401         (lifted_id, unlifted_id) = mkLiftedId new_id u2
2402
2403
2404 cloneTyVarSM :: TyVar -> SpecM TyVar
2405
2406 cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
2407   = let
2408         uniq = getSUnique us
2409     in
2410     cloneTyVar old_tyvar uniq -- new_tyvar
2411
2412 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2413
2414 bindId id val specm sw_chkr tvenv idenv us
2415  = specm sw_chkr tvenv (addOneToIdEnv idenv id val) us
2416
2417 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2418
2419 bindIds olds news specm sw_chkr tvenv idenv us
2420  = specm sw_chkr tvenv (growIdEnvList idenv (zip olds news)) us
2421
2422 bindSpecIds :: [Id]             -- Old
2423             -> [(CloneInfo)]    -- New
2424             -> [[SpecInfo]]     -- Corresponding specialisations
2425                                 -- Each sub-list corresponds to a different type,
2426                                 -- and contains one spec_info for each id
2427             -> SpecM thing
2428             -> SpecM thing
2429
2430 bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
2431  = specm sw_chkr tvenv (growIdEnvList idenv old_to_clone) us
2432  where
2433    old_to_clone = mk_old_to_clone olds clones spec_infos
2434
2435    -- The important thing here is that we are *lazy* in spec_infos
2436    mk_old_to_clone [] [] _ = []
2437    mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2438      = (old, add_spec_info clone) :
2439        mk_old_to_clone rest_olds rest_clones spec_infos_rest
2440      where
2441        add_spec_info (NoLift (CoVarAtom new))
2442          = NoLift (CoVarAtom (new `addIdSpecialisation`
2443                                   (mkSpecEnv spec_infos_this_id)))
2444        add_spec_info lifted
2445          = lifted               -- no specialised instances for unboxed lifted values
2446
2447        spec_infos_this_id = map head spec_infos
2448        spec_infos_rest    = map tail spec_infos
2449
2450 {- UNUSED: creating specialised constructors
2451 bindConIds :: [Id]              -- Old constructors
2452            -> [[SpecInfo]]      -- Corresponding specialisations to be added
2453                                 -- Each sub-list corresponds to one constructor, and
2454                                 -- gives all its specialisations
2455            -> SpecM thing
2456            -> SpecM thing
2457
2458 bindConIds ids spec_infos specm sw_chkr tvenv idenv us
2459  = specm sw_chkr tvenv (growIdEnvList idenv id_to_newspec) us
2460  where
2461    id_to_newspec = mk_id_to_newspec ids spec_infos
2462
2463    -- The important thing here is that we are *lazy* in spec_infos
2464    mk_id_to_newspec [] _ = []
2465    mk_id_to_newspec (id:rest_ids) spec_infos
2466      = (id, CoVarAtom id_with_spec) :
2467        mk_id_to_newspec rest_ids spec_infos_rest
2468      where
2469        id_with_spec = id `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)
2470        spec_infos_this_id = head spec_infos
2471        spec_infos_rest    = tail spec_infos
2472 -}
2473
2474 bindTyVar :: TyVar -> UniType -> SpecM thing -> SpecM thing
2475
2476 bindTyVar tyvar ty specm sw_chkr tvenv idenv us
2477  = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2478 \end{code}
2479
2480 \begin{code}
2481 lookupId :: Id -> SpecM CloneInfo
2482
2483 lookupId id sw_chkr tvenv idenv us
2484   = case lookupIdEnv idenv id of
2485       Nothing   -> NoLift (CoVarAtom id)
2486       Just info -> info
2487 \end{code}
2488
2489 \begin{code}
2490 specTy :: UniType -> SpecM UniType      -- Apply the current type envt to the type
2491
2492 specTy ty sw_chkr tvenv idenv us
2493   = applyTypeEnvToTy tvenv ty
2494 \end{code}
2495
2496 \begin{code}
2497 liftId :: Id -> SpecM (Id, Id)
2498 liftId id sw_chkr tvenv idenv us
2499   = let
2500         uniq = getSUnique us
2501     in
2502     mkLiftedId id uniq
2503 \end{code}
2504
2505 In other monads these @mapSM@ things are usually called @listM@.
2506 I think @mapSM@ is a much better name.  The `2' and `3' variants are
2507 when you want to return two or three results, and get at them
2508 separately.  It saves you having to do an (unzip stuff) right after.
2509
2510 \begin{code}
2511 mapSM          :: (a -> SpecM b)            -> [a] -> SpecM [b]
2512 mapAndUnzipSM  :: (a -> SpecM (b1, b2))     -> [a] -> SpecM ([b1],[b2])
2513 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2514 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2515
2516 mapSM f [] = returnSM []
2517 mapSM f (x:xs) = f x            `thenSM` \ r ->
2518                  mapSM f xs     `thenSM` \ rs ->
2519                  returnSM (r:rs)
2520
2521 mapAndUnzipSM f [] = returnSM ([],[])
2522 mapAndUnzipSM f (x:xs) = f x                    `thenSM` \ (r1, r2) ->
2523                          mapAndUnzipSM f xs     `thenSM` \ (rs1,rs2) ->
2524                          returnSM ((r1:rs1),(r2:rs2))
2525
2526 mapAndUnzip3SM f [] = returnSM ([],[],[])
2527 mapAndUnzip3SM f (x:xs) = f x                   `thenSM` \ (r1,r2,r3) ->
2528                           mapAndUnzip3SM f xs   `thenSM` \ (rs1,rs2,rs3) ->
2529                           returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2530
2531 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2532 mapAndUnzip4SM f (x:xs) = f x                   `thenSM` \ (r1,r2,r3,r4) ->
2533                           mapAndUnzip4SM f xs   `thenSM` \ (rs1,rs2,rs3,rs4) ->
2534                           returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
2535 \end{code}