2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
7 #include "HsVersions.h"
17 IMPORT_1_3(List(partition))
19 import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
20 partitionBag, listToBag, bagToList
22 import Class ( GenClass{-instance Eq-} )
23 import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
24 opt_CompilingGhcInternals, opt_SpecialiseTrace,
25 opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
28 import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
30 import CoreUtils ( coreExprType, squashableDictishCcExpr )
31 import FiniteMap ( addListToFM_C, FiniteMap )
32 import Kind ( mkBoxedTypeKind )
33 import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
34 isSuperDictSelId_maybe, isBottomingId,
35 isConstMethodId_maybe, isDataCon,
36 isImportedId, mkIdWithNewUniq,
37 dataConTyCon, applyTypeEnvToId,
38 nullIdEnv, addOneToIdEnv, growIdEnvList,
39 lookupIdEnv, SYN_IE(IdEnv),
40 emptyIdSet, mkIdSet, unitIdSet,
41 elementOfIdSet, minusIdSet,
42 unionIdSets, unionManyIdSets, SYN_IE(IdSet),
45 import Literal ( Literal{-instance Outputable-} )
46 import Maybes ( catMaybes, firstJust, maybeToBool )
47 import Name ( isLocallyDefined )
48 import Outputable ( interppSP, Outputable(..){-instance * []-} )
49 import PprStyle ( PprStyle(..) )
50 import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
51 GenType{-instance Outputable-}, GenTyVar{-ditto-},
54 import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
55 ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty)
57 import PrimOp ( PrimOp(..) )
59 import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
60 tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
62 import TyCon ( TyCon{-instance Eq-} )
63 import TyVar ( cloneTyVar, mkSysTyVar,
64 elementOfTyVarSet, SYN_IE(TyVarSet),
65 nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv),
66 GenTyVar{-instance Eq-}
68 import TysWiredIn ( liftDataCon )
69 import Unique ( Unique{-instance Eq-} )
70 import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
71 import UniqSupply ( splitUniqSupply, getUniques, getUnique )
72 import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
73 thenCmp, panic, pprTrace, pprPanic, assertPanic
79 data SpecInfo = SpecInfo [Maybe Type] Int Id
80 lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
81 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
82 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
83 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
84 isClassOpId = panic "Specialise.isClassOpId (ToDo)"
85 isDictTy = panic "Specialise.isDictTy (ToDo)"
86 isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
87 isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
88 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
89 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
90 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
91 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
92 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
93 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
94 specialiseTy = panic "Specialise.specialiseTy (ToDo)"
97 %************************************************************************
99 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
101 %************************************************************************
103 These notes describe how we implement specialisation to eliminate
104 overloading, and optionally to eliminate unboxed polymorphism, and
107 The specialisation pass is a partial evaluator which works on Core
108 syntax, complete with all the explicit dictionary application,
109 abstraction and construction as added by the type checker. The
110 existing type checker remains largely as it is.
112 One important thought: the {\em types} passed to an overloaded
113 function, and the {\em dictionaries} passed are mutually redundant.
114 If the same function is applied to the same type(s) then it is sure to
115 be applied to the same dictionary(s)---or rather to the same {\em
116 values}. (The arguments might look different but they will evaluate
119 Second important thought: we know that we can make progress by
120 treating dictionary arguments as static and worth specialising on. So
121 we can do without binding-time analysis, and instead specialise on
122 dictionary arguments and no others.
131 and suppose f is overloaded.
133 STEP 1: CALL-INSTANCE COLLECTION
135 We traverse <body>, accumulating all applications of f to types and
138 (Might there be partial applications, to just some of its types and
139 dictionaries? In principle yes, but in practice the type checker only
140 builds applications of f to all its types and dictionaries, so partial
141 applications could only arise as a result of transformation, and even
142 then I think it's unlikely. In any case, we simply don't accumulate such
143 partial applications.)
145 There's a choice of whether to collect details of all *polymorphic* functions
146 or simply all *overloaded* ones. How to sort this out?
147 Pass in a predicate on the function to say if it is "interesting"?
148 This is dependent on the user flags: SpecialiseOverloaded
154 So now we have a collection of calls to f:
158 Notice that f may take several type arguments. To avoid ambiguity, we
159 say that f is called at type t1/t2 and t3/t4.
161 We take equivalence classes using equality of the *types* (ignoring
162 the dictionary args, which as mentioned previously are redundant).
164 STEP 3: SPECIALISATION
166 For each equivalence class, choose a representative (f t1 t2 d1 d2),
167 and create a local instance of f, defined thus:
169 f@t1/t2 = <f_rhs> t1 t2 d1 d2
171 (f_rhs presumably has some big lambdas and dictionary lambdas, so lots
172 of simplification will now result.) Then we should recursively do
175 The new id has its own unique, but its print-name (if exported) has
176 an explicit representation of the instance types t1/t2.
178 Add this new id to f's IdInfo, to record that f has a specialised version.
180 Before doing any of this, check that f's IdInfo doesn't already
181 tell us about an existing instance of f at the required type/s.
182 (This might happen if specialisation was applied more than once, or
183 it might arise from user SPECIALIZE pragmas.)
187 Wait a minute! What if f is recursive? Then we can't just plug in
188 its right-hand side, can we?
190 But it's ok. The type checker *always* creates non-recursive definitions
191 for overloaded recursive functions. For example:
193 f x = f (x+x) -- Yes I know its silly
197 f a (d::Num a) = let p = +.sel a d
199 letrec fl (y::a) = fl (p y y)
203 We still have recusion for non-overloadd functions which we
204 speciailise, but the recursive call should get speciailised to the
205 same recursive version.
211 All this is crystal clear when the function is applied to *constant
212 types*; that is, types which have no type variables inside. But what if
213 it is applied to non-constant types? Suppose we find a call of f at type
214 t1/t2. There are two possibilities:
216 (a) The free type variables of t1, t2 are in scope at the definition point
217 of f. In this case there's no problem, we proceed just as before. A common
218 example is as follows. Here's the Haskell:
223 After typechecking we have
225 g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
226 in +.sel a d (f a d y) (f a d y)
228 Notice that the call to f is at type type "a"; a non-constant type.
229 Both calls to f are at the same type, so we can specialise to give:
231 g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
232 in +.sel a d (f@a y) (f@a y)
235 (b) The other case is when the type variables in the instance types
236 are *not* in scope at the definition point of f. The example we are
237 working with above is a good case. There are two instances of (+.sel a d),
238 but "a" is not in scope at the definition of +.sel. Can we do anything?
239 Yes, we can "common them up", a sort of limited common sub-expression deal.
242 g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
243 f@a (x::a) = +.sel@a x x
244 in +.sel@a (f@a y) (f@a y)
246 This can save work, and can't be spotted by the type checker, because
247 the two instances of +.sel weren't originally at the same type.
251 * There are quite a few variations here. For example, the defn of
252 +.sel could be floated ouside the \y, to attempt to gain laziness.
253 It certainly mustn't be floated outside the \d because the d has to
256 * We don't want to inline f_rhs in this case, because
257 that will duplicate code. Just commoning up the call is the point.
259 * Nothing gets added to +.sel's IdInfo.
261 * Don't bother unless the equivalence class has more than one item!
263 Not clear whether this is all worth it. It is of course OK to
264 simply discard call-instances when passing a big lambda.
266 Polymorphism 2 -- Overloading
268 Consider a function whose most general type is
270 f :: forall a b. Ord a => [a] -> b -> b
272 There is really no point in making a version of g at Int/Int and another
273 at Int/Bool, because it's only instancing the type variable "a" which
274 buys us any efficiency. Since g is completely polymorphic in b there
275 ain't much point in making separate versions of g for the different
278 That suggests that we should identify which of g's type variables
279 are constrained (like "a") and which are unconstrained (like "b").
280 Then when taking equivalence classes in STEP 2, we ignore the type args
281 corresponding to unconstrained type variable. In STEP 3 we make
282 polymorphic versions. Thus:
284 f@t1/ = /\b -> <f_rhs> t1 b d1 d2
286 This seems pretty simple, and a Good Thing.
288 Polymorphism 3 -- Unboxed
291 If we are speciailising at unboxed types we must speciailise
292 regardless of the overloading constraint. In the exaple above it is
293 worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
296 Note that specialising an overloaded type at an uboxed type requires
297 an unboxed instance -- we cannot default to an unspecialised version!
304 f x = let g p q = p==q
310 Before specialisation, leaving out type abstractions we have
312 f df x = let g :: Eq a => a -> a -> Bool
314 h :: Num a => a -> a -> (a, Bool)
315 h dh r s = let deq = eqFromNum dh
316 in (+ dh r s, g deq r s)
320 After specialising h we get a specialised version of h, like this:
322 h' r s = let deq = eqFromNum df
323 in (+ df r s, g deq r s)
325 But we can't naively make an instance for g from this, because deq is not in scope
326 at the defn of g. Instead, we have to float out the (new) defn of deq
327 to widen its scope. Notice that this floating can't be done in advance -- it only
328 shows up when specialisation is done.
330 DELICATE MATTER: the way we tell a dictionary binding is by looking to
331 see if it has a Dict type. If the type has been "undictify'd", so that
332 it looks like a tuple, then the dictionary binding won't be floated, and
333 an opportunity to specialise might be lost.
335 User SPECIALIZE pragmas
336 ~~~~~~~~~~~~~~~~~~~~~~~
337 Specialisation pragmas can be digested by the type checker, and implemented
338 by adding extra definitions along with that of f, in the same way as before
340 f@t1/t2 = <f_rhs> t1 t2 d1 d2
342 Indeed the pragmas *have* to be dealt with by the type checker, because
343 only it knows how to build the dictionaries d1 and d2! For example
345 g :: Ord a => [a] -> [a]
346 {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
348 Here, the specialised version of g is an application of g's rhs to the
349 Ord dictionary for (Tree Int), which only the type checker can conjure
350 up. There might not even *be* one, if (Tree Int) is not an instance of
351 Ord! (All the other specialision has suitable dictionaries to hand
354 Problem. The type checker doesn't have to hand a convenient <f_rhs>, because
355 it is buried in a complex (as-yet-un-desugared) binding group.
358 f@t1/t2 = f* t1 t2 d1 d2
360 where f* is the Id f with an IdInfo which says "inline me regardless!".
361 Indeed all the specialisation could be done in this way.
362 That in turn means that the simplifier has to be prepared to inline absolutely
363 any in-scope let-bound thing.
366 Again, the pragma should permit polymorphism in unconstrained variables:
368 h :: Ord a => [a] -> b -> b
369 {-# SPECIALIZE h :: [Int] -> b -> b #-}
371 We *insist* that all overloaded type variables are specialised to ground types,
372 (and hence there can be no context inside a SPECIALIZE pragma).
373 We *permit* unconstrained type variables to be specialised to
375 - or left as a polymorphic type variable
376 but nothing in between. So
378 {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
380 is *illegal*. (It can be handled, but it adds complication, and gains the
384 SPECIALISING INSTANCE DECLARATIONS
385 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
388 instance Foo a => Foo [a] where
390 {-# SPECIALIZE instance Foo [Int] #-}
392 The original instance decl creates a dictionary-function
395 dfun.Foo.List :: forall a. Foo a -> Foo [a]
397 The SPECIALIZE pragma just makes a specialised copy, just as for
398 ordinary function definitions:
400 dfun.Foo.List@Int :: Foo [Int]
401 dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
403 The information about what instance of the dfun exist gets added to
404 the dfun's IdInfo in the same way as a user-defined function too.
406 In fact, matters are a little bit more complicated than this.
407 When we make one of these specialised instances, we are defining
408 a constant dictionary, and so we want immediate access to its constant
409 methods and superclasses. Indeed, these constant methods and superclasses
410 must be in the IdInfo for the class selectors! We need help from the
411 typechecker to sort this out, perhaps by generating a separate IdInfo
414 Automatic instance decl specialisation?
415 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
416 Can instance decls be specialised automatically? It's tricky.
417 We could collect call-instance information for each dfun, but
418 then when we specialised their bodies we'd get new call-instances
419 for ordinary functions; and when we specialised their bodies, we might get
420 new call-instances of the dfuns, and so on. This all arises because of
421 the unrestricted mutual recursion between instance decls and value decls.
423 Furthermore, instance decls are usually exported and used non-locally,
424 so we'll want to compile enough to get those specialisations done.
426 Lastly, there's no such thing as a local instance decl, so we can
427 survive solely by spitting out *usage* information, and then reading that
428 back in as a pragma when next compiling the file. So for now,
429 we only specialise instance decls in response to pragmas.
431 That means that even if an instance decl ain't otherwise exported it
432 needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
433 something to say which module defined the instance, so the usage info
434 can be fed into the right reqts info file. Blegh.
437 SPECIAILISING DATA DECLARATIONS
438 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
440 With unboxed specialisation (or full specialisation) we also require
441 data types (and their constructors) to be speciailised on unboxed
444 In addition to normal call instances we gather TyCon call instances at
445 unboxed types, determine equivalence classes for the locally defined
446 TyCons and build speciailised data constructor Ids for each TyCon and
447 substitute these in the Con calls.
449 We need the list of local TyCons to partition the TyCon instance info.
450 We pass out a FiniteMap from local TyCons to Specialised Instances to
451 give to the interface and code genertors.
453 N.B. The specialised data constructors reference the original data
454 constructor and type constructor which do not have the updated
455 specialisation info attached. Any specialisation info must be
456 extracted from the TyCon map returned.
459 SPITTING OUT USAGE INFORMATION
460 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
462 To spit out usage information we need to traverse the code collecting
463 call-instance information for all imported (non-prelude?) functions
464 and data types. Then we equivalence-class it and spit it out.
466 This is done at the top-level when all the call instances which escape
467 must be for imported functions and data types.
470 Partial specialisation by pragmas
471 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
472 What about partial specialisation:
474 k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
475 {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
479 {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
481 Seems quite reasonable. Similar things could be done with instance decls:
483 instance (Foo a, Foo b) => Foo (a,b) where
485 {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
486 {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
488 Ho hum. Things are complex enough without this. I pass.
491 Requirements for the simplifer
492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
493 The simplifier has to be able to take advantage of the specialisation.
495 * When the simplifier finds an application of a polymorphic f, it looks in
496 f's IdInfo in case there is a suitable instance to call instead. This converts
498 f t1 t2 d1 d2 ===> f_t1_t2
500 Note that the dictionaries get eaten up too!
502 * Dictionary selection operations on constant dictionaries must be
505 +.sel Int d ===> +Int
507 The obvious way to do this is in the same way as other specialised
508 calls: +.sel has inside it some IdInfo which tells that if it's applied
509 to the type Int then it should eat a dictionary and transform to +Int.
511 In short, dictionary selectors need IdInfo inside them for constant
514 * Exactly the same applies if a superclass dictionary is being
517 Eq.sel Int d ===> dEqInt
519 * Something similar applies to dictionary construction too. Suppose
520 dfun.Eq.List is the function taking a dictionary for (Eq a) to
521 one for (Eq [a]). Then we want
523 dfun.Eq.List Int d ===> dEq.List_Int
525 Where does the Eq [Int] dictionary come from? It is built in
526 response to a SPECIALIZE pragma on the Eq [a] instance decl.
528 In short, dfun Ids need IdInfo with a specialisation for each
529 constant instance of their instance declaration.
532 What does the specialisation IdInfo look like?
533 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
536 [Maybe Type] -- Instance types
537 Int -- No of dicts to eat
538 Id -- Specialised version
540 For example, if f has this SpecInfo:
542 SpecInfo [Just t1, Nothing, Just t3] 2 f'
546 f t1 t2 t3 d1 d2 ===> f t2
548 The "Nothings" identify type arguments in which the specialised
549 version is polymorphic.
551 What can't be done this way?
552 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
553 There is no way, post-typechecker, to get a dictionary for (say)
554 Eq a from a dictionary for Eq [a]. So if we find
558 we can't transform to
563 eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
565 Of course, we currently have no way to automatically derive
566 eqList, nor to connect it to the Eq [a] instance decl, but you
567 can imagine that it might somehow be possible. Taking advantage
568 of this is permanently ruled out.
570 Still, this is no great hardship, because we intend to eliminate
571 overloading altogether anyway!
576 What about types/classes mentioned in SPECIALIZE pragmas spat out,
577 but not otherwise exported. Even if they are exported, what about
578 their original names.
580 Suggestion: use qualified names in pragmas, omitting module for
581 prelude and "this module".
588 f a (d::Num a) = let g = ...
590 ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
592 Here, g is only called at one type, but the dictionary isn't in scope at the
593 definition point for g. Usually the type checker would build a
594 definition for d1 which enclosed g, but the transformation system
595 might have moved d1's defn inward.
601 What should we do when a value is specialised to a *strict* unboxed value?
603 map_*_* f (x:xs) = let h = f x
607 Could convert let to case:
609 map_*_Int# f (x:xs) = case f x of h# ->
613 This may be undesirable since it forces evaluation here, but the value
614 may not be used in all branches of the body. In the general case this
615 transformation is impossible since the mutual recursion in a letrec
616 cannot be expressed as a case.
618 There is also a problem with top-level unboxed values, since our
619 implementation cannot handle unboxed values at the top level.
621 Solution: Lift the binding of the unboxed value and extract it when it
624 map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
629 Now give it to the simplifier and the _Lifting will be optimised away.
631 The benfit is that we have given the specialised "unboxed" values a
632 very simple lifted semantics and then leave it up to the simplifier to
633 optimise it --- knowing that the overheads will be removed in nearly
636 In particular, the value will only be evaluted in the branches of the
637 program which use it, rather than being forced at the point where the
638 value is bound. For example:
640 filtermap_*_* p f (x:xs)
647 filtermap_*_Int# p f (x:xs)
648 = let h = case (f x) of h# -> _Lift h#
651 True -> case h of _Lift h#
655 The binding for h can still be inlined in the one branch and the
659 Question: When won't the _Lifting be eliminated?
661 Answer: When they at the top-level (where it is necessary) or when
662 inlining would duplicate work (or possibly code depending on
663 options). However, the _Lifting will still be eliminated if the
664 strictness analyser deems the lifted binding strict.
668 %************************************************************************
670 \subsubsection[CallInstances]{@CallInstances@ data type}
672 %************************************************************************
675 type FreeVarsSet = IdSet
676 type FreeTyVarsSet = TyVarSet
680 Id -- This Id; *new* ie *cloned* id
681 [Maybe Type] -- Specialised at these types (*new*, cloned)
682 -- Nothing => no specialisation on this type arg
683 -- is required (flag dependent).
684 [CoreArg] -- And these dictionaries; all ValArgs
685 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
686 (Maybe SpecInfo) -- For specialisation with explicit SpecId
690 pprCI :: CallInstance -> Pretty
691 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
692 = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
693 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
694 case maybe_specinfo of
695 Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
696 Just (SpecInfo _ _ spec_id)
697 -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
700 -- ToDo: instance Outputable CoreArg?
701 ppr_arg sty (TyArg t) = ppr sty t
702 ppr_arg sty (LitArg i) = ppr sty i
703 ppr_arg sty (VarArg v) = ppr sty v
705 isUnboxedCI :: CallInstance -> Bool
706 isUnboxedCI (CallInstance _ spec_tys _ _ _)
707 = any isUnboxedType (catMaybes spec_tys)
709 isExplicitCI :: CallInstance -> Bool
710 isExplicitCI (CallInstance _ _ _ _ (Just _))
712 isExplicitCI (CallInstance _ _ _ _ Nothing)
716 Comparisons are based on the {\em types}, ignoring the dictionary args:
720 cmpCI :: CallInstance -> CallInstance -> TAG_
721 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
722 = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
724 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
725 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
726 = cmpUniTypeMaybeList tys1 tys2
728 eqCI_tys :: CallInstance -> CallInstance -> Bool
730 = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
732 isCIofTheseIds :: [Id] -> CallInstance -> Bool
733 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
734 = any ((==) ci_id) ids
736 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
737 singleCI id tys dicts
738 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
739 emptyBag [] emptyIdSet 0 0
741 fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
743 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
744 explicitCI id tys specinfo
745 = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
747 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
748 dicts = panic "Specialise:explicitCI:dicts"
749 fv_set = unitIdSet id
751 -- We do not process the CIs for top-level dfuns or defms
752 -- Instead we require an explicit SPEC inst pragma for dfuns
753 -- and an explict method within any instances for the defms
755 getCIids :: Bool -> [Id] -> [Id]
756 getCIids True ids = filter not_dict_or_defm ids
760 = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
762 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
763 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
765 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
766 cis_here_list = bagToList cis_here
768 -- pprTrace "getCIs:"
769 -- (ppHang (ppBesides [ppStr "{",
770 -- interppSP PprDebug ids,
772 -- 4 (ppAboves (map pprCI cis_here_list)))
773 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
775 dumpCIs :: Bag CallInstance -- The call instances
776 -> Bool -- True <=> top level bound Ids
777 -> Bool -- True <=> dict bindings to be floated (specBind only)
778 -> [CallInstance] -- Call insts for bound ids (instBind only)
779 -> [Id] -- Bound ids *new*
780 -> [Id] -- Full bound ids: includes dumped dicts
781 -> Bag CallInstance -- Kept call instances
783 -- CIs are dumped if:
784 -- 1) they are a CI for one of the bound ids, or
785 -- 2) they mention any of the dicts in a local unfloated binding
787 -- For top-level bindings we allow the call instances to
788 -- float past a dict bind and place all the top-level binds
789 -- in a *global* Rec.
790 -- We leave it to the simplifier will sort it all out ...
792 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
793 = (if not (isEmptyBag cis_of_bound_id) &&
794 not (isEmptyBag cis_of_bound_id_without_inst_cis)
796 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
797 " (may be a non-HM recursive call)\n")
798 (ppHang (ppBesides [ppStr "{",
799 interppSP PprDebug bound_ids,
801 4 (ppAboves [ppStr "Dumping CIs:",
802 ppAboves (map pprCI (bagToList cis_of_bound_id)),
803 ppStr "Instantiating CIs:",
804 ppAboves (map pprCI inst_cis)]))
806 if top_lev || floating then
809 (if not (isEmptyBag cis_dump_unboxed)
810 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
811 (ppHang (ppBesides [ppStr "{",
812 interppSP PprDebug full_ids,
814 4 (ppAboves (map pprCI (bagToList cis_dump))))
816 cis_keep_not_bound_id
819 (cis_of_bound_id, cis_not_bound_id)
820 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
822 (cis_dump, cis_keep_not_bound_id)
823 = partitionBag ok_to_dump_ci cis_not_bound_id
825 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
826 = any (\ i -> i `elementOfIdSet` fv_set) full_ids
828 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
829 have_inst_ci ci = any (eqCI_tys ci) inst_cis
831 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
835 Any call instances of a bound_id can be safely dumped, because any
836 recursive calls should be at the same instance as the parent instance.
838 letrec f = /\a -> \x::a -> ...(f t x')...
840 Here, the type, t, at which f is used in its own RHS should be
841 just "a"; that is, the recursive call is at the same type as
842 the original call. That means that when specialising f at some
843 type, say Int#, we shouldn't find any *new* instances of f
844 arising from specialising f's RHS. The only instance we'll find
845 is another call of (f Int#).
847 We check this in dumpCIs by passing in all the instantiated call
848 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
849 for which there is no such instance.
851 We also report CIs dumped due to a bound dictionary arg if they
852 contain unboxed types.
854 %************************************************************************
856 \subsubsection[TyConInstances]{@TyConInstances@ data type}
858 %************************************************************************
862 = TyConInstance TyCon -- Type Constructor
863 [Maybe Type] -- Applied to these specialising types
865 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
866 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
867 = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
869 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
870 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
871 = cmpUniTypeMaybeList tys1 tys2
873 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
874 singleTyConI ty_con spec_tys
875 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
877 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
878 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
880 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
881 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
883 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
884 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
886 (tycon_cis_local, tycon_cis_global)
887 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
888 tycon_cis_local_list = bagToList tycon_cis_local
890 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
894 %************************************************************************
896 \subsubsection[UsageDetails]{@UsageDetails@ data type}
898 %************************************************************************
903 (Bag CallInstance) -- The collection of call-instances
904 (Bag TyConInstance) -- Constructor call-instances
905 [DictBindDetails] -- Dictionary bindings in data-dependence order!
906 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
907 Int -- no. of spec calls
908 Int -- no. of spec insts
911 The DictBindDetails are fully processed; their call-instance information is
912 incorporated in the call-instances of the
913 UsageDetails which includes the DictBindDetails. The free vars in a usage details
914 will *include* the binders of the DictBind details.
916 A @DictBindDetails@ contains bindings for dictionaries *only*.
921 [Id] -- Main binders, originally visible in scope of binding (cloned)
922 CoreBinding -- Fully processed
923 FreeVarsSet -- Free in binding group (cloned)
924 FreeTyVarsSet -- Free in binding group
928 emptyUDs :: UsageDetails
929 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
930 unionUDList :: [UsageDetails] -> UsageDetails
932 -- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
933 tickSpecInsts :: UsageDetails -> UsageDetails
935 -- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
936 -- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
938 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
939 = UsageDetails cis ty_cis dbs fvs c (i+1)
941 emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
943 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
944 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
945 (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
946 -- The append here is really redundant, since the bindings don't
947 -- scope over each other. ToDo.
949 unionUDList = foldr unionUDs emptyUDs
951 singleFvUDs (VarArg v) | not (isImportedId v)
952 = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
956 singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
958 dumpDBs :: [DictBindDetails]
959 -> Bool -- True <=> top level bound Ids
960 -> [TyVar] -- TyVars being bound (cloned)
961 -> [Id] -- Ids being bound (cloned)
962 -> FreeVarsSet -- Fvs of body
963 -> ([CoreBinding], -- These ones have to go here
964 [DictBindDetails], -- These can float further
965 [Id], -- Incoming list + names of dicts bound here
966 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
969 -- It is just to complex to try to float top-level
970 -- dict bindings with constant methods, inst methods,
971 -- auxillary derived instance defns and user instance
972 -- defns all getting in the way.
973 -- So we dump all dbinds as soon as we get to the top
974 -- level and place them in a *global* Rec.
975 -- We leave it to the simplifier will sort it all out ...
977 dumpDBs [] top_lev bound_tyvars bound_ids fvs
978 = ([], [], bound_ids, fvs)
980 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
981 top_lev bound_tyvars bound_ids fvs
983 || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
984 || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
985 = let -- Ha! Dump it!
986 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
987 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
989 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
991 | otherwise -- This one can float out further
993 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
994 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
996 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
1000 dumpUDs :: UsageDetails
1001 -> Bool -- True <=> top level bound Ids
1002 -> Bool -- True <=> dict bindings to be floated (specBind only)
1003 -> [CallInstance] -- Call insts for bound Ids (instBind only)
1004 -> [Id] -- Ids which are just being bound; *new*
1005 -> [TyVar] -- TyVars which are just being bound
1006 -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
1007 UsageDetails) -- The above bindings removed, and
1008 -- any call-instances which mention the ids dumped too
1010 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
1012 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
1013 = dumpDBs dbs top_lev tvs bound_ids fvs
1014 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
1015 fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
1017 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
1021 addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
1022 -> UsageDetails -- The usage to augment
1024 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
1025 (UsageDetails cis tycon_cis dbs fvs c i)
1026 = UsageDetails (db_cis `unionBags` cis)
1027 (db_tycon_cis `unionBags` tycon_cis)
1028 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
1030 -- NB: We ignore counts from dictbinds since it is not user code
1032 -- The free tyvars of the dictionary bindings should really be
1033 -- gotten from the RHSs, but I'm pretty sure it's good enough just
1034 -- to look at the type of the dictionary itself.
1035 -- Doing the proper job would entail keeping track of free tyvars as
1036 -- well as free vars, which would be a bore.
1037 db_ftvs = tyVarsOfTypes (map idType dbinders)
1040 %************************************************************************
1042 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
1044 %************************************************************************
1046 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
1048 1) (NoLift LitArg l) : an Id which is bound to a literal
1050 2) (NoLift LitArg l) : an Id bound to a "new" Id
1051 The new Id is a possibly-type-specialised clone of the original
1053 3) Lifted lifted_id unlifted_id :
1055 This indicates that the original Id has been specialised to an
1056 unboxed value which must be lifted (see "Unboxed bindings" above)
1057 @unlifted_id@ is the unboxed clone of the original Id
1058 @lifted_id@ is a *lifted* version of the original Id
1060 When you lookup Ids which are Lifted, you have to insert a case
1061 expression to un-lift the value (done with @bindUnlift@)
1063 You also have to insert a case to lift the value in the binding
1064 (done with @liftExpr@)
1068 type SpecIdEnv = IdEnv CloneInfo
1071 = NoLift CoreArg -- refers to cloned id or literal
1073 | Lifted Id -- lifted, cloned id
1074 Id -- unlifted, cloned id
1078 %************************************************************************
1080 \subsection[specialise-data]{Data returned by specialiser}
1082 %************************************************************************
1087 -- True <=> Specialisation performed
1089 -- False <=> Specialisation completed with errors
1092 -- Local tycons declared in this module
1095 -- Those in-scope data types for which we want to
1096 -- generate code for their constructors.
1097 -- Namely: data types declared in this module +
1098 -- any big tuples used in this module
1099 -- The initial (and default) value is the local tycons
1101 (FiniteMap TyCon [(Bool, [Maybe Type])])
1102 -- TyCon specialisations to be generated
1103 -- We generate specialialised code (Bool=True) for data types
1104 -- defined in this module and any tuples used in this module
1105 -- The initial (and default) value is the specialisations
1106 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1107 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1109 (Bag (Id,[Maybe Type]))
1110 -- Imported specialisation errors
1111 (Bag (Id,[Maybe Type]))
1112 -- Imported specialisation warnings
1113 (Bag (TyCon,[Maybe Type]))
1114 -- Imported TyCon specialisation errors
1116 initSpecData local_tycons tycon_specs
1117 = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1120 ToDo[sansom]: Transformation data to process specialisation requests.
1122 %************************************************************************
1124 \subsection[specProgram]{Specialising a core program}
1126 %************************************************************************
1129 specProgram :: UniqSupply
1130 -> [CoreBinding] -- input ...
1132 -> ([CoreBinding], -- main result
1133 SpecialiseData) -- result specialise data
1135 specProgram uniqs binds
1136 (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1137 = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
1138 (final_binds, tycon_specs_list,
1139 UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1141 used_conids = filter isDataCon (uniqSetToList fvs)
1142 used_tycons = map dataConTyCon used_conids
1143 used_gen = filter isLocalGenTyCon used_tycons
1144 gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
1146 result_specs = addListToFM_C (++) init_specs tycon_specs_list
1148 uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
1149 cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1150 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1151 cis_warn = init_warn `unionBags` listToBag cis_other
1152 cis_errs = init_errs `unionBags` listToBag cis_unboxed
1154 uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
1155 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1156 tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
1158 no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
1159 && (not opt_SpecialiseImports || isEmptyBag cis_warn)
1161 (if opt_D_simplifier_stats then
1162 pprTrace "\nSpecialiser Stats:\n" (ppAboves [
1163 ppBesides [ppStr "SpecCalls ", ppInt spec_calls],
1164 ppBesides [ppStr "SpecInsts ", ppInt spec_insts],
1169 SpecData True no_errs local_tycons gen_tycons result_specs
1170 cis_errs cis_warn tycis_errs)
1172 specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
1173 = panic "Specialise:specProgram: specialiser called more than once"
1175 -- It may be possible safely to call the specialiser more than once,
1176 -- but I am not sure there is any benefit in doing so (Patrick)
1178 -- ToDo: What about unfoldings performed after specialisation ???
1181 %************************************************************************
1183 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1185 %************************************************************************
1187 In the specialiser we just collect up the specialisations which will
1188 be required. We don't create the specialised constructors in
1189 Core. These are only introduced when we convert to StgSyn.
1191 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1194 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1195 -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1197 specTyConsAndScope scopeM
1198 = scopeM `thenSM` \ (binds, scope_uds) ->
1200 (tycons_cis, gotci_scope_uds)
1201 = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds
1203 tycon_specs_list = collectTyConSpecs tycons_cis
1205 (if opt_SpecialiseTrace && not (null tycon_specs_list) then
1206 pprTrace "Specialising TyCons:\n"
1207 (ppAboves [ if not (null specs) then
1208 ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
1209 4 (ppAboves (map pp_specs specs))
1211 | (tycon, specs) <- tycon_specs_list])
1213 returnSM (binds, tycon_specs_list, gotci_scope_uds)
1216 collectTyConSpecs []
1218 collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1219 = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1221 (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1222 uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1223 tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1225 pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
1229 %************************************************************************
1231 \subsection[specTopBinds]{Specialising top-level bindings}
1233 %************************************************************************
1236 specTopBinds :: [CoreBinding]
1237 -> SpecM ([CoreBinding], UsageDetails)
1240 = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1242 -- Add bindings for floated dbinds and collect fvs
1243 -- In actual fact many of these bindings are dead code since dict
1244 -- arguments are dropped when a specialised call is created
1245 -- The simplifier should be able to cope ...
1247 (dbinders_s, dbinds, dfvs_s)
1248 = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1250 full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
1251 fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
1253 -- It is just to complex to try to sort out top-level dependencies
1254 -- So we just place all the top-level binds in a *global* Rec and
1255 -- leave it to the simplifier to sort it all out ...
1258 returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1261 spec_top_binds (first_bind:rest_binds)
1262 = specBindAndScope True first_bind (
1263 spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1264 returnSM (ItsABinds rest_binds, rest_uds)
1265 ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1266 returnSM (first_binds ++ rest_binds, all_uds)
1269 = returnSM ([], emptyUDs)
1272 %************************************************************************
1274 \subsection[specExpr]{Specialising expressions}
1276 %************************************************************************
1279 specExpr :: CoreExpr
1280 -> [CoreArg] -- The arguments:
1281 -- TypeArgs are speced
1282 -- ValArgs are unprocessed
1283 -> SpecM (CoreExpr, -- Result expression with specialised versions installed
1284 UsageDetails)-- Details of usage of enclosing binders in the result
1287 specExpr (Var v) args
1288 = lookupId v `thenSM` \ vlookup ->
1291 -> -- Binding has been lifted, need to extract un-lifted value
1292 -- NB: a function binding will never be lifted => args always null
1293 -- i.e. no call instance required or call to be constructed
1295 returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
1297 NoLift vatom@(VarArg new_v)
1298 -> mapSM specOutArg args `thenSM` \ arg_info ->
1299 mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
1300 mkCall new_v arg_info `thenSM` \ call ->
1302 uds = unionUDList [call_uds,
1304 unionUDList [uds | (_,uds,_) <- arg_info]
1307 returnSM (call, {- tickSpecCall speced -} uds)
1309 specExpr expr@(Lit _) null_args
1310 = ASSERT (null null_args)
1311 returnSM (expr, emptyUDs)
1313 specExpr (Con con args) null_args
1314 = ASSERT (null null_args)
1316 (targs, vargs) = partition_args args
1318 mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
1319 mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
1320 mkTyConInstance con tys `thenSM` \ con_uds ->
1321 returnSM (applyBindUnlifts unlifts (Con con (targs ++ vargs)),
1322 unionUDList args_uds_s `unionUDs` con_uds)
1324 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
1325 = ASSERT (null null_args)
1327 (targs, vargs) = partition_args args
1330 mapSM specTy arg_tys `thenSM` \ arg_tys ->
1331 specTy res_ty `thenSM` \ res_ty ->
1332 mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
1333 returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) vargs),
1334 unionUDList args_uds_s)
1336 specExpr (Prim prim args) null_args
1337 = ASSERT (null null_args)
1339 (targs, vargs) = partition_args args
1341 mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
1342 mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
1343 -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
1344 returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)),
1345 unionUDList args_uds_s {-`unionUDs` prim_uds-} )
1349 specPrimOp :: PrimOp
1355 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1356 -- and/or chooses PrimOp specialised to any unboxed tys
1357 -- Errors are dealt with by returning a PrimOp call instance
1358 -- which will result in a cis_errs message
1360 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1364 specExpr (App fun arg) args
1365 = -- If TyArg, arg will be processed; otherwise, left alone
1366 preSpecArg arg `thenSM` \ new_arg ->
1367 specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
1368 returnSM (expr, uds)
1370 specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
1371 = lookup_arg arg `thenSM` \ arg ->
1372 bindId binder arg (specExpr body args)
1374 lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1375 lookup_arg (VarArg v) = lookupId v
1377 specExpr (Lam (ValBinder binder) body) []
1378 = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1379 returnSM (Lam (ValBinder binder) body, uds)
1381 specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
1382 = -- Type lambda with argument; argument already spec'd
1383 bindTyVar tyvar ty ( specExpr body args )
1385 specExpr (Lam (TyBinder tyvar) body) []
1387 cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
1388 bindTyVar tyvar (mkTyVarTy new_tyvar) (
1389 specExpr body [] `thenSM` \ (body, body_uds) ->
1391 (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1393 returnSM (Lam (TyBinder new_tyvar)
1394 (mkCoLetsNoUnboxed binds_here body),
1398 specExpr (Case scrutinee alts) args
1399 = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
1400 specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
1401 returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
1403 scrutinee_type = coreExprType scrutinee
1405 specExpr (Let bind body) args
1406 = specBindAndScope False bind (
1407 specExpr body args `thenSM` \ (body, body_uds) ->
1408 returnSM (ItsAnExpr body, body_uds)
1409 ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1410 returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1412 specExpr (SCC cc expr) args
1413 = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
1414 mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1417 = if squashableDictishCcExpr cc expr -- can toss the _scc_
1421 returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1422 unionUDList args_uds_s `unionUDs` expr_uds)
1424 specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
1426 -- ToDo: This may leave some unspec'd dictionaries!!
1429 %************************************************************************
1431 \subsubsection{Specialising a lambda}
1433 %************************************************************************
1436 specLambdaOrCaseBody :: [Id] -- The binders
1437 -> CoreExpr -- The body
1438 -> [CoreArg] -- Its args
1439 -> SpecM ([Id], -- New binders
1440 CoreExpr, -- New body
1443 specLambdaOrCaseBody bound_ids body args
1444 = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
1445 bindIds bound_ids clone_infos (
1447 specExpr body args `thenSM` \ (body, body_uds) ->
1450 -- Dump any dictionary bindings (and call instances)
1451 -- from the scope which mention things bound here
1452 (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1454 returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1457 -- ToDo: Opportunity here to common-up dictionaries with same type,
1458 -- thus avoiding recomputation.
1461 A variable bound in a lambda or case is normally monomorphic so no
1462 specialised versions will be required. This is just as well since we
1463 do not know what code to specialise!
1465 Unfortunately this is not always the case. For example a class Foo
1466 with polymorphic methods gives rise to a dictionary with polymorphic
1467 components as follows:
1474 instance Foo Int where
1482 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1483 d.Foo.Int = (op1_Int, op2_Int)
1485 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1487 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1490 N.B. The type of the dictionary is not Hindley Milner!
1492 Now we must specialise op1 at {* Int#} which requires a version of
1493 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1494 not have access to its code to create the specialised version.
1496 If we specialise on overloaded types as well we specialise op1 at
1497 {Int Int#} d.Foo.Int:
1499 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1501 Though this is still invalid, after further simplification we get:
1503 op1_Int_Int# = opInt1 {Int#}
1505 Another round of specialisation will result in the specialised
1506 version of op1Int being called directly.
1508 For now we PANIC if a polymorphic lambda/case bound variable is found
1509 in a call instance with an unboxed type. Other call instances, arising
1510 from overloaded type arguments, are discarded since the unspecialised
1511 version extracted from the method can be called as normal.
1513 ToDo: Implement and test second round of specialisation.
1516 %************************************************************************
1518 \subsubsection{Specialising case alternatives}
1520 %************************************************************************
1524 specAlts (AlgAlts alts deflt) scrutinee_ty args
1525 = mapSM specTy ty_args `thenSM` \ ty_args ->
1526 mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
1527 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1528 returnSM (AlgAlts alts deflt,
1529 unionUDList alts_uds_s `unionUDs` deflt_uds)
1531 -- We use ty_args of scrutinee type to identify specialisation of
1534 (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
1535 getAppDataTyConExpandingDicts scrutinee_ty
1537 specAlgAlt ty_args (con,binders,rhs)
1538 = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
1539 mkTyConInstance con ty_args `thenSM` \ con_uds ->
1540 returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1542 specAlts (PrimAlts alts deflt) scrutinee_ty args
1543 = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
1544 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1545 returnSM (PrimAlts alts deflt,
1546 unionUDList alts_uds_s `unionUDs` deflt_uds)
1548 specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
1549 returnSM ((lit,rhs), uds)
1552 specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
1553 specDeflt (BindDefault binder rhs) args
1554 = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
1555 returnSM (BindDefault binder rhs, uds)
1559 %************************************************************************
1561 \subsubsection{Specialising an atom}
1563 %************************************************************************
1566 partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
1568 = span is_ty_arg args
1570 is_ty_arg (TyArg _) = True
1574 preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else
1576 preSpecArg (TyArg ty)
1577 = specTy ty `thenSM` \ new_ty ->
1578 returnSM (TyArg new_ty)
1580 preSpecArg other = returnSM other
1582 --------------------
1583 specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
1584 CoreExpr -> CoreExpr)
1586 specValArg (LitArg lit)
1587 = returnSM (LitArg lit, emptyUDs, id)
1589 specValArg (VarArg v)
1590 = lookupId v `thenSM` \ vlookup ->
1593 -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
1596 -> returnSM (vatom, singleFvUDs vatom, id)
1600 specTyArg (TyArg ty)
1601 = specTy ty `thenSM` \ new_ty ->
1602 returnSM (TyArg new_ty, new_ty)
1605 specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
1606 CoreExpr -> CoreExpr)
1608 specOutArg (TyArg ty) -- already speced; no action
1609 = returnSM (TyArg ty, emptyUDs, id)
1611 specOutArg other_arg -- unprocessed; spec the atom
1612 = specValArg other_arg
1616 %************************************************************************
1618 \subsubsection{Specialising bindings}
1620 %************************************************************************
1622 A classic case of when having a polymorphic recursive function would help!
1625 data BindsOrExpr = ItsABinds [CoreBinding]
1626 | ItsAnExpr CoreExpr
1631 :: Bool -- True <=> a top level group
1632 -> CoreBinding -- As yet unprocessed
1633 -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
1634 -> SpecM ([CoreBinding], -- Processed
1635 BindsOrExpr, -- Combined result
1636 UsageDetails) -- Usage details of the whole lot
1638 specBindAndScope top_lev bind scopeM
1639 = cloneLetBinders top_lev (is_rec bind) binders
1640 `thenSM` \ (new_binders, clone_infos) ->
1642 -- Two cases now: either this is a bunch of local dictionaries,
1643 -- in which case we float them; or its a bunch of other values,
1644 -- in which case we see if they correspond to any call-instances
1645 -- we have from processing the scope
1647 if not top_lev && all (isDictTy . idType) binders
1649 -- Ha! A group of local dictionary bindings
1651 bindIds binders clone_infos (
1653 -- Process the dictionary bindings themselves
1654 specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
1656 -- Process their scope
1657 scopeM `thenSM` \ (thing, scope_uds) ->
1659 -- Add the bindings to the current stuff
1660 final_uds = addDictBinds new_binders bind rhs_uds scope_uds
1662 returnSM ([], thing, final_uds)
1665 -- Ho! A group of bindings
1667 fixSM (\ ~(_, _, _, rec_spec_infos) ->
1669 bindSpecIds binders clone_infos rec_spec_infos (
1670 -- It's ok to have new binders in scope in
1671 -- non-recursive decls too, cos name shadowing is gone by now
1673 -- Do the scope of the bindings
1674 scopeM `thenSM` \ (thing, scope_uds) ->
1676 (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
1678 equiv_ciss = equivClasses cmpCI_tys call_insts
1679 inst_cis = map head equiv_ciss
1682 -- Do the bindings themselves
1683 specBind top_lev False new_binders inst_cis bind
1684 `thenSM` \ (spec_bind, spec_uds) ->
1686 -- Create any necessary instances
1687 instBind top_lev new_binders bind equiv_ciss inst_cis
1688 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
1691 -- NB: dumpUDs only worries about new_binders since the free var
1692 -- stuff only records free new_binders
1693 -- The spec_ids only appear in SpecInfos and final speced calls
1695 -- Build final binding group and usage details
1696 (final_binds, final_uds)
1698 -- For a top-level binding we have to dumpUDs from
1699 -- spec_uds and inst_uds and scope_uds creating
1700 -- *global* dict bindings
1702 (scope_dict_binds, final_scope_uds)
1703 = dumpUDs gotci_scope_uds True False [] new_binders []
1704 (spec_dict_binds, final_spec_uds)
1705 = dumpUDs spec_uds True False inst_cis new_binders []
1706 (inst_dict_binds, final_inst_uds)
1707 = dumpUDs inst_uds True False inst_cis new_binders []
1709 ([spec_bind] ++ inst_binds ++ scope_dict_binds
1710 ++ spec_dict_binds ++ inst_dict_binds,
1711 final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
1713 -- For a local binding we only have to dumpUDs from
1714 -- scope_uds since the UDs from spec_uds and inst_uds
1715 -- have already been dumped by specBind and instBind
1717 (scope_dict_binds, final_scope_uds)
1718 = dumpUDs gotci_scope_uds False False [] new_binders []
1720 ([spec_bind] ++ inst_binds ++ scope_dict_binds,
1721 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
1723 -- inst_uds comes last, because there may be dict bindings
1724 -- floating outward in scope_uds which are mentioned
1725 -- in the call-instances, and hence in spec_uds.
1726 -- This ordering makes sure that the precedence order
1727 -- among the dict bindings finally floated out is maintained.
1729 returnSM (final_binds, thing, final_uds, spec_infos)
1731 ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
1732 returnSM (binds, thing, final_uds)
1734 binders = bindersOf bind
1736 is_rec (NonRec _ _) = False
1741 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
1743 -> SpecM (CoreBinding, UsageDetails)
1744 -- The UsageDetails returned has already had stuff to do with this group
1745 -- of binders deleted; that's why new_binders is passed in.
1746 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
1747 = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
1748 `thenSM` \ ((binder,rhs), rhs_uds) ->
1749 returnSM (NonRec binder rhs, rhs_uds)
1751 specBind top_lev floating new_binders inst_cis (Rec pairs)
1752 = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
1753 `thenSM` \ (pairs, rhs_uds_s) ->
1754 returnSM (Rec pairs, unionUDList rhs_uds_s)
1757 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
1759 -> SpecM ((Id,CoreExpr), UsageDetails)
1761 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
1762 = lookupId binder `thenSM` \ blookup ->
1763 specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
1765 specid_maybe_maybe = isSpecPragmaId_maybe binder
1766 is_specid = maybeToBool specid_maybe_maybe
1767 Just specinfo_maybe = specid_maybe_maybe
1768 specid_with_info = maybeToBool specinfo_maybe
1769 Just spec_info = specinfo_maybe
1771 -- If we have a SpecInfo stored in a SpecPragmaId binder
1772 -- it will contain a SpecInfo with an explicit SpecId
1773 -- We add the explicit ci to the usage details
1774 -- Any ordinary cis for orig_id (there should only be one)
1775 -- will be ignored later
1778 = if is_specid && specid_with_info then
1780 (SpecInfo spec_tys _ spec_id) = spec_info
1781 Just (orig_id, _) = isSpecId_maybe spec_id
1783 ASSERT(toplevelishId orig_id) -- must not be cloned!
1784 explicitCI orig_id spec_tys spec_info
1788 -- For a local binding we dump the usage details, creating
1789 -- any local dict bindings required
1790 -- At the top-level the uds will be dumped in specBindAndScope
1791 -- and the dict bindings made *global*
1793 (local_dict_binds, final_uds)
1794 = if not top_lev then
1795 dumpUDs rhs_uds False floating inst_cis new_binders []
1800 Lifted lift_binder unlift_binder
1801 -> -- We may need to record an unboxed instance of
1802 -- the _Lift data type in the usage details
1803 mkTyConInstance liftDataCon [idType unlift_binder]
1804 `thenSM` \ lift_uds ->
1805 returnSM ((lift_binder,
1806 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
1807 final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
1809 NoLift (VarArg binder)
1810 -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
1811 final_uds `unionUDs` pragma_uds)
1815 %************************************************************************
1817 \subsection{@instBind@}
1819 %************************************************************************
1822 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
1824 = returnSM ([], emptyUDs, [])
1826 | all same_overloading other_binders
1827 = -- For each call_inst, build an instance
1828 mapAndUnzip3SM do_this_class equiv_ciss
1829 `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
1831 -- Add in the remaining UDs
1832 returnSM (catMaybes inst_binds,
1833 unionUDList inst_uds_s,
1837 | otherwise -- Incompatible overloadings; see below by same_overloading
1838 = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
1839 then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
1841 then pprTrace "dumpCIs: not same overloading ... top level \n"
1843 ) (ppHang (ppBesides [ppStr "{",
1844 interppSP PprDebug new_ids,
1846 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids),
1847 ppAboves (map pprCI (concat equiv_ciss))]))
1848 (returnSM ([], emptyUDs, []))
1851 (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
1852 tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
1854 no_of_tyvars = length tyvar_tmpls
1855 no_of_dicts = length class_tyvar_pairs
1857 do_this_class equiv_cis
1858 = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
1860 (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
1861 do_cis = head (normal_cis ++ explicit_cis)
1862 -- must choose a normal_cis in preference since dict_args will
1863 -- not be defined for an explicit_cis
1865 -- same_overloading tests whether the types of all the binders
1866 -- are "compatible"; ie have the same type and dictionary abstractions
1867 -- Almost always this is the case, because a recursive group is abstracted
1868 -- all together. But, it can happen that it ain't the case, because of
1869 -- code generated from instance decls:
1872 -- dfun.Foo.Int :: (forall a. a -> Int, Int)
1873 -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
1875 -- const.op1.Int :: forall a. a -> Int
1876 -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
1878 -- const.op2.Int :: Int
1879 -- const.op2.Int = 3
1881 -- Note that the first two defns have different polymorphism, but they are
1882 -- mutually recursive!
1884 same_overloading :: Id -> Bool
1886 = no_of_tyvars == length this_id_tyvars
1887 -- Same no of tyvars
1888 && no_of_dicts == length this_id_class_tyvar_pairs
1889 -- Same no of vdicts
1890 && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
1891 && length class_tyvar_pairs == length this_id_class_tyvar_pairs
1894 (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
1895 tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
1897 same_ov (clas1,tyvar1) (clas2,tyvar2)
1899 tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
1903 - a call instance eg f [t1,t2,t3] [d1,d2]
1904 - the rhs of the function eg orig_rhs
1905 - a constraint vector, saying which of eg [T,F,T]
1906 the functions type args are constrained
1909 We return a new definition
1911 f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2
1913 The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
1915 SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
1917 Based on this SpecInfo, a call instance of f
1919 ...(f t1 t2 t3 d1 d2)...
1921 should get replaced by
1925 (But that is the business of @mkCall@.)
1928 mkOneInst :: CallInstance
1929 -> [CallInstance] -- Any explicit cis for this inst
1930 -> Int -- No of dicts to specialise
1931 -> Bool -- Top level binders?
1932 -> [CallInstance] -- Instantiated call insts for binders
1933 -> [Id] -- New binders
1934 -> CoreBinding -- Unprocessed
1935 -> SpecM (Maybe CoreBinding, -- Instantiated version of input
1937 [Maybe SpecInfo] -- One for each id in the original binding
1940 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
1941 no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
1942 = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
1943 `thenSM` \ spec_ids ->
1944 newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
1946 -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
1947 -- which correspond to unspeciailsed args
1949 (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
1952 args = map TyArg arg_tys ++ dict_args
1954 (new_id:_) = new_ids
1955 (spec_id:_) = spec_ids
1957 do_bind (NonRec orig_id rhs)
1958 = do_one_rhs (spec_id, new_id, (orig_id,rhs))
1959 `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
1961 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
1962 Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
1965 = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
1966 `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
1967 returnSM (Just (Rec (catMaybes maybe_pairs)),
1968 unionUDList rhss_uds_s, spec_infos)
1970 do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
1972 -- Avoid duplicating a spec which has already been created ...
1973 -- This can arise in a Rec involving a dfun for which a
1974 -- a specialised instance has been created but specialisation
1975 -- "required" by one of the other Ids in the Rec
1976 | top_lev && maybeToBool lookup_orig_spec
1977 = (if opt_SpecialiseTrace
1978 then trace_nospec " Exists: " orig_id
1981 returnSM (Nothing, emptyUDs, Nothing)
1984 -- Check for a (single) explicit call instance for this id
1985 | not (null explicit_cis_for_this_id)
1986 = ASSERT (length explicit_cis_for_this_id == 1)
1987 (if opt_SpecialiseTrace
1988 then trace_nospec " Explicit: " explicit_id
1991 returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
1994 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
1996 = ASSERT (no_of_dicts_to_specialise == length dict_args)
1997 specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
1999 -- For a local binding we dump the usage details, creating
2000 -- any local dict bindings required
2001 -- At the top-level the uds will be dumped in specBindAndScope
2002 -- and the dict bindings made *global*
2004 (local_dict_binds, final_uds)
2005 = if not top_lev then
2006 dumpUDs inst_uds False False inst_cis new_ids []
2010 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
2012 if isUnboxedType (idType spec_id) then
2013 ASSERT (null poly_tyvars)
2014 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2015 mkTyConInstance liftDataCon [idType unlift_spec_id]
2016 `thenSM` \ lift_uds ->
2017 returnSM (Just (lift_spec_id,
2018 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
2019 tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
2021 returnSM (Just (spec_id,
2022 mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
2023 tickSpecInsts final_uds, spec_info)
2025 lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
2027 explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
2028 [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
2029 SpecInfo _ _ explicit_id = explicit_spec_info
2031 trace_nospec :: String -> Id -> a -> a
2032 trace_nospec str spec_id
2034 (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys),
2035 ppStr "==>", ppr PprDebug spec_id])
2037 (if opt_SpecialiseTrace then
2038 pprTrace "Specialising:"
2039 (ppHang (ppBesides [ppStr "{",
2040 interppSP PprDebug new_ids,
2043 ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
2044 if isExplicitCI do_cis then ppNil else
2045 ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
2046 ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
2049 do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
2051 returnSM (maybe_inst_bind, inst_uds, spec_infos)
2054 pp_dict d = ppr_arg PprDebug d
2055 pp_ty t = pprParendGenType PprDebug t
2057 do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
2058 do_the_wotsit tyvars (Just ty) = (tyvars, ty)
2062 %************************************************************************
2064 \subsection[Misc]{Miscellaneous junk}
2066 %************************************************************************
2069 mkCallInstance :: Id
2071 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2072 -> SpecM UsageDetails
2074 mkCallInstance id new_id []
2077 mkCallInstance id new_id args
2079 -- No specialised versions for "error" and friends are req'd.
2080 -- This is a special case in core lint etc.
2085 -- No call instances for SuperDictSelIds
2086 -- These are a special case in mkCall
2088 | maybeToBool (isSuperDictSelId_maybe id)
2091 -- There are also no call instances for ClassOpIds
2092 -- However, we need to process it to get any second-level call
2093 -- instances for a ConstMethodId extracted from its SpecEnv
2097 spec_overloading = opt_SpecialiseOverloaded
2098 spec_unboxed = opt_SpecialiseUnboxed
2099 spec_all = opt_SpecialiseAll
2101 (tyvars, class_tyvar_pairs) = getIdOverloading id
2103 arg_res = take_type_args tyvars class_tyvar_pairs args
2104 enough_args = maybeToBool arg_res
2106 (Just (tys, dicts, rest_args)) = arg_res
2109 = (record, lookup, spec_tys)
2111 spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
2112 (mkConstraintVector id) tys
2114 record = any (not . isTyVarTy) (catMaybes spec_tys)
2116 lookup = lookupSpecEnv (getIdSpecialisation id) tys
2118 if (not enough_args) then
2119 pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
2120 (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args]))
2122 case record_spec id tys of
2124 -> -- pprTrace "CallInst:NotReqd\n"
2125 -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
2128 (True, Nothing, spec_tys)
2129 -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
2132 -- pprTrace "CallInst:Reqd\n"
2133 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2134 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
2135 -- ppCat (map (ppr PprDebug) dicts)]])
2136 (returnSM (singleCI new_id spec_tys dicts))
2138 (True, Just (spec_id, tys_left, toss), _)
2139 -> if maybeToBool (isConstMethodId_maybe spec_id) then
2140 -- If we got a const method spec_id see if further spec required
2141 -- NB: const method is top-level so spec_id will not be cloned
2142 case record_spec spec_id tys_left of
2144 -> -- pprTrace "CallInst:Exists\n"
2145 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2146 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2147 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2150 (True, Nothing, spec_tys)
2151 -> -- pprTrace "CallInst:Exists:Reqd\n"
2152 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2153 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2154 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2155 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
2156 -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
2157 (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
2159 (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
2160 -> -- pprTrace "CallInst:Exists:Exists\n"
2161 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2162 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2163 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2164 -- ppCat [ppStr "->", ppr PprDebug spec_spec_id,
2165 -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
2169 -- pprTrace "CallInst:Exists\n"
2170 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2171 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2172 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2176 take_type_args (_:tyvars) class_tyvar_pairs ((TyArg ty,_,_):args)
2177 = case (take_type_args tyvars class_tyvar_pairs args) of
2179 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2181 take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing
2183 take_type_args [] class_tyvar_pairs args
2184 = case (take_dict_args class_tyvar_pairs args) of
2186 Just (dicts, others) -> Just ([], dicts, others)
2188 take_dict_args (_:class_tyvar_pairs) ((dict,_,_):args) | isValArg dict
2189 = case (take_dict_args class_tyvar_pairs args) of
2191 Just (dicts, others) -> Just (dict:dicts, others)
2193 take_dict_args (_:class_tyvar_pairs) [] = Nothing
2195 take_dict_args [] args = Just ([], args)
2200 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2203 mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
2206 | maybeToBool (isSuperDictSelId_maybe new_id)
2207 && any isUnboxedType ty_args
2208 -- No specialisations for super-dict selectors
2209 -- Specialise unboxed calls to SuperDictSelIds by extracting
2210 -- the super class dictionary directly form the super class
2211 -- NB: This should be dead code since all uses of this dictionary should
2212 -- have been specialised. We only do this to keep core-lint happy.
2214 Just (_, super_class) = isSuperDictSelId_maybe new_id
2215 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2216 Nothing -> panic "Specialise:mkCall:SuperDictId"
2219 returnSM (False, Var super_dict_id)
2222 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2223 Nothing -> checkUnspecOK new_id ty_args (
2224 returnSM (False, unspec_call)
2227 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2229 -- It may be necessary to specialsie a constant method spec_id again
2230 (spec_id, tys_left, dicts_to_toss) =
2231 case (maybeToBool (isConstMethodId_maybe spec_id_1),
2232 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2233 (False, _ ) -> spec_1_details
2234 (True, Nothing) -> spec_1_details
2235 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2236 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2238 args_left = toss_dicts dicts_to_toss val_args
2240 checkSpecOK new_id ty_args spec_id tys_left (
2242 -- The resulting spec_id may be a top-level unboxed value
2243 -- This can arise for:
2244 -- 1) constant method values
2245 -- eq: class Num a where pi :: a
2246 -- instance Num Double# where pi = 3.141#
2247 -- 2) specilised overloaded values
2248 -- eq: i1 :: Num a => a
2249 -- i1 Int# d.Num.Int# ==> i1.Int#
2250 -- These top level defns should have been lifted.
2251 -- We must add code to unlift such a spec_id.
2253 if isUnboxedType (idType spec_id) then
2254 ASSERT (null tys_left && null args_left)
2255 if toplevelishId spec_id then
2256 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2257 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2258 (Var unlift_spec_id))
2260 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2261 (ppCat [ppr PprDebug new_id,
2262 ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
2264 ppr PprDebug spec_id])
2267 (vals_left, _, unlifts_left) = unzip3 args_left
2268 applied_tys = mkTyApp (Var spec_id) tys_left
2269 applied_vals = mkGenApp applied_tys vals_left
2271 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2274 (tys_and_vals, _, unlifts) = unzip3 args
2275 unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2278 -- ty_args is the types at the front of the arg list
2279 -- val_args is the rest of the arg-list
2281 (ty_args, val_args) = get args
2283 get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2284 get args = ([], args)
2287 -- toss_dicts chucks away dict args, checking that they ain't types!
2288 toss_dicts 0 args = args
2289 toss_dicts n ((a,_,_) : args)
2290 | isValArg a = toss_dicts (n-1) args
2295 checkUnspecOK :: Id -> [Type] -> a -> a
2296 checkUnspecOK check_id tys
2297 = if isLocallyDefined check_id && any isUnboxedType tys
2298 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2299 (ppCat [ppr PprDebug check_id,
2300 ppInterleave ppNil (map (pprParendGenType PprDebug) tys)])
2303 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2304 checkSpecOK check_id tys spec_id tys_left
2305 = if any isUnboxedType tys_left
2306 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2307 (ppAboves [ppCat [ppr PprDebug check_id,
2308 ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
2309 ppCat [ppr PprDebug spec_id,
2310 ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
2316 mkTyConInstance :: Id
2318 -> SpecM UsageDetails
2319 mkTyConInstance con tys
2320 = recordTyConInst con tys `thenSM` \ record_inst ->
2322 Nothing -- No TyCon instance
2323 -> -- pprTrace "NoTyConInst:"
2324 -- (ppCat [ppr PprDebug tycon, ppStr "at",
2325 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
2326 (returnSM (singleConUDs con))
2328 Just spec_tys -- Record TyCon instance
2329 -> -- pprTrace "TyConInst:"
2330 -- (ppCat [ppr PprDebug tycon, ppStr "at",
2331 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
2332 -- ppBesides [ppStr "(",
2333 -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
2335 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2337 tycon = dataConTyCon con
2341 recordTyConInst :: Id
2343 -> SpecM (Maybe [Maybe Type])
2345 recordTyConInst con tys
2347 spec_tys = specialiseConstrTys tys
2349 do_tycon_spec = maybeToBool (firstJust spec_tys)
2351 spec_exists = maybeToBool (lookupSpecEnv
2352 (getIdSpecialisation con)
2355 -- pprTrace "ConSpecExists?: "
2356 -- (ppAboves [ppStr (if spec_exists then "True" else "False"),
2357 -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
2358 (if (not spec_exists && do_tycon_spec)
2359 then returnSM (Just spec_tys)
2360 else returnSM Nothing)
2363 %************************************************************************
2365 \subsection[monad-Specialise]{Monad used in specialisation}
2367 %************************************************************************
2371 inherited: control flags and
2372 recordInst functions with flags cached
2374 environment mapping tyvars to types
2375 environment mapping Ids to Atoms
2377 threaded in and out: unique supply
2380 type TypeEnv = TyVarEnv Type
2389 = m nullTyVarEnv nullIdEnv uniqs
2391 returnSM :: a -> SpecM a
2392 thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
2393 fixSM :: (a -> SpecM a) -> SpecM a
2395 thenSM m k tvenv idenv us
2396 = case splitUniqSupply us of { (s1, s2) ->
2397 case (m tvenv idenv s1) of { r ->
2398 k r tvenv idenv s2 }}
2400 returnSM r tvenv idenv us = r
2402 fixSM k tvenv idenv us
2405 r = k r tvenv idenv us -- Recursive in r!
2408 The only interesting bit is figuring out the type of the SpecId!
2411 newSpecIds :: [Id] -- The id of which to make a specialised version
2412 -> [Maybe Type] -- Specialise to these types
2413 -> Int -- No of dicts to specialise
2416 newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
2417 = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2418 | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
2420 uniqs = getUniques (length new_ids) us
2421 spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2423 newTyVars :: Int -> SpecM [TyVar]
2424 newTyVars n tvenv idenv us
2425 = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
2428 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2429 binders, and build ``clones'' for them. The clones differ from the
2430 originals in three ways:
2432 (a) they have a fresh unique
2433 (b) they have the current type environment applied to their type
2434 (c) for Let binders which have been specialised to unboxed values
2435 the clone will have a lifted type
2437 As well as returning the list of cloned @Id@s they also return a list of
2438 @CloneInfo@s which the original binders should be bound to.
2441 cloneLambdaOrCaseBinders :: [Id] -- Old binders
2442 -> SpecM ([Id], [CloneInfo]) -- New ones
2444 cloneLambdaOrCaseBinders old_ids tvenv idenv us
2446 uniqs = getUniques (length old_ids) us
2448 unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
2450 clone_it old_id uniq
2451 = (new_id, NoLift (VarArg new_id))
2453 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2455 cloneLetBinders :: Bool -- Top level ?
2456 -> Bool -- Recursice
2457 -> [Id] -- Old binders
2458 -> SpecM ([Id], [CloneInfo]) -- New ones
2460 cloneLetBinders top_lev is_rec old_ids tvenv idenv us
2462 uniqs = getUniques (2 * length old_ids) us
2464 unzip (clone_them old_ids uniqs)
2466 clone_them [] [] = []
2468 clone_them (old_id:olds) (u1:u2:uniqs)
2471 NoLift (VarArg old_id)) : clone_rest
2473 -- Don't clone if it is a top-level thing. Why not?
2474 -- (a) we don't want to change the uniques
2476 -- (b) we don't have to be paranoid about name capture
2477 -- (c) the thing is polymorphic so no need to subst
2480 = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
2482 Lifted lifted_id unlifted_id) : clone_rest
2484 NoLift (VarArg new_id)) : clone_rest
2487 clone_rest = clone_them olds uniqs
2489 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2490 new_ty = idType new_id
2491 old_ty = idType old_id
2493 (lifted_id, unlifted_id) = mkLiftedId new_id u2
2496 cloneTyVarSM :: TyVar -> SpecM TyVar
2498 cloneTyVarSM old_tyvar tvenv idenv us
2502 cloneTyVar old_tyvar uniq -- new_tyvar
2504 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2506 bindId id val specm tvenv idenv us
2507 = specm tvenv (addOneToIdEnv idenv id val) us
2509 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2511 bindIds olds news specm tvenv idenv us
2512 = specm tvenv (growIdEnvList idenv (zip olds news)) us
2514 bindSpecIds :: [Id] -- Old
2515 -> [(CloneInfo)] -- New
2516 -> [[Maybe SpecInfo]] -- Corresponding specialisations
2517 -- Each sub-list corresponds to a different type,
2518 -- and contains one Maybe spec_info for each id
2522 bindSpecIds olds clones spec_infos specm tvenv idenv us
2523 = specm tvenv (growIdEnvList idenv old_to_clone) us
2525 old_to_clone = mk_old_to_clone olds clones spec_infos
2527 -- The important thing here is that we are *lazy* in spec_infos
2528 mk_old_to_clone [] [] _ = []
2529 mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2530 = (old, add_spec_info clone) :
2531 mk_old_to_clone rest_olds rest_clones spec_infos_rest
2533 add_spec_info (NoLift (VarArg new))
2534 = NoLift (VarArg (new `addIdSpecialisation`
2535 (mkSpecEnv spec_infos_this_id)))
2536 add_spec_info lifted
2537 = lifted -- no specialised instances for unboxed lifted values
2539 spec_infos_this_id = catMaybes (map head spec_infos)
2540 spec_infos_rest = map tail spec_infos
2543 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2545 bindTyVar tyvar ty specm tvenv idenv us
2546 = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2550 lookupId :: Id -> SpecM CloneInfo
2552 lookupId id tvenv idenv us
2553 = case lookupIdEnv idenv id of
2554 Nothing -> NoLift (VarArg id)
2559 specTy :: Type -> SpecM Type -- Apply the current type envt to the type
2561 specTy ty tvenv idenv us
2562 = applyTypeEnvToTy tvenv ty
2566 liftId :: Id -> SpecM (Id, Id)
2567 liftId id tvenv idenv us
2574 In other monads these @mapSM@ things are usually called @listM@.
2575 I think @mapSM@ is a much better name. The `2' and `3' variants are
2576 when you want to return two or three results, and get at them
2577 separately. It saves you having to do an (unzip stuff) right after.
2580 mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
2581 mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
2582 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2583 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2585 mapSM f [] = returnSM []
2586 mapSM f (x:xs) = f x `thenSM` \ r ->
2587 mapSM f xs `thenSM` \ rs ->
2590 mapAndUnzipSM f [] = returnSM ([],[])
2591 mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
2592 mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
2593 returnSM ((r1:rs1),(r2:rs2))
2595 mapAndUnzip3SM f [] = returnSM ([],[],[])
2596 mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
2597 mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
2598 returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2600 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2601 mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
2602 mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
2603 returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))