2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
7 #include "HsVersions.h"
20 import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
21 partitionBag, listToBag, bagToList
23 import Class ( GenClass{-instance Eq-} )
24 import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
25 opt_CompilingPrelude, opt_SpecialiseTrace,
26 opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
29 import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
31 import CoreUtils ( coreExprType, squashableDictishCcExpr )
32 import FiniteMap ( addListToFM_C )
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, IdEnv(..),
40 emptyIdSet, mkIdSet, unitIdSet,
41 elementOfIdSet, minusIdSet,
42 unionIdSets, unionManyIdSets, IdSet(..),
45 import Literal ( Literal{-instance Outputable-} )
46 import Maybes ( catMaybes, firstJust, maybeToBool )
47 import Outputable ( interppSP, isLocallyDefined, Outputable(..){-instance * []-} )
48 import PprStyle ( PprStyle(..) )
49 import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
50 GenType{-instance Outputable-}, GenTyVar{-ditto-},
53 import PrelInfo ( liftDataCon )
54 import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
55 ppInt, ppSP, ppInterleave, ppNil, Pretty(..)
57 import PrimOp ( PrimOp(..) )
59 import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyCon,
60 tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
62 import TyCon ( TyCon{-instance Eq-} )
63 import TyVar ( cloneTyVar,
64 elementOfTyVarSet, TyVarSet(..),
65 nullTyVarEnv, growTyVarEnvList, TyVarEnv(..),
66 GenTyVar{-instance Eq-}
68 import Unique ( Unique{-instance Eq-} )
69 import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
70 import UniqSupply ( splitUniqSupply, getUniques, getUnique )
71 import Util ( equivClasses, mapAccumL, assoc, zipWithEqual,
72 panic, pprTrace, pprPanic, assertPanic
78 data SpecInfo = SpecInfo [Maybe Type] Int Id
80 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
81 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
82 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
83 isClassOpId = panic "Specialise.isClassOpId (ToDo)"
84 isDictTy = panic "Specialise.isDictTy (ToDo)"
85 isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
86 isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
87 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
88 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
89 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
90 lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
91 mkPolySysTyVar = panic "Specialise.mkPolySysTyVar (ToDo)"
92 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
93 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
94 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
95 specialiseTy = panic "Specialise.specialiseTy (ToDo)"
98 %************************************************************************
100 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
102 %************************************************************************
104 These notes describe how we implement specialisation to eliminate
105 overloading, and optionally to eliminate unboxed polymorphism, and
108 The specialisation pass is a partial evaluator which works on Core
109 syntax, complete with all the explicit dictionary application,
110 abstraction and construction as added by the type checker. The
111 existing type checker remains largely as it is.
113 One important thought: the {\em types} passed to an overloaded
114 function, and the {\em dictionaries} passed are mutually redundant.
115 If the same function is applied to the same type(s) then it is sure to
116 be applied to the same dictionary(s)---or rather to the same {\em
117 values}. (The arguments might look different but they will evaluate
120 Second important thought: we know that we can make progress by
121 treating dictionary arguments as static and worth specialising on. So
122 we can do without binding-time analysis, and instead specialise on
123 dictionary arguments and no others.
132 and suppose f is overloaded.
134 STEP 1: CALL-INSTANCE COLLECTION
136 We traverse <body>, accumulating all applications of f to types and
139 (Might there be partial applications, to just some of its types and
140 dictionaries? In principle yes, but in practice the type checker only
141 builds applications of f to all its types and dictionaries, so partial
142 applications could only arise as a result of transformation, and even
143 then I think it's unlikely. In any case, we simply don't accumulate such
144 partial applications.)
146 There's a choice of whether to collect details of all *polymorphic* functions
147 or simply all *overloaded* ones. How to sort this out?
148 Pass in a predicate on the function to say if it is "interesting"?
149 This is dependent on the user flags: SpecialiseOverloaded
155 So now we have a collection of calls to f:
159 Notice that f may take several type arguments. To avoid ambiguity, we
160 say that f is called at type t1/t2 and t3/t4.
162 We take equivalence classes using equality of the *types* (ignoring
163 the dictionary args, which as mentioned previously are redundant).
165 STEP 3: SPECIALISATION
167 For each equivalence class, choose a representative (f t1 t2 d1 d2),
168 and create a local instance of f, defined thus:
170 f@t1/t2 = <f_rhs> t1 t2 d1 d2
172 (f_rhs presumably has some big lambdas and dictionary lambdas, so lots
173 of simplification will now result.) Then we should recursively do
176 The new id has its own unique, but its print-name (if exported) has
177 an explicit representation of the instance types t1/t2.
179 Add this new id to f's IdInfo, to record that f has a specialised version.
181 Before doing any of this, check that f's IdInfo doesn't already
182 tell us about an existing instance of f at the required type/s.
183 (This might happen if specialisation was applied more than once, or
184 it might arise from user SPECIALIZE pragmas.)
188 Wait a minute! What if f is recursive? Then we can't just plug in
189 its right-hand side, can we?
191 But it's ok. The type checker *always* creates non-recursive definitions
192 for overloaded recursive functions. For example:
194 f x = f (x+x) -- Yes I know its silly
198 f a (d::Num a) = let p = +.sel a d
200 letrec fl (y::a) = fl (p y y)
204 We still have recusion for non-overloadd functions which we
205 speciailise, but the recursive call should get speciailised to the
206 same recursive version.
212 All this is crystal clear when the function is applied to *constant
213 types*; that is, types which have no type variables inside. But what if
214 it is applied to non-constant types? Suppose we find a call of f at type
215 t1/t2. There are two possibilities:
217 (a) The free type variables of t1, t2 are in scope at the definition point
218 of f. In this case there's no problem, we proceed just as before. A common
219 example is as follows. Here's the Haskell:
224 After typechecking we have
226 g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
227 in +.sel a d (f a d y) (f a d y)
229 Notice that the call to f is at type type "a"; a non-constant type.
230 Both calls to f are at the same type, so we can specialise to give:
232 g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
233 in +.sel a d (f@a y) (f@a y)
236 (b) The other case is when the type variables in the instance types
237 are *not* in scope at the definition point of f. The example we are
238 working with above is a good case. There are two instances of (+.sel a d),
239 but "a" is not in scope at the definition of +.sel. Can we do anything?
240 Yes, we can "common them up", a sort of limited common sub-expression deal.
243 g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
244 f@a (x::a) = +.sel@a x x
245 in +.sel@a (f@a y) (f@a y)
247 This can save work, and can't be spotted by the type checker, because
248 the two instances of +.sel weren't originally at the same type.
252 * There are quite a few variations here. For example, the defn of
253 +.sel could be floated ouside the \y, to attempt to gain laziness.
254 It certainly mustn't be floated outside the \d because the d has to
257 * We don't want to inline f_rhs in this case, because
258 that will duplicate code. Just commoning up the call is the point.
260 * Nothing gets added to +.sel's IdInfo.
262 * Don't bother unless the equivalence class has more than one item!
264 Not clear whether this is all worth it. It is of course OK to
265 simply discard call-instances when passing a big lambda.
267 Polymorphism 2 -- Overloading
269 Consider a function whose most general type is
271 f :: forall a b. Ord a => [a] -> b -> b
273 There is really no point in making a version of g at Int/Int and another
274 at Int/Bool, because it's only instancing the type variable "a" which
275 buys us any efficiency. Since g is completely polymorphic in b there
276 ain't much point in making separate versions of g for the different
279 That suggests that we should identify which of g's type variables
280 are constrained (like "a") and which are unconstrained (like "b").
281 Then when taking equivalence classes in STEP 2, we ignore the type args
282 corresponding to unconstrained type variable. In STEP 3 we make
283 polymorphic versions. Thus:
285 f@t1/ = /\b -> <f_rhs> t1 b d1 d2
287 This seems pretty simple, and a Good Thing.
289 Polymorphism 3 -- Unboxed
292 If we are speciailising at unboxed types we must speciailise
293 regardless of the overloading constraint. In the exaple above it is
294 worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
297 Note that specialising an overloaded type at an uboxed type requires
298 an unboxed instance -- we cannot default to an unspecialised version!
305 f x = let g p q = p==q
311 Before specialisation, leaving out type abstractions we have
313 f df x = let g :: Eq a => a -> a -> Bool
315 h :: Num a => a -> a -> (a, Bool)
316 h dh r s = let deq = eqFromNum dh
317 in (+ dh r s, g deq r s)
321 After specialising h we get a specialised version of h, like this:
323 h' r s = let deq = eqFromNum df
324 in (+ df r s, g deq r s)
326 But we can't naively make an instance for g from this, because deq is not in scope
327 at the defn of g. Instead, we have to float out the (new) defn of deq
328 to widen its scope. Notice that this floating can't be done in advance -- it only
329 shows up when specialisation is done.
331 DELICATE MATTER: the way we tell a dictionary binding is by looking to
332 see if it has a Dict type. If the type has been "undictify'd", so that
333 it looks like a tuple, then the dictionary binding won't be floated, and
334 an opportunity to specialise might be lost.
336 User SPECIALIZE pragmas
337 ~~~~~~~~~~~~~~~~~~~~~~~
338 Specialisation pragmas can be digested by the type checker, and implemented
339 by adding extra definitions along with that of f, in the same way as before
341 f@t1/t2 = <f_rhs> t1 t2 d1 d2
343 Indeed the pragmas *have* to be dealt with by the type checker, because
344 only it knows how to build the dictionaries d1 and d2! For example
346 g :: Ord a => [a] -> [a]
347 {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
349 Here, the specialised version of g is an application of g's rhs to the
350 Ord dictionary for (Tree Int), which only the type checker can conjure
351 up. There might not even *be* one, if (Tree Int) is not an instance of
352 Ord! (All the other specialision has suitable dictionaries to hand
355 Problem. The type checker doesn't have to hand a convenient <f_rhs>, because
356 it is buried in a complex (as-yet-un-desugared) binding group.
359 f@t1/t2 = f* t1 t2 d1 d2
361 where f* is the Id f with an IdInfo which says "inline me regardless!".
362 Indeed all the specialisation could be done in this way.
363 That in turn means that the simplifier has to be prepared to inline absolutely
364 any in-scope let-bound thing.
367 Again, the pragma should permit polymorphism in unconstrained variables:
369 h :: Ord a => [a] -> b -> b
370 {-# SPECIALIZE h :: [Int] -> b -> b #-}
372 We *insist* that all overloaded type variables are specialised to ground types,
373 (and hence there can be no context inside a SPECIALIZE pragma).
374 We *permit* unconstrained type variables to be specialised to
376 - or left as a polymorphic type variable
377 but nothing in between. So
379 {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
381 is *illegal*. (It can be handled, but it adds complication, and gains the
385 SPECIALISING INSTANCE DECLARATIONS
386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
389 instance Foo a => Foo [a] where
391 {-# SPECIALIZE instance Foo [Int] #-}
393 The original instance decl creates a dictionary-function
396 dfun.Foo.List :: forall a. Foo a -> Foo [a]
398 The SPECIALIZE pragma just makes a specialised copy, just as for
399 ordinary function definitions:
401 dfun.Foo.List@Int :: Foo [Int]
402 dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
404 The information about what instance of the dfun exist gets added to
405 the dfun's IdInfo in the same way as a user-defined function too.
407 In fact, matters are a little bit more complicated than this.
408 When we make one of these specialised instances, we are defining
409 a constant dictionary, and so we want immediate access to its constant
410 methods and superclasses. Indeed, these constant methods and superclasses
411 must be in the IdInfo for the class selectors! We need help from the
412 typechecker to sort this out, perhaps by generating a separate IdInfo
415 Automatic instance decl specialisation?
416 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
417 Can instance decls be specialised automatically? It's tricky.
418 We could collect call-instance information for each dfun, but
419 then when we specialised their bodies we'd get new call-instances
420 for ordinary functions; and when we specialised their bodies, we might get
421 new call-instances of the dfuns, and so on. This all arises because of
422 the unrestricted mutual recursion between instance decls and value decls.
424 Furthermore, instance decls are usually exported and used non-locally,
425 so we'll want to compile enough to get those specialisations done.
427 Lastly, there's no such thing as a local instance decl, so we can
428 survive solely by spitting out *usage* information, and then reading that
429 back in as a pragma when next compiling the file. So for now,
430 we only specialise instance decls in response to pragmas.
432 That means that even if an instance decl ain't otherwise exported it
433 needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
434 something to say which module defined the instance, so the usage info
435 can be fed into the right reqts info file. Blegh.
438 SPECIAILISING DATA DECLARATIONS
439 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
441 With unboxed specialisation (or full specialisation) we also require
442 data types (and their constructors) to be speciailised on unboxed
445 In addition to normal call instances we gather TyCon call instances at
446 unboxed types, determine equivalence classes for the locally defined
447 TyCons and build speciailised data constructor Ids for each TyCon and
448 substitute these in the Con calls.
450 We need the list of local TyCons to partition the TyCon instance info.
451 We pass out a FiniteMap from local TyCons to Specialised Instances to
452 give to the interface and code genertors.
454 N.B. The specialised data constructors reference the original data
455 constructor and type constructor which do not have the updated
456 specialisation info attached. Any specialisation info must be
457 extracted from the TyCon map returned.
460 SPITTING OUT USAGE INFORMATION
461 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
463 To spit out usage information we need to traverse the code collecting
464 call-instance information for all imported (non-prelude?) functions
465 and data types. Then we equivalence-class it and spit it out.
467 This is done at the top-level when all the call instances which escape
468 must be for imported functions and data types.
471 Partial specialisation by pragmas
472 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
473 What about partial specialisation:
475 k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
476 {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
480 {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
482 Seems quite reasonable. Similar things could be done with instance decls:
484 instance (Foo a, Foo b) => Foo (a,b) where
486 {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
487 {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
489 Ho hum. Things are complex enough without this. I pass.
492 Requirements for the simplifer
493 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
494 The simplifier has to be able to take advantage of the specialisation.
496 * When the simplifier finds an application of a polymorphic f, it looks in
497 f's IdInfo in case there is a suitable instance to call instead. This converts
499 f t1 t2 d1 d2 ===> f_t1_t2
501 Note that the dictionaries get eaten up too!
503 * Dictionary selection operations on constant dictionaries must be
506 +.sel Int d ===> +Int
508 The obvious way to do this is in the same way as other specialised
509 calls: +.sel has inside it some IdInfo which tells that if it's applied
510 to the type Int then it should eat a dictionary and transform to +Int.
512 In short, dictionary selectors need IdInfo inside them for constant
515 * Exactly the same applies if a superclass dictionary is being
518 Eq.sel Int d ===> dEqInt
520 * Something similar applies to dictionary construction too. Suppose
521 dfun.Eq.List is the function taking a dictionary for (Eq a) to
522 one for (Eq [a]). Then we want
524 dfun.Eq.List Int d ===> dEq.List_Int
526 Where does the Eq [Int] dictionary come from? It is built in
527 response to a SPECIALIZE pragma on the Eq [a] instance decl.
529 In short, dfun Ids need IdInfo with a specialisation for each
530 constant instance of their instance declaration.
533 What does the specialisation IdInfo look like?
534 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
537 [Maybe Type] -- Instance types
538 Int -- No of dicts to eat
539 Id -- Specialised version
541 For example, if f has this SpecInfo:
543 SpecInfo [Just t1, Nothing, Just t3] 2 f'
547 f t1 t2 t3 d1 d2 ===> f t2
549 The "Nothings" identify type arguments in which the specialised
550 version is polymorphic.
552 What can't be done this way?
553 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
554 There is no way, post-typechecker, to get a dictionary for (say)
555 Eq a from a dictionary for Eq [a]. So if we find
559 we can't transform to
564 eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
566 Of course, we currently have no way to automatically derive
567 eqList, nor to connect it to the Eq [a] instance decl, but you
568 can imagine that it might somehow be possible. Taking advantage
569 of this is permanently ruled out.
571 Still, this is no great hardship, because we intend to eliminate
572 overloading altogether anyway!
577 What about types/classes mentioned in SPECIALIZE pragmas spat out,
578 but not otherwise exported. Even if they are exported, what about
579 their original names.
581 Suggestion: use qualified names in pragmas, omitting module for
582 prelude and "this module".
589 f a (d::Num a) = let g = ...
591 ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
593 Here, g is only called at one type, but the dictionary isn't in scope at the
594 definition point for g. Usually the type checker would build a
595 definition for d1 which enclosed g, but the transformation system
596 might have moved d1's defn inward.
602 What should we do when a value is specialised to a *strict* unboxed value?
604 map_*_* f (x:xs) = let h = f x
608 Could convert let to case:
610 map_*_Int# f (x:xs) = case f x of h# ->
614 This may be undesirable since it forces evaluation here, but the value
615 may not be used in all branches of the body. In the general case this
616 transformation is impossible since the mutual recursion in a letrec
617 cannot be expressed as a case.
619 There is also a problem with top-level unboxed values, since our
620 implementation cannot handle unboxed values at the top level.
622 Solution: Lift the binding of the unboxed value and extract it when it
625 map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
630 Now give it to the simplifier and the _Lifting will be optimised away.
632 The benfit is that we have given the specialised "unboxed" values a
633 very simple lifted semantics and then leave it up to the simplifier to
634 optimise it --- knowing that the overheads will be removed in nearly
637 In particular, the value will only be evaluted in the branches of the
638 program which use it, rather than being forced at the point where the
639 value is bound. For example:
641 filtermap_*_* p f (x:xs)
648 filtermap_*_Int# p f (x:xs)
649 = let h = case (f x) of h# -> _Lift h#
652 True -> case h of _Lift h#
656 The binding for h can still be inlined in the one branch and the
660 Question: When won't the _Lifting be eliminated?
662 Answer: When they at the top-level (where it is necessary) or when
663 inlining would duplicate work (or possibly code depending on
664 options). However, the _Lifting will still be eliminated if the
665 strictness analyser deems the lifted binding strict.
669 %************************************************************************
671 \subsubsection[CallInstances]{@CallInstances@ data type}
673 %************************************************************************
676 type FreeVarsSet = IdSet
677 type FreeTyVarsSet = TyVarSet
681 Id -- This Id; *new* ie *cloned* id
682 [Maybe Type] -- Specialised at these types (*new*, cloned)
683 -- Nothing => no specialisation on this type arg
684 -- is required (flag dependent).
685 [CoreArg] -- And these dictionaries; all ValArgs
686 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
687 (Maybe SpecInfo) -- For specialisation with explicit SpecId
691 pprCI :: CallInstance -> Pretty
692 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
693 = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
694 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
695 case maybe_specinfo of
696 Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
697 Just (SpecInfo _ _ spec_id)
698 -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
701 -- ToDo: instance Outputable CoreArg?
702 ppr_arg sty (TyArg t) = ppr sty t
703 ppr_arg sty (LitArg i) = ppr sty i
704 ppr_arg sty (VarArg v) = ppr sty v
706 isUnboxedCI :: CallInstance -> Bool
707 isUnboxedCI (CallInstance _ spec_tys _ _ _)
708 = any isUnboxedType (catMaybes spec_tys)
710 isExplicitCI :: CallInstance -> Bool
711 isExplicitCI (CallInstance _ _ _ _ (Just _))
713 isExplicitCI (CallInstance _ _ _ _ Nothing)
717 Comparisons are based on the {\em types}, ignoring the dictionary args:
721 cmpCI :: CallInstance -> CallInstance -> TAG_
722 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
723 = case (id1 `cmp` id2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
725 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
726 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
727 = cmpUniTypeMaybeList tys1 tys2
729 eqCI_tys :: CallInstance -> CallInstance -> Bool
731 = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
733 isCIofTheseIds :: [Id] -> CallInstance -> Bool
734 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
735 = any ((==) ci_id) ids
737 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
738 singleCI id tys dicts
739 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
740 emptyBag [] emptyIdSet 0 0
742 fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
744 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
745 explicitCI id tys specinfo
746 = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
748 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
749 dicts = panic "Specialise:explicitCI:dicts"
750 fv_set = unitIdSet id
752 -- We do not process the CIs for top-level dfuns or defms
753 -- Instead we require an explicit SPEC inst pragma for dfuns
754 -- and an explict method within any instances for the defms
756 getCIids :: Bool -> [Id] -> [Id]
757 getCIids True ids = filter not_dict_or_defm ids
761 = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
763 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
764 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
766 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
767 cis_here_list = bagToList cis_here
769 -- pprTrace "getCIs:"
770 -- (ppHang (ppBesides [ppStr "{",
771 -- interppSP PprDebug ids,
773 -- 4 (ppAboves (map pprCI cis_here_list)))
774 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
776 dumpCIs :: Bag CallInstance -- The call instances
777 -> Bool -- True <=> top level bound Ids
778 -> Bool -- True <=> dict bindings to be floated (specBind only)
779 -> [CallInstance] -- Call insts for bound ids (instBind only)
780 -> [Id] -- Bound ids *new*
781 -> [Id] -- Full bound ids: includes dumped dicts
782 -> Bag CallInstance -- Kept call instances
784 -- CIs are dumped if:
785 -- 1) they are a CI for one of the bound ids, or
786 -- 2) they mention any of the dicts in a local unfloated binding
788 -- For top-level bindings we allow the call instances to
789 -- float past a dict bind and place all the top-level binds
790 -- in a *global* Rec.
791 -- We leave it to the simplifier will sort it all out ...
793 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
794 = (if not (isEmptyBag cis_of_bound_id) &&
795 not (isEmptyBag cis_of_bound_id_without_inst_cis)
797 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
798 " (may be a non-HM recursive call)\n")
799 (ppHang (ppBesides [ppStr "{",
800 interppSP PprDebug bound_ids,
802 4 (ppAboves [ppStr "Dumping CIs:",
803 ppAboves (map pprCI (bagToList cis_of_bound_id)),
804 ppStr "Instantiating CIs:",
805 ppAboves (map pprCI inst_cis)]))
807 if top_lev || floating then
810 (if not (isEmptyBag cis_dump_unboxed)
811 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
812 (ppHang (ppBesides [ppStr "{",
813 interppSP PprDebug full_ids,
815 4 (ppAboves (map pprCI (bagToList cis_dump))))
817 cis_keep_not_bound_id
820 (cis_of_bound_id, cis_not_bound_id)
821 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
823 (cis_dump, cis_keep_not_bound_id)
824 = partitionBag ok_to_dump_ci cis_not_bound_id
826 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
827 = any (\ i -> i `elementOfIdSet` fv_set) full_ids
829 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
830 have_inst_ci ci = any (eqCI_tys ci) inst_cis
832 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
836 Any call instances of a bound_id can be safely dumped, because any
837 recursive calls should be at the same instance as the parent instance.
839 letrec f = /\a -> \x::a -> ...(f t x')...
841 Here, the type, t, at which f is used in its own RHS should be
842 just "a"; that is, the recursive call is at the same type as
843 the original call. That means that when specialising f at some
844 type, say Int#, we shouldn't find any *new* instances of f
845 arising from specialising f's RHS. The only instance we'll find
846 is another call of (f Int#).
848 We check this in dumpCIs by passing in all the instantiated call
849 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
850 for which there is no such instance.
852 We also report CIs dumped due to a bound dictionary arg if they
853 contain unboxed types.
855 %************************************************************************
857 \subsubsection[TyConInstances]{@TyConInstances@ data type}
859 %************************************************************************
863 = TyConInstance TyCon -- Type Constructor
864 [Maybe Type] -- Applied to these specialising types
866 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
867 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
868 = case (cmp tc1 tc2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
870 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
871 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
872 = cmpUniTypeMaybeList tys1 tys2
874 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
875 singleTyConI ty_con spec_tys
876 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
878 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
879 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
881 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
882 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
884 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
885 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
887 (tycon_cis_local, tycon_cis_global)
888 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
889 tycon_cis_local_list = bagToList tycon_cis_local
891 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
895 %************************************************************************
897 \subsubsection[UsageDetails]{@UsageDetails@ data type}
899 %************************************************************************
904 (Bag CallInstance) -- The collection of call-instances
905 (Bag TyConInstance) -- Constructor call-instances
906 [DictBindDetails] -- Dictionary bindings in data-dependence order!
907 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
908 Int -- no. of spec calls
909 Int -- no. of spec insts
912 The DictBindDetails are fully processed; their call-instance information is
913 incorporated in the call-instances of the
914 UsageDetails which includes the DictBindDetails. The free vars in a usage details
915 will *include* the binders of the DictBind details.
917 A @DictBindDetails@ contains bindings for dictionaries *only*.
922 [Id] -- Main binders, originally visible in scope of binding (cloned)
923 CoreBinding -- Fully processed
924 FreeVarsSet -- Free in binding group (cloned)
925 FreeTyVarsSet -- Free in binding group
929 emptyUDs :: UsageDetails
930 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
931 unionUDList :: [UsageDetails] -> UsageDetails
933 tickSpecCall :: Bool -> UsageDetails -> UsageDetails
934 tickSpecInsts :: UsageDetails -> UsageDetails
936 tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
937 = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
939 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
940 = UsageDetails cis ty_cis dbs fvs c (i+1)
942 emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
944 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
945 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
946 (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
947 -- The append here is really redundant, since the bindings don't
948 -- scope over each other. ToDo.
950 unionUDList = foldr unionUDs emptyUDs
952 singleFvUDs (VarArg v) | not (isImportedId v)
953 = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
957 singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
959 dumpDBs :: [DictBindDetails]
960 -> Bool -- True <=> top level bound Ids
961 -> [TyVar] -- TyVars being bound (cloned)
962 -> [Id] -- Ids being bound (cloned)
963 -> FreeVarsSet -- Fvs of body
964 -> ([CoreBinding], -- These ones have to go here
965 [DictBindDetails], -- These can float further
966 [Id], -- Incoming list + names of dicts bound here
967 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
970 -- It is just to complex to try to float top-level
971 -- dict bindings with constant methods, inst methods,
972 -- auxillary derived instance defns and user instance
973 -- defns all getting in the way.
974 -- So we dump all dbinds as soon as we get to the top
975 -- level and place them in a *global* Rec.
976 -- We leave it to the simplifier will sort it all out ...
978 dumpDBs [] top_lev bound_tyvars bound_ids fvs
979 = ([], [], bound_ids, fvs)
981 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
982 top_lev bound_tyvars bound_ids fvs
984 || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
985 || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
986 = let -- Ha! Dump it!
987 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
988 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
990 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
992 | otherwise -- This one can float out further
994 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
995 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
997 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
1001 dumpUDs :: UsageDetails
1002 -> Bool -- True <=> top level bound Ids
1003 -> Bool -- True <=> dict bindings to be floated (specBind only)
1004 -> [CallInstance] -- Call insts for bound Ids (instBind only)
1005 -> [Id] -- Ids which are just being bound; *new*
1006 -> [TyVar] -- TyVars which are just being bound
1007 -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
1008 UsageDetails) -- The above bindings removed, and
1009 -- any call-instances which mention the ids dumped too
1011 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
1013 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
1014 = dumpDBs dbs top_lev tvs bound_ids fvs
1015 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
1016 fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
1018 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
1022 addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
1023 -> UsageDetails -- The usage to augment
1025 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
1026 (UsageDetails cis tycon_cis dbs fvs c i)
1027 = UsageDetails (db_cis `unionBags` cis)
1028 (db_tycon_cis `unionBags` tycon_cis)
1029 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
1031 -- NB: We ignore counts from dictbinds since it is not user code
1033 -- The free tyvars of the dictionary bindings should really be
1034 -- gotten from the RHSs, but I'm pretty sure it's good enough just
1035 -- to look at the type of the dictionary itself.
1036 -- Doing the proper job would entail keeping track of free tyvars as
1037 -- well as free vars, which would be a bore.
1038 db_ftvs = tyVarsOfTypes (map idType dbinders)
1041 %************************************************************************
1043 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
1045 %************************************************************************
1047 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
1049 1) (NoLift LitArg l) : an Id which is bound to a literal
1051 2) (NoLift LitArg l) : an Id bound to a "new" Id
1052 The new Id is a possibly-type-specialised clone of the original
1054 3) Lifted lifted_id unlifted_id :
1056 This indicates that the original Id has been specialised to an
1057 unboxed value which must be lifted (see "Unboxed bindings" above)
1058 @unlifted_id@ is the unboxed clone of the original Id
1059 @lifted_id@ is a *lifted* version of the original Id
1061 When you lookup Ids which are Lifted, you have to insert a case
1062 expression to un-lift the value (done with @bindUnlift@)
1064 You also have to insert a case to lift the value in the binding
1065 (done with @liftExpr@)
1069 type SpecIdEnv = IdEnv CloneInfo
1072 = NoLift CoreArg -- refers to cloned id or literal
1074 | Lifted Id -- lifted, cloned id
1075 Id -- unlifted, cloned id
1079 %************************************************************************
1081 \subsection[specialise-data]{Data returned by specialiser}
1083 %************************************************************************
1088 -- True <=> Specialisation performed
1090 -- False <=> Specialisation completed with errors
1093 -- Local tycons declared in this module
1096 -- Those in-scope data types for which we want to
1097 -- generate code for their constructors.
1098 -- Namely: data types declared in this module +
1099 -- any big tuples used in this module
1100 -- The initial (and default) value is the local tycons
1102 (FiniteMap TyCon [(Bool, [Maybe Type])])
1103 -- TyCon specialisations to be generated
1104 -- We generate specialialised code (Bool=True) for data types
1105 -- defined in this module and any tuples used in this module
1106 -- The initial (and default) value is the specialisations
1107 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1108 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1110 (Bag (Id,[Maybe Type]))
1111 -- Imported specialisation errors
1112 (Bag (Id,[Maybe Type]))
1113 -- Imported specialisation warnings
1114 (Bag (TyCon,[Maybe Type]))
1115 -- Imported TyCon specialisation errors
1117 initSpecData local_tycons tycon_specs
1118 = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1121 ToDo[sansom]: Transformation data to process specialisation requests.
1123 %************************************************************************
1125 \subsection[specProgram]{Specialising a core program}
1127 %************************************************************************
1130 specProgram :: UniqSupply
1131 -> [CoreBinding] -- input ...
1133 -> ([CoreBinding], -- main result
1134 SpecialiseData) -- result specialise data
1136 specProgram uniqs binds
1137 (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1138 = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
1139 (final_binds, tycon_specs_list,
1140 UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1142 used_conids = filter isDataCon (uniqSetToList fvs)
1143 used_tycons = map dataConTyCon used_conids
1144 used_gen = filter isLocalGenTyCon used_tycons
1145 gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
1147 result_specs = addListToFM_C (++) init_specs tycon_specs_list
1149 uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
1150 cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1151 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1152 cis_warn = init_warn `unionBags` listToBag cis_other
1153 cis_errs = init_errs `unionBags` listToBag cis_unboxed
1155 uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
1156 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1157 tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
1159 no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
1160 && (not opt_SpecialiseImports || isEmptyBag cis_warn)
1162 (if opt_D_simplifier_stats then
1163 pprTrace "\nSpecialiser Stats:\n" (ppAboves [
1164 ppBesides [ppStr "SpecCalls ", ppInt spec_calls],
1165 ppBesides [ppStr "SpecInsts ", ppInt spec_insts],
1170 SpecData True no_errs local_tycons gen_tycons result_specs
1171 cis_errs cis_warn tycis_errs)
1173 specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
1174 = panic "Specialise:specProgram: specialiser called more than once"
1176 -- It may be possible safely to call the specialiser more than once,
1177 -- but I am not sure there is any benefit in doing so (Patrick)
1179 -- ToDo: What about unfoldings performed after specialisation ???
1182 %************************************************************************
1184 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1186 %************************************************************************
1188 In the specialiser we just collect up the specialisations which will
1189 be required. We don't create the specialised constructors in
1190 Core. These are only introduced when we convert to StgSyn.
1192 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1195 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1196 -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1198 specTyConsAndScope scopeM
1199 = scopeM `thenSM` \ (binds, scope_uds) ->
1201 (tycons_cis, gotci_scope_uds)
1202 = getLocalSpecTyConIs opt_CompilingPrelude scope_uds
1204 tycon_specs_list = collectTyConSpecs tycons_cis
1206 (if opt_SpecialiseTrace && not (null tycon_specs_list) then
1207 pprTrace "Specialising TyCons:\n"
1208 (ppAboves [ if not (null specs) then
1209 ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
1210 4 (ppAboves (map pp_specs specs))
1212 | (tycon, specs) <- tycon_specs_list])
1214 returnSM (binds, tycon_specs_list, gotci_scope_uds)
1217 collectTyConSpecs []
1219 collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1220 = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1222 (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1223 uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1224 tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1226 pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
1230 %************************************************************************
1232 \subsection[specTopBinds]{Specialising top-level bindings}
1234 %************************************************************************
1237 specTopBinds :: [CoreBinding]
1238 -> SpecM ([CoreBinding], UsageDetails)
1241 = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1243 -- Add bindings for floated dbinds and collect fvs
1244 -- In actual fact many of these bindings are dead code since dict
1245 -- arguments are dropped when a specialised call is created
1246 -- The simplifier should be able to cope ...
1248 (dbinders_s, dbinds, dfvs_s)
1249 = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1251 full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
1252 fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
1254 -- It is just to complex to try to sort out top-level dependencies
1255 -- So we just place all the top-level binds in a *global* Rec and
1256 -- leave it to the simplifier to sort it all out ...
1259 returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1262 spec_top_binds (first_bind:rest_binds)
1263 = specBindAndScope True first_bind (
1264 spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1265 returnSM (ItsABinds rest_binds, rest_uds)
1266 ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1267 returnSM (first_binds ++ rest_binds, all_uds)
1270 = returnSM ([], emptyUDs)
1273 %************************************************************************
1275 \subsection[specExpr]{Specialising expressions}
1277 %************************************************************************
1280 specExpr :: CoreExpr
1281 -> [CoreArg] -- The arguments:
1282 -- TypeArgs are speced
1283 -- ValArgs are unprocessed
1284 -> SpecM (CoreExpr, -- Result expression with specialised versions installed
1285 UsageDetails)-- Details of usage of enclosing binders in the result
1288 specExpr (Var v) args
1289 = lookupId v `thenSM` \ vlookup ->
1292 -> -- Binding has been lifted, need to extract un-lifted value
1293 -- NB: a function binding will never be lifted => args always null
1294 -- i.e. no call instance required or call to be constructed
1296 returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
1298 NoLift vatom@(VarArg new_v)
1299 -> mapSM specOutArg args `thenSM` \ arg_info ->
1300 mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
1301 mkCall new_v arg_info `thenSM` \ ~(speced, call) ->
1303 uds = unionUDList [call_uds,
1305 unionUDList [uds | (_,uds,_) <- arg_info]
1308 returnSM (call, tickSpecCall speced uds)
1310 specExpr expr@(Lit _) null_args
1311 = ASSERT (null null_args)
1312 returnSM (expr, emptyUDs)
1314 specExpr (Con con args) null_args
1315 = ASSERT (null null_args)
1317 (targs, vargs) = partition_args args
1319 mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
1320 mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
1321 mkTyConInstance con tys `thenSM` \ con_uds ->
1322 returnSM (applyBindUnlifts unlifts (Con con (targs ++ vargs)),
1323 unionUDList args_uds_s `unionUDs` con_uds)
1325 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
1326 = ASSERT (null null_args)
1328 (targs, vargs) = partition_args args
1331 mapSM specTy arg_tys `thenSM` \ arg_tys ->
1332 specTy res_ty `thenSM` \ res_ty ->
1333 mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
1334 returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) vargs),
1335 unionUDList args_uds_s)
1337 specExpr (Prim prim args) null_args
1338 = ASSERT (null null_args)
1340 (targs, vargs) = partition_args args
1342 mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
1343 mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
1344 -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
1345 returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)),
1346 unionUDList args_uds_s {-`unionUDs` prim_uds-} )
1350 specPrimOp :: PrimOp
1356 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1357 -- and/or chooses PrimOp specialised to any unboxed tys
1358 -- Errors are dealt with by returning a PrimOp call instance
1359 -- which will result in a cis_errs message
1361 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1365 specExpr (App fun arg) args
1366 = -- If TyArg, arg will be processed; otherwise, left alone
1367 preSpecArg arg `thenSM` \ new_arg ->
1368 specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
1369 returnSM (expr, uds)
1371 specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
1372 = lookup_arg arg `thenSM` \ arg ->
1373 bindId binder arg (specExpr body args)
1375 lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1376 lookup_arg (VarArg v) = lookupId v
1378 specExpr (Lam (ValBinder binder) body) []
1379 = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1380 returnSM (Lam (ValBinder binder) body, uds)
1382 specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
1383 = -- Type lambda with argument; argument already spec'd
1384 bindTyVar tyvar ty ( specExpr body args )
1386 specExpr (Lam (TyBinder tyvar) body) []
1388 cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
1389 bindTyVar tyvar (mkTyVarTy new_tyvar) (
1390 specExpr body [] `thenSM` \ (body, body_uds) ->
1392 (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1394 returnSM (Lam (TyBinder new_tyvar)
1395 (mkCoLetsNoUnboxed binds_here body),
1399 specExpr (Case scrutinee alts) args
1400 = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
1401 specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
1402 returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
1404 scrutinee_type = coreExprType scrutinee
1406 specExpr (Let bind body) args
1407 = specBindAndScope False bind (
1408 specExpr body args `thenSM` \ (body, body_uds) ->
1409 returnSM (ItsAnExpr body, body_uds)
1410 ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1411 returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1413 specExpr (SCC cc expr) args
1414 = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
1415 mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1418 = if squashableDictishCcExpr cc expr -- can toss the _scc_
1422 returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1423 unionUDList args_uds_s `unionUDs` expr_uds)
1425 -- ToDo: This may leave some unspec'd dictionaries!!
1428 %************************************************************************
1430 \subsubsection{Specialising a lambda}
1432 %************************************************************************
1435 specLambdaOrCaseBody :: [Id] -- The binders
1436 -> CoreExpr -- The body
1437 -> [CoreArg] -- Its args
1438 -> SpecM ([Id], -- New binders
1439 CoreExpr, -- New body
1442 specLambdaOrCaseBody bound_ids body args
1443 = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
1444 bindIds bound_ids clone_infos (
1446 specExpr body args `thenSM` \ (body, body_uds) ->
1449 -- Dump any dictionary bindings (and call instances)
1450 -- from the scope which mention things bound here
1451 (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1453 returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1456 -- ToDo: Opportunity here to common-up dictionaries with same type,
1457 -- thus avoiding recomputation.
1460 A variable bound in a lambda or case is normally monomorphic so no
1461 specialised versions will be required. This is just as well since we
1462 do not know what code to specialise!
1464 Unfortunately this is not always the case. For example a class Foo
1465 with polymorphic methods gives rise to a dictionary with polymorphic
1466 components as follows:
1473 instance Foo Int where
1481 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1482 d.Foo.Int = (op1_Int, op2_Int)
1484 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1486 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1489 N.B. The type of the dictionary is not Hindley Milner!
1491 Now we must specialise op1 at {* Int#} which requires a version of
1492 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1493 not have access to its code to create the specialised version.
1495 If we specialise on overloaded types as well we specialise op1 at
1496 {Int Int#} d.Foo.Int:
1498 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1500 Though this is still invalid, after further simplification we get:
1502 op1_Int_Int# = opInt1 {Int#}
1504 Another round of specialisation will result in the specialised
1505 version of op1Int being called directly.
1507 For now we PANIC if a polymorphic lambda/case bound variable is found
1508 in a call instance with an unboxed type. Other call instances, arising
1509 from overloaded type arguments, are discarded since the unspecialised
1510 version extracted from the method can be called as normal.
1512 ToDo: Implement and test second round of specialisation.
1515 %************************************************************************
1517 \subsubsection{Specialising case alternatives}
1519 %************************************************************************
1523 specAlts (AlgAlts alts deflt) scrutinee_ty args
1524 = mapSM specTy ty_args `thenSM` \ ty_args ->
1525 mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
1526 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1527 returnSM (AlgAlts alts deflt,
1528 unionUDList alts_uds_s `unionUDs` deflt_uds)
1530 -- We use ty_args of scrutinee type to identify specialisation of
1533 (_, ty_args, _) = getAppDataTyCon scrutinee_ty
1535 specAlgAlt ty_args (con,binders,rhs)
1536 = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
1537 mkTyConInstance con ty_args `thenSM` \ con_uds ->
1538 returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1540 specAlts (PrimAlts alts deflt) scrutinee_ty args
1541 = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
1542 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1543 returnSM (PrimAlts alts deflt,
1544 unionUDList alts_uds_s `unionUDs` deflt_uds)
1546 specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
1547 returnSM ((lit,rhs), uds)
1550 specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
1551 specDeflt (BindDefault binder rhs) args
1552 = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
1553 returnSM (BindDefault binder rhs, uds)
1557 %************************************************************************
1559 \subsubsection{Specialising an atom}
1561 %************************************************************************
1564 partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
1566 = span is_ty_arg args
1568 is_ty_arg (TyArg _) = True
1572 preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else
1574 preSpecArg (TyArg ty)
1575 = specTy ty `thenSM` \ new_ty ->
1576 returnSM (TyArg new_ty)
1578 preSpecArg other = returnSM other
1580 --------------------
1581 specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
1582 CoreExpr -> CoreExpr)
1584 specValArg (LitArg lit)
1585 = returnSM (LitArg lit, emptyUDs, id)
1587 specValArg (VarArg v)
1588 = lookupId v `thenSM` \ vlookup ->
1591 -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
1594 -> returnSM (vatom, singleFvUDs vatom, id)
1598 specTyArg (TyArg ty)
1599 = specTy ty `thenSM` \ new_ty ->
1600 returnSM (TyArg new_ty, new_ty)
1603 specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
1604 CoreExpr -> CoreExpr)
1606 specOutArg (TyArg ty) -- already speced; no action
1607 = returnSM (TyArg ty, emptyUDs, id)
1609 specOutArg other_arg -- unprocessed; spec the atom
1610 = specValArg other_arg
1614 %************************************************************************
1616 \subsubsection{Specialising bindings}
1618 %************************************************************************
1620 A classic case of when having a polymorphic recursive function would help!
1623 data BindsOrExpr = ItsABinds [CoreBinding]
1624 | ItsAnExpr CoreExpr
1629 :: Bool -- True <=> a top level group
1630 -> CoreBinding -- As yet unprocessed
1631 -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
1632 -> SpecM ([CoreBinding], -- Processed
1633 BindsOrExpr, -- Combined result
1634 UsageDetails) -- Usage details of the whole lot
1636 specBindAndScope top_lev bind scopeM
1637 = cloneLetBinders top_lev (is_rec bind) binders
1638 `thenSM` \ (new_binders, clone_infos) ->
1640 -- Two cases now: either this is a bunch of local dictionaries,
1641 -- in which case we float them; or its a bunch of other values,
1642 -- in which case we see if they correspond to any call-instances
1643 -- we have from processing the scope
1645 if not top_lev && all (isDictTy . idType) binders
1647 -- Ha! A group of local dictionary bindings
1649 bindIds binders clone_infos (
1651 -- Process the dictionary bindings themselves
1652 specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
1654 -- Process their scope
1655 scopeM `thenSM` \ (thing, scope_uds) ->
1657 -- Add the bindings to the current stuff
1658 final_uds = addDictBinds new_binders bind rhs_uds scope_uds
1660 returnSM ([], thing, final_uds)
1663 -- Ho! A group of bindings
1665 fixSM (\ ~(_, _, _, rec_spec_infos) ->
1667 bindSpecIds binders clone_infos rec_spec_infos (
1668 -- It's ok to have new binders in scope in
1669 -- non-recursive decls too, cos name shadowing is gone by now
1671 -- Do the scope of the bindings
1672 scopeM `thenSM` \ (thing, scope_uds) ->
1674 (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
1676 equiv_ciss = equivClasses cmpCI_tys call_insts
1677 inst_cis = map head equiv_ciss
1680 -- Do the bindings themselves
1681 specBind top_lev False new_binders inst_cis bind
1682 `thenSM` \ (spec_bind, spec_uds) ->
1684 -- Create any necessary instances
1685 instBind top_lev new_binders bind equiv_ciss inst_cis
1686 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
1689 -- NB: dumpUDs only worries about new_binders since the free var
1690 -- stuff only records free new_binders
1691 -- The spec_ids only appear in SpecInfos and final speced calls
1693 -- Build final binding group and usage details
1694 (final_binds, final_uds)
1696 -- For a top-level binding we have to dumpUDs from
1697 -- spec_uds and inst_uds and scope_uds creating
1698 -- *global* dict bindings
1700 (scope_dict_binds, final_scope_uds)
1701 = dumpUDs gotci_scope_uds True False [] new_binders []
1702 (spec_dict_binds, final_spec_uds)
1703 = dumpUDs spec_uds True False inst_cis new_binders []
1704 (inst_dict_binds, final_inst_uds)
1705 = dumpUDs inst_uds True False inst_cis new_binders []
1707 ([spec_bind] ++ inst_binds ++ scope_dict_binds
1708 ++ spec_dict_binds ++ inst_dict_binds,
1709 final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
1711 -- For a local binding we only have to dumpUDs from
1712 -- scope_uds since the UDs from spec_uds and inst_uds
1713 -- have already been dumped by specBind and instBind
1715 (scope_dict_binds, final_scope_uds)
1716 = dumpUDs gotci_scope_uds False False [] new_binders []
1718 ([spec_bind] ++ inst_binds ++ scope_dict_binds,
1719 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
1721 -- inst_uds comes last, because there may be dict bindings
1722 -- floating outward in scope_uds which are mentioned
1723 -- in the call-instances, and hence in spec_uds.
1724 -- This ordering makes sure that the precedence order
1725 -- among the dict bindings finally floated out is maintained.
1727 returnSM (final_binds, thing, final_uds, spec_infos)
1729 ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
1730 returnSM (binds, thing, final_uds)
1732 binders = bindersOf bind
1734 is_rec (NonRec _ _) = False
1739 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
1741 -> SpecM (CoreBinding, UsageDetails)
1742 -- The UsageDetails returned has already had stuff to do with this group
1743 -- of binders deleted; that's why new_binders is passed in.
1744 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
1745 = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
1746 `thenSM` \ ((binder,rhs), rhs_uds) ->
1747 returnSM (NonRec binder rhs, rhs_uds)
1749 specBind top_lev floating new_binders inst_cis (Rec pairs)
1750 = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
1751 `thenSM` \ (pairs, rhs_uds_s) ->
1752 returnSM (Rec pairs, unionUDList rhs_uds_s)
1755 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
1757 -> SpecM ((Id,CoreExpr), UsageDetails)
1759 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
1760 = lookupId binder `thenSM` \ blookup ->
1761 specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
1763 specid_maybe_maybe = isSpecPragmaId_maybe binder
1764 is_specid = maybeToBool specid_maybe_maybe
1765 Just specinfo_maybe = specid_maybe_maybe
1766 specid_with_info = maybeToBool specinfo_maybe
1767 Just spec_info = specinfo_maybe
1769 -- If we have a SpecInfo stored in a SpecPragmaId binder
1770 -- it will contain a SpecInfo with an explicit SpecId
1771 -- We add the explicit ci to the usage details
1772 -- Any ordinary cis for orig_id (there should only be one)
1773 -- will be ignored later
1776 = if is_specid && specid_with_info then
1778 (SpecInfo spec_tys _ spec_id) = spec_info
1779 Just (orig_id, _) = isSpecId_maybe spec_id
1781 ASSERT(toplevelishId orig_id) -- must not be cloned!
1782 explicitCI orig_id spec_tys spec_info
1786 -- For a local binding we dump the usage details, creating
1787 -- any local dict bindings required
1788 -- At the top-level the uds will be dumped in specBindAndScope
1789 -- and the dict bindings made *global*
1791 (local_dict_binds, final_uds)
1792 = if not top_lev then
1793 dumpUDs rhs_uds False floating inst_cis new_binders []
1798 Lifted lift_binder unlift_binder
1799 -> -- We may need to record an unboxed instance of
1800 -- the _Lift data type in the usage details
1801 mkTyConInstance liftDataCon [idType unlift_binder]
1802 `thenSM` \ lift_uds ->
1803 returnSM ((lift_binder,
1804 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
1805 final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
1807 NoLift (VarArg binder)
1808 -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
1809 final_uds `unionUDs` pragma_uds)
1813 %************************************************************************
1815 \subsection{@instBind@}
1817 %************************************************************************
1820 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
1822 = returnSM ([], emptyUDs, [])
1824 | all same_overloading other_binders
1825 = -- For each call_inst, build an instance
1826 mapAndUnzip3SM do_this_class equiv_ciss
1827 `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
1829 -- Add in the remaining UDs
1830 returnSM (catMaybes inst_binds,
1831 unionUDList inst_uds_s,
1835 | otherwise -- Incompatible overloadings; see below by same_overloading
1836 = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
1837 then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
1839 then pprTrace "dumpCIs: not same overloading ... top level \n"
1841 ) (ppHang (ppBesides [ppStr "{",
1842 interppSP PprDebug new_ids,
1844 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids),
1845 ppAboves (map pprCI (concat equiv_ciss))]))
1846 (returnSM ([], emptyUDs, []))
1849 (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
1850 tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
1852 no_of_tyvars = length tyvar_tmpls
1853 no_of_dicts = length class_tyvar_pairs
1855 do_this_class equiv_cis
1856 = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
1858 (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
1859 do_cis = head (normal_cis ++ explicit_cis)
1860 -- must choose a normal_cis in preference since dict_args will
1861 -- not be defined for an explicit_cis
1863 -- same_overloading tests whether the types of all the binders
1864 -- are "compatible"; ie have the same type and dictionary abstractions
1865 -- Almost always this is the case, because a recursive group is abstracted
1866 -- all together. But, it can happen that it ain't the case, because of
1867 -- code generated from instance decls:
1870 -- dfun.Foo.Int :: (forall a. a -> Int, Int)
1871 -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
1873 -- const.op1.Int :: forall a. a -> Int
1874 -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
1876 -- const.op2.Int :: Int
1877 -- const.op2.Int = 3
1879 -- Note that the first two defns have different polymorphism, but they are
1880 -- mutually recursive!
1882 same_overloading :: Id -> Bool
1884 = no_of_tyvars == length this_id_tyvars
1885 -- Same no of tyvars
1886 && no_of_dicts == length this_id_class_tyvar_pairs
1887 -- Same no of vdicts
1888 && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
1889 && length class_tyvar_pairs == length this_id_class_tyvar_pairs
1892 (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
1893 tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
1895 same_ov (clas1,tyvar1) (clas2,tyvar2)
1897 tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
1901 - a call instance eg f [t1,t2,t3] [d1,d2]
1902 - the rhs of the function eg orig_rhs
1903 - a constraint vector, saying which of eg [T,F,T]
1904 the functions type args are constrained
1907 We return a new definition
1909 f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2
1911 The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
1913 SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
1915 Based on this SpecInfo, a call instance of f
1917 ...(f t1 t2 t3 d1 d2)...
1919 should get replaced by
1923 (But that is the business of @mkCall@.)
1926 mkOneInst :: CallInstance
1927 -> [CallInstance] -- Any explicit cis for this inst
1928 -> Int -- No of dicts to specialise
1929 -> Bool -- Top level binders?
1930 -> [CallInstance] -- Instantiated call insts for binders
1931 -> [Id] -- New binders
1932 -> CoreBinding -- Unprocessed
1933 -> SpecM (Maybe CoreBinding, -- Instantiated version of input
1935 [Maybe SpecInfo] -- One for each id in the original binding
1938 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
1939 no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
1940 = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
1941 `thenSM` \ spec_ids ->
1942 newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
1944 -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
1945 -- which correspond to unspeciailsed args
1947 (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
1950 args = map TyArg arg_tys ++ dict_args
1952 (new_id:_) = new_ids
1953 (spec_id:_) = spec_ids
1955 do_bind (NonRec orig_id rhs)
1956 = do_one_rhs (spec_id, new_id, (orig_id,rhs))
1957 `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
1959 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
1960 Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
1963 = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
1964 `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
1965 returnSM (Just (Rec (catMaybes maybe_pairs)),
1966 unionUDList rhss_uds_s, spec_infos)
1968 do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
1970 -- Avoid duplicating a spec which has already been created ...
1971 -- This can arise in a Rec involving a dfun for which a
1972 -- a specialised instance has been created but specialisation
1973 -- "required" by one of the other Ids in the Rec
1974 | top_lev && maybeToBool lookup_orig_spec
1975 = (if opt_SpecialiseTrace
1976 then trace_nospec " Exists: " exists_id
1979 returnSM (Nothing, emptyUDs, Nothing)
1982 -- Check for a (single) explicit call instance for this id
1983 | not (null explicit_cis_for_this_id)
1984 = ASSERT (length explicit_cis_for_this_id == 1)
1985 (if opt_SpecialiseTrace
1986 then trace_nospec " Explicit: " explicit_id
1989 returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
1992 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
1994 = ASSERT (no_of_dicts_to_specialise == length dict_args)
1995 specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
1997 -- For a local binding we dump the usage details, creating
1998 -- any local dict bindings required
1999 -- At the top-level the uds will be dumped in specBindAndScope
2000 -- and the dict bindings made *global*
2002 (local_dict_binds, final_uds)
2003 = if not top_lev then
2004 dumpUDs inst_uds False False inst_cis new_ids []
2008 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
2010 if isUnboxedType (idType spec_id) then
2011 ASSERT (null poly_tyvars)
2012 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2013 mkTyConInstance liftDataCon [idType unlift_spec_id]
2014 `thenSM` \ lift_uds ->
2015 returnSM (Just (lift_spec_id,
2016 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
2017 tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
2019 returnSM (Just (spec_id,
2020 mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
2021 tickSpecInsts final_uds, spec_info)
2023 lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
2024 Just (exists_id, _, _) = lookup_orig_spec
2026 explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
2027 [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
2028 SpecInfo _ _ explicit_id = explicit_spec_info
2030 trace_nospec :: String -> Id -> a -> a
2031 trace_nospec str spec_id
2033 (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys),
2034 ppStr "==>", ppr PprDebug spec_id])
2036 (if opt_SpecialiseTrace then
2037 pprTrace "Specialising:"
2038 (ppHang (ppBesides [ppStr "{",
2039 interppSP PprDebug new_ids,
2042 ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
2043 if isExplicitCI do_cis then ppNil else
2044 ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
2045 ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
2048 do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
2050 returnSM (maybe_inst_bind, inst_uds, spec_infos)
2053 pp_dict d = ppr_arg PprDebug d
2054 pp_ty t = pprParendGenType PprDebug t
2056 do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
2057 do_the_wotsit tyvars (Just ty) = (tyvars, ty)
2061 %************************************************************************
2063 \subsection[Misc]{Miscellaneous junk}
2065 %************************************************************************
2068 mkCallInstance :: Id
2070 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2071 -> SpecM UsageDetails
2073 mkCallInstance id new_id []
2076 mkCallInstance id new_id args
2078 -- No specialised versions for "error" and friends are req'd.
2079 -- This is a special case in core lint etc.
2084 -- No call instances for SuperDictSelIds
2085 -- These are a special case in mkCall
2087 | maybeToBool (isSuperDictSelId_maybe id)
2090 -- There are also no call instances for ClassOpIds
2091 -- However, we need to process it to get any second-level call
2092 -- instances for a ConstMethodId extracted from its SpecEnv
2096 spec_overloading = opt_SpecialiseOverloaded
2097 spec_unboxed = opt_SpecialiseUnboxed
2098 spec_all = opt_SpecialiseAll
2100 (tyvars, class_tyvar_pairs) = getIdOverloading id
2102 arg_res = take_type_args tyvars class_tyvar_pairs args
2103 enough_args = maybeToBool arg_res
2105 (Just (tys, dicts, rest_args)) = arg_res
2108 = (record, lookup, spec_tys)
2110 spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
2111 (mkConstraintVector id) tys
2113 record = any (not . isTyVarTy) (catMaybes spec_tys)
2115 lookup = lookupSpecEnv (getIdSpecialisation id) tys
2117 if (not enough_args) then
2118 pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
2119 (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args]))
2121 case record_spec id tys of
2123 -> -- pprTrace "CallInst:NotReqd\n"
2124 -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
2127 (True, Nothing, spec_tys)
2128 -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
2131 -- pprTrace "CallInst:Reqd\n"
2132 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2133 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
2134 -- ppCat (map (ppr PprDebug) dicts)]])
2135 (returnSM (singleCI new_id spec_tys dicts))
2137 (True, Just (spec_id, tys_left, toss), _)
2138 -> if maybeToBool (isConstMethodId_maybe spec_id) then
2139 -- If we got a const method spec_id see if further spec required
2140 -- NB: const method is top-level so spec_id will not be cloned
2141 case record_spec spec_id tys_left of
2143 -> -- pprTrace "CallInst:Exists\n"
2144 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2145 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2146 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2149 (True, Nothing, spec_tys)
2150 -> -- pprTrace "CallInst:Exists:Reqd\n"
2151 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2152 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2153 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2154 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
2155 -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
2156 (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
2158 (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
2159 -> -- pprTrace "CallInst:Exists:Exists\n"
2160 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2161 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2162 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2163 -- ppCat [ppStr "->", ppr PprDebug spec_spec_id,
2164 -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
2168 -- pprTrace "CallInst:Exists\n"
2169 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2170 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2171 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2175 take_type_args (_:tyvars) class_tyvar_pairs ((TyArg ty,_,_):args)
2176 = case (take_type_args tyvars class_tyvar_pairs args) of
2178 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2180 take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing
2182 take_type_args [] class_tyvar_pairs args
2183 = case (take_dict_args class_tyvar_pairs args) of
2185 Just (dicts, others) -> Just ([], dicts, others)
2187 take_dict_args (_:class_tyvar_pairs) ((dict,_,_):args) | isValArg dict
2188 = case (take_dict_args class_tyvar_pairs args) of
2190 Just (dicts, others) -> Just (dict:dicts, others)
2192 take_dict_args (_:class_tyvar_pairs) [] = Nothing
2194 take_dict_args [] args = Just ([], args)
2199 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2200 -> SpecM (Bool, CoreExpr)
2203 | maybeToBool (isSuperDictSelId_maybe new_id)
2204 && any isUnboxedType ty_args
2205 -- No specialisations for super-dict selectors
2206 -- Specialise unboxed calls to SuperDictSelIds by extracting
2207 -- the super class dictionary directly form the super class
2208 -- NB: This should be dead code since all uses of this dictionary should
2209 -- have been specialised. We only do this to keep core-lint happy.
2211 Just (_, super_class) = isSuperDictSelId_maybe new_id
2212 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2213 Nothing -> panic "Specialise:mkCall:SuperDictId"
2216 returnSM (False, Var super_dict_id)
2219 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2220 Nothing -> checkUnspecOK new_id ty_args (
2221 returnSM (False, unspec_call)
2224 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2226 -- It may be necessary to specialsie a constant method spec_id again
2227 (spec_id, tys_left, dicts_to_toss) =
2228 case (maybeToBool (isConstMethodId_maybe spec_id_1),
2229 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2230 (False, _ ) -> spec_1_details
2231 (True, Nothing) -> spec_1_details
2232 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2233 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2235 args_left = toss_dicts dicts_to_toss val_args
2237 checkSpecOK new_id ty_args spec_id tys_left (
2239 -- The resulting spec_id may be a top-level unboxed value
2240 -- This can arise for:
2241 -- 1) constant method values
2242 -- eq: class Num a where pi :: a
2243 -- instance Num Double# where pi = 3.141#
2244 -- 2) specilised overloaded values
2245 -- eq: i1 :: Num a => a
2246 -- i1 Int# d.Num.Int# ==> i1.Int#
2247 -- These top level defns should have been lifted.
2248 -- We must add code to unlift such a spec_id.
2250 if isUnboxedType (idType spec_id) then
2251 ASSERT (null tys_left && null args_left)
2252 if toplevelishId spec_id then
2253 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2254 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2255 (Var unlift_spec_id))
2257 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2258 (ppCat [ppr PprDebug new_id,
2259 ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
2261 ppr PprDebug spec_id])
2264 (vals_left, _, unlifts_left) = unzip3 args_left
2265 applied_tys = mkTyApp (Var spec_id) tys_left
2266 applied_vals = mkGenApp applied_tys vals_left
2268 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2271 (tys_and_vals, _, unlifts) = unzip3 args
2272 unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2275 -- ty_args is the types at the front of the arg list
2276 -- val_args is the rest of the arg-list
2278 (ty_args, val_args) = get args
2280 get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2281 get args = ([], args)
2284 -- toss_dicts chucks away dict args, checking that they ain't types!
2285 toss_dicts 0 args = args
2286 toss_dicts n ((a,_,_) : args)
2287 | isValArg a = toss_dicts (n-1) args
2292 checkUnspecOK :: Id -> [Type] -> a -> a
2293 checkUnspecOK check_id tys
2294 = if isLocallyDefined check_id && any isUnboxedType tys
2295 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2296 (ppCat [ppr PprDebug check_id,
2297 ppInterleave ppNil (map (pprParendGenType PprDebug) tys)])
2300 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2301 checkSpecOK check_id tys spec_id tys_left
2302 = if any isUnboxedType tys_left
2303 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2304 (ppAboves [ppCat [ppr PprDebug check_id,
2305 ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
2306 ppCat [ppr PprDebug spec_id,
2307 ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
2312 mkTyConInstance :: Id
2314 -> SpecM UsageDetails
2315 mkTyConInstance con tys
2316 = recordTyConInst con tys `thenSM` \ record_inst ->
2318 Nothing -- No TyCon instance
2319 -> -- pprTrace "NoTyConInst:"
2320 -- (ppCat [ppr PprDebug tycon, ppStr "at",
2321 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
2322 (returnSM (singleConUDs con))
2324 Just spec_tys -- Record TyCon instance
2325 -> -- pprTrace "TyConInst:"
2326 -- (ppCat [ppr PprDebug tycon, ppStr "at",
2327 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
2328 -- ppBesides [ppStr "(",
2329 -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
2331 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2333 tycon = dataConTyCon con
2337 recordTyConInst :: Id
2339 -> SpecM (Maybe [Maybe Type])
2341 recordTyConInst con tys
2343 spec_tys = specialiseConstrTys tys
2345 do_tycon_spec = maybeToBool (firstJust spec_tys)
2347 spec_exists = maybeToBool (lookupSpecEnv
2348 (getIdSpecialisation con)
2351 -- pprTrace "ConSpecExists?: "
2352 -- (ppAboves [ppStr (if spec_exists then "True" else "False"),
2353 -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
2354 (if (not spec_exists && do_tycon_spec)
2355 then returnSM (Just spec_tys)
2356 else returnSM Nothing)
2359 %************************************************************************
2361 \subsection[monad-Specialise]{Monad used in specialisation}
2363 %************************************************************************
2367 inherited: control flags and
2368 recordInst functions with flags cached
2370 environment mapping tyvars to types
2371 environment mapping Ids to Atoms
2373 threaded in and out: unique supply
2376 type TypeEnv = TyVarEnv Type
2385 = m nullTyVarEnv nullIdEnv uniqs
2387 returnSM :: a -> SpecM a
2388 thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
2389 fixSM :: (a -> SpecM a) -> SpecM a
2391 thenSM m k tvenv idenv us
2392 = case splitUniqSupply us of { (s1, s2) ->
2393 case (m tvenv idenv s1) of { r ->
2394 k r tvenv idenv s2 }}
2396 returnSM r tvenv idenv us = r
2398 fixSM k tvenv idenv us
2401 r = k r tvenv idenv us -- Recursive in r!
2404 The only interesting bit is figuring out the type of the SpecId!
2407 newSpecIds :: [Id] -- The id of which to make a specialised version
2408 -> [Maybe Type] -- Specialise to these types
2409 -> Int -- No of dicts to specialise
2412 newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
2413 = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2414 | (id,uniq) <- new_ids `zip` uniqs ]
2416 uniqs = getUniques (length new_ids) us
2417 spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2419 newTyVars :: Int -> SpecM [TyVar]
2420 newTyVars n tvenv idenv us
2421 = map mkPolySysTyVar uniqs
2423 uniqs = getUniques n us
2426 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2427 binders, and build ``clones'' for them. The clones differ from the
2428 originals in three ways:
2430 (a) they have a fresh unique
2431 (b) they have the current type environment applied to their type
2432 (c) for Let binders which have been specialised to unboxed values
2433 the clone will have a lifted type
2435 As well as returning the list of cloned @Id@s they also return a list of
2436 @CloneInfo@s which the original binders should be bound to.
2439 cloneLambdaOrCaseBinders :: [Id] -- Old binders
2440 -> SpecM ([Id], [CloneInfo]) -- New ones
2442 cloneLambdaOrCaseBinders old_ids tvenv idenv us
2444 uniqs = getUniques (length old_ids) us
2446 unzip (zipWithEqual clone_it old_ids uniqs)
2448 clone_it old_id uniq
2449 = (new_id, NoLift (VarArg new_id))
2451 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2453 cloneLetBinders :: Bool -- Top level ?
2454 -> Bool -- Recursice
2455 -> [Id] -- Old binders
2456 -> SpecM ([Id], [CloneInfo]) -- New ones
2458 cloneLetBinders top_lev is_rec old_ids tvenv idenv us
2460 uniqs = getUniques (2 * length old_ids) us
2462 unzip (clone_them old_ids uniqs)
2464 clone_them [] [] = []
2466 clone_them (old_id:olds) (u1:u2:uniqs)
2469 NoLift (VarArg old_id)) : clone_rest
2471 -- Don't clone if it is a top-level thing. Why not?
2472 -- (a) we don't want to change the uniques
2473 -- on such things (see TopLevId in Id.lhs)
2474 -- (b) we don't have to be paranoid about name capture
2475 -- (c) the thing is polymorphic so no need to subst
2478 = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
2480 Lifted lifted_id unlifted_id) : clone_rest
2482 NoLift (VarArg new_id)) : clone_rest
2485 clone_rest = clone_them olds uniqs
2487 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2488 new_ty = idType new_id
2489 old_ty = idType old_id
2491 (lifted_id, unlifted_id) = mkLiftedId new_id u2
2494 cloneTyVarSM :: TyVar -> SpecM TyVar
2496 cloneTyVarSM old_tyvar tvenv idenv us
2500 cloneTyVar old_tyvar uniq -- new_tyvar
2502 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2504 bindId id val specm tvenv idenv us
2505 = specm tvenv (addOneToIdEnv idenv id val) us
2507 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2509 bindIds olds news specm tvenv idenv us
2510 = specm tvenv (growIdEnvList idenv (zip olds news)) us
2512 bindSpecIds :: [Id] -- Old
2513 -> [(CloneInfo)] -- New
2514 -> [[Maybe SpecInfo]] -- Corresponding specialisations
2515 -- Each sub-list corresponds to a different type,
2516 -- and contains one Maybe spec_info for each id
2520 bindSpecIds olds clones spec_infos specm tvenv idenv us
2521 = specm tvenv (growIdEnvList idenv old_to_clone) us
2523 old_to_clone = mk_old_to_clone olds clones spec_infos
2525 -- The important thing here is that we are *lazy* in spec_infos
2526 mk_old_to_clone [] [] _ = []
2527 mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2528 = (old, add_spec_info clone) :
2529 mk_old_to_clone rest_olds rest_clones spec_infos_rest
2531 add_spec_info (NoLift (VarArg new))
2532 = NoLift (VarArg (new `addIdSpecialisation`
2533 (mkSpecEnv spec_infos_this_id)))
2534 add_spec_info lifted
2535 = lifted -- no specialised instances for unboxed lifted values
2537 spec_infos_this_id = catMaybes (map head spec_infos)
2538 spec_infos_rest = map tail spec_infos
2541 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2543 bindTyVar tyvar ty specm tvenv idenv us
2544 = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2548 lookupId :: Id -> SpecM CloneInfo
2550 lookupId id tvenv idenv us
2551 = case lookupIdEnv idenv id of
2552 Nothing -> NoLift (VarArg id)
2557 specTy :: Type -> SpecM Type -- Apply the current type envt to the type
2559 specTy ty tvenv idenv us
2560 = applyTypeEnvToTy tvenv ty
2564 liftId :: Id -> SpecM (Id, Id)
2565 liftId id tvenv idenv us
2572 In other monads these @mapSM@ things are usually called @listM@.
2573 I think @mapSM@ is a much better name. The `2' and `3' variants are
2574 when you want to return two or three results, and get at them
2575 separately. It saves you having to do an (unzip stuff) right after.
2578 mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
2579 mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
2580 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2581 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2583 mapSM f [] = returnSM []
2584 mapSM f (x:xs) = f x `thenSM` \ r ->
2585 mapSM f xs `thenSM` \ rs ->
2588 mapAndUnzipSM f [] = returnSM ([],[])
2589 mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
2590 mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
2591 returnSM ((r1:rs1),(r2:rs2))
2593 mapAndUnzip3SM f [] = returnSM ([],[],[])
2594 mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
2595 mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
2596 returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2598 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2599 mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
2600 mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
2601 returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))