2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
14 #include "HsVersions.h"
16 import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
17 partitionBag, listToBag, bagToList, Bag
19 import Class ( Class )
20 import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
23 import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
25 import CoreUtils ( coreExprType, squashableDictishCcExpr )
26 import FiniteMap ( addListToFM_C, FiniteMap )
27 import Kind ( mkBoxedTypeKind, isBoxedTypeKind )
28 import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
29 isSuperDictSelId_maybe, isBottomingId,
31 isImportedId, mkIdWithNewUniq,
32 dataConTyCon, applyTypeEnvToId,
33 nullIdEnv, addOneToIdEnv, growIdEnvList,
35 emptyIdSet, mkIdSet, unitIdSet,
36 elementOfIdSet, minusIdSet,
37 unionIdSets, unionManyIdSets, IdSet,
38 GenId{-instance Eq-}, Id
40 import Literal ( Literal{-instance Outputable-} )
41 import Maybes ( catMaybes, firstJust, maybeToBool )
42 import Name ( isLocallyDefined )
43 import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
44 GenType{-instance Outputable-}, GenTyVar{-ditto-},
47 import PrimOp ( PrimOp(..) )
49 import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp,
50 tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy,
53 import TyCon ( TyCon{-instance Eq-} )
54 import TyVar ( cloneTyVar, mkSysTyVar,
55 elementOfTyVarSet, TyVarSet,
56 emptyTyVarEnv, growTyVarEnvList, TyVarEnv,
57 GenTyVar{-instance Eq-}
59 import TysWiredIn ( liftDataCon )
60 import Unique ( Unique{-instance Eq-} )
61 import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
62 import UniqSupply ( splitUniqSupply, getUniques, getUnique )
63 import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
66 import List ( partition )
71 specProgram = panic "SpecProgram"
74 data SpecInfo = SpecInfo [Maybe Type] Int Id
78 lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
79 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
80 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
81 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
82 isClassOpId = panic "Specialise.isClassOpId (ToDo)"
83 isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
84 isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
85 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
86 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
87 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
88 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
89 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
90 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
91 specialiseTy = panic "Specialise.specialiseTy (ToDo)"
94 %************************************************************************
96 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
98 %************************************************************************
100 These notes describe how we implement specialisation to eliminate
101 overloading, and optionally to eliminate unboxed polymorphism, and
104 The specialisation pass is a partial evaluator which works on Core
105 syntax, complete with all the explicit dictionary application,
106 abstraction and construction as added by the type checker. The
107 existing type checker remains largely as it is.
109 One important thought: the {\em types} passed to an overloaded
110 function, and the {\em dictionaries} passed are mutually redundant.
111 If the same function is applied to the same type(s) then it is sure to
112 be applied to the same dictionary(s)---or rather to the same {\em
113 values}. (The arguments might look different but they will evaluate
116 Second important thought: we know that we can make progress by
117 treating dictionary arguments as static and worth specialising on. So
118 we can do without binding-time analysis, and instead specialise on
119 dictionary arguments and no others.
128 and suppose f is overloaded.
130 STEP 1: CALL-INSTANCE COLLECTION
132 We traverse <body>, accumulating all applications of f to types and
135 (Might there be partial applications, to just some of its types and
136 dictionaries? In principle yes, but in practice the type checker only
137 builds applications of f to all its types and dictionaries, so partial
138 applications could only arise as a result of transformation, and even
139 then I think it's unlikely. In any case, we simply don't accumulate such
140 partial applications.)
142 There's a choice of whether to collect details of all *polymorphic* functions
143 or simply all *overloaded* ones. How to sort this out?
144 Pass in a predicate on the function to say if it is "interesting"?
145 This is dependent on the user flags: SpecialiseOverloaded
151 So now we have a collection of calls to f:
155 Notice that f may take several type arguments. To avoid ambiguity, we
156 say that f is called at type t1/t2 and t3/t4.
158 We take equivalence classes using equality of the *types* (ignoring
159 the dictionary args, which as mentioned previously are redundant).
161 STEP 3: SPECIALISATION
163 For each equivalence class, choose a representative (f t1 t2 d1 d2),
164 and create a local instance of f, defined thus:
166 f@t1/t2 = <f_rhs> t1 t2 d1 d2
168 (f_rhs presumably has some big lambdas and dictionary lambdas, so lots
169 of simplification will now result.) Then we should recursively do
172 The new id has its own unique, but its print-name (if exported) has
173 an explicit representation of the instance types t1/t2.
175 Add this new id to f's IdInfo, to record that f has a specialised version.
177 Before doing any of this, check that f's IdInfo doesn't already
178 tell us about an existing instance of f at the required type/s.
179 (This might happen if specialisation was applied more than once, or
180 it might arise from user SPECIALIZE pragmas.)
184 Wait a minute! What if f is recursive? Then we can't just plug in
185 its right-hand side, can we?
187 But it's ok. The type checker *always* creates non-recursive definitions
188 for overloaded recursive functions. For example:
190 f x = f (x+x) -- Yes I know its silly
194 f a (d::Num a) = let p = +.sel a d
196 letrec fl (y::a) = fl (p y y)
200 We still have recusion for non-overloadd functions which we
201 speciailise, but the recursive call should get speciailised to the
202 same recursive version.
208 All this is crystal clear when the function is applied to *constant
209 types*; that is, types which have no type variables inside. But what if
210 it is applied to non-constant types? Suppose we find a call of f at type
211 t1/t2. There are two possibilities:
213 (a) The free type variables of t1, t2 are in scope at the definition point
214 of f. In this case there's no problem, we proceed just as before. A common
215 example is as follows. Here's the Haskell:
220 After typechecking we have
222 g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
223 in +.sel a d (f a d y) (f a d y)
225 Notice that the call to f is at type type "a"; a non-constant type.
226 Both calls to f are at the same type, so we can specialise to give:
228 g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
229 in +.sel a d (f@a y) (f@a y)
232 (b) The other case is when the type variables in the instance types
233 are *not* in scope at the definition point of f. The example we are
234 working with above is a good case. There are two instances of (+.sel a d),
235 but "a" is not in scope at the definition of +.sel. Can we do anything?
236 Yes, we can "common them up", a sort of limited common sub-expression deal.
239 g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
240 f@a (x::a) = +.sel@a x x
241 in +.sel@a (f@a y) (f@a y)
243 This can save work, and can't be spotted by the type checker, because
244 the two instances of +.sel weren't originally at the same type.
248 * There are quite a few variations here. For example, the defn of
249 +.sel could be floated ouside the \y, to attempt to gain laziness.
250 It certainly mustn't be floated outside the \d because the d has to
253 * We don't want to inline f_rhs in this case, because
254 that will duplicate code. Just commoning up the call is the point.
256 * Nothing gets added to +.sel's IdInfo.
258 * Don't bother unless the equivalence class has more than one item!
260 Not clear whether this is all worth it. It is of course OK to
261 simply discard call-instances when passing a big lambda.
263 Polymorphism 2 -- Overloading
265 Consider a function whose most general type is
267 f :: forall a b. Ord a => [a] -> b -> b
269 There is really no point in making a version of g at Int/Int and another
270 at Int/Bool, because it's only instancing the type variable "a" which
271 buys us any efficiency. Since g is completely polymorphic in b there
272 ain't much point in making separate versions of g for the different
275 That suggests that we should identify which of g's type variables
276 are constrained (like "a") and which are unconstrained (like "b").
277 Then when taking equivalence classes in STEP 2, we ignore the type args
278 corresponding to unconstrained type variable. In STEP 3 we make
279 polymorphic versions. Thus:
281 f@t1/ = /\b -> <f_rhs> t1 b d1 d2
283 This seems pretty simple, and a Good Thing.
285 Polymorphism 3 -- Unboxed
288 If we are speciailising at unboxed types we must speciailise
289 regardless of the overloading constraint. In the exaple above it is
290 worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
293 Note that specialising an overloaded type at an uboxed type requires
294 an unboxed instance -- we cannot default to an unspecialised version!
301 f x = let g p q = p==q
307 Before specialisation, leaving out type abstractions we have
309 f df x = let g :: Eq a => a -> a -> Bool
311 h :: Num a => a -> a -> (a, Bool)
312 h dh r s = let deq = eqFromNum dh
313 in (+ dh r s, g deq r s)
317 After specialising h we get a specialised version of h, like this:
319 h' r s = let deq = eqFromNum df
320 in (+ df r s, g deq r s)
322 But we can't naively make an instance for g from this, because deq is not in scope
323 at the defn of g. Instead, we have to float out the (new) defn of deq
324 to widen its scope. Notice that this floating can't be done in advance -- it only
325 shows up when specialisation is done.
327 DELICATE MATTER: the way we tell a dictionary binding is by looking to
328 see if it has a Dict type. If the type has been "undictify'd", so that
329 it looks like a tuple, then the dictionary binding won't be floated, and
330 an opportunity to specialise might be lost.
332 User SPECIALIZE pragmas
333 ~~~~~~~~~~~~~~~~~~~~~~~
334 Specialisation pragmas can be digested by the type checker, and implemented
335 by adding extra definitions along with that of f, in the same way as before
337 f@t1/t2 = <f_rhs> t1 t2 d1 d2
339 Indeed the pragmas *have* to be dealt with by the type checker, because
340 only it knows how to build the dictionaries d1 and d2! For example
342 g :: Ord a => [a] -> [a]
343 {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
345 Here, the specialised version of g is an application of g's rhs to the
346 Ord dictionary for (Tree Int), which only the type checker can conjure
347 up. There might not even *be* one, if (Tree Int) is not an instance of
348 Ord! (All the other specialision has suitable dictionaries to hand
351 Problem. The type checker doesn't have to hand a convenient <f_rhs>, because
352 it is buried in a complex (as-yet-un-desugared) binding group.
355 f@t1/t2 = f* t1 t2 d1 d2
357 where f* is the Id f with an IdInfo which says "inline me regardless!".
358 Indeed all the specialisation could be done in this way.
359 That in turn means that the simplifier has to be prepared to inline absolutely
360 any in-scope let-bound thing.
363 Again, the pragma should permit polymorphism in unconstrained variables:
365 h :: Ord a => [a] -> b -> b
366 {-# SPECIALIZE h :: [Int] -> b -> b #-}
368 We *insist* that all overloaded type variables are specialised to ground types,
369 (and hence there can be no context inside a SPECIALIZE pragma).
370 We *permit* unconstrained type variables to be specialised to
372 - or left as a polymorphic type variable
373 but nothing in between. So
375 {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
377 is *illegal*. (It can be handled, but it adds complication, and gains the
381 SPECIALISING INSTANCE DECLARATIONS
382 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
385 instance Foo a => Foo [a] where
387 {-# SPECIALIZE instance Foo [Int] #-}
389 The original instance decl creates a dictionary-function
392 dfun.Foo.List :: forall a. Foo a -> Foo [a]
394 The SPECIALIZE pragma just makes a specialised copy, just as for
395 ordinary function definitions:
397 dfun.Foo.List@Int :: Foo [Int]
398 dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
400 The information about what instance of the dfun exist gets added to
401 the dfun's IdInfo in the same way as a user-defined function too.
403 In fact, matters are a little bit more complicated than this.
404 When we make one of these specialised instances, we are defining
405 a constant dictionary, and so we want immediate access to its constant
406 methods and superclasses. Indeed, these constant methods and superclasses
407 must be in the IdInfo for the class selectors! We need help from the
408 typechecker to sort this out, perhaps by generating a separate IdInfo
411 Automatic instance decl specialisation?
412 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
413 Can instance decls be specialised automatically? It's tricky.
414 We could collect call-instance information for each dfun, but
415 then when we specialised their bodies we'd get new call-instances
416 for ordinary functions; and when we specialised their bodies, we might get
417 new call-instances of the dfuns, and so on. This all arises because of
418 the unrestricted mutual recursion between instance decls and value decls.
420 Furthermore, instance decls are usually exported and used non-locally,
421 so we'll want to compile enough to get those specialisations done.
423 Lastly, there's no such thing as a local instance decl, so we can
424 survive solely by spitting out *usage* information, and then reading that
425 back in as a pragma when next compiling the file. So for now,
426 we only specialise instance decls in response to pragmas.
428 That means that even if an instance decl ain't otherwise exported it
429 needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
430 something to say which module defined the instance, so the usage info
431 can be fed into the right reqts info file. Blegh.
434 SPECIAILISING DATA DECLARATIONS
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
437 With unboxed specialisation (or full specialisation) we also require
438 data types (and their constructors) to be speciailised on unboxed
441 In addition to normal call instances we gather TyCon call instances at
442 unboxed types, determine equivalence classes for the locally defined
443 TyCons and build speciailised data constructor Ids for each TyCon and
444 substitute these in the Con calls.
446 We need the list of local TyCons to partition the TyCon instance info.
447 We pass out a FiniteMap from local TyCons to Specialised Instances to
448 give to the interface and code genertors.
450 N.B. The specialised data constructors reference the original data
451 constructor and type constructor which do not have the updated
452 specialisation info attached. Any specialisation info must be
453 extracted from the TyCon map returned.
456 SPITTING OUT USAGE INFORMATION
457 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
459 To spit out usage information we need to traverse the code collecting
460 call-instance information for all imported (non-prelude?) functions
461 and data types. Then we equivalence-class it and spit it out.
463 This is done at the top-level when all the call instances which escape
464 must be for imported functions and data types.
467 Partial specialisation by pragmas
468 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
469 What about partial specialisation:
471 k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
472 {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
476 {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
478 Seems quite reasonable. Similar things could be done with instance decls:
480 instance (Foo a, Foo b) => Foo (a,b) where
482 {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
483 {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
485 Ho hum. Things are complex enough without this. I pass.
488 Requirements for the simplifer
489 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
490 The simplifier has to be able to take advantage of the specialisation.
492 * When the simplifier finds an application of a polymorphic f, it looks in
493 f's IdInfo in case there is a suitable instance to call instead. This converts
495 f t1 t2 d1 d2 ===> f_t1_t2
497 Note that the dictionaries get eaten up too!
499 * Dictionary selection operations on constant dictionaries must be
502 +.sel Int d ===> +Int
504 The obvious way to do this is in the same way as other specialised
505 calls: +.sel has inside it some IdInfo which tells that if it's applied
506 to the type Int then it should eat a dictionary and transform to +Int.
508 In short, dictionary selectors need IdInfo inside them for constant
511 * Exactly the same applies if a superclass dictionary is being
514 Eq.sel Int d ===> dEqInt
516 * Something similar applies to dictionary construction too. Suppose
517 dfun.Eq.List is the function taking a dictionary for (Eq a) to
518 one for (Eq [a]). Then we want
520 dfun.Eq.List Int d ===> dEq.List_Int
522 Where does the Eq [Int] dictionary come from? It is built in
523 response to a SPECIALIZE pragma on the Eq [a] instance decl.
525 In short, dfun Ids need IdInfo with a specialisation for each
526 constant instance of their instance declaration.
529 What does the specialisation IdInfo look like?
530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
533 [Maybe Type] -- Instance types
534 Int -- No of dicts to eat
535 Id -- Specialised version
537 For example, if f has this SpecInfo:
539 SpecInfo [Just t1, Nothing, Just t3] 2 f'
543 f t1 t2 t3 d1 d2 ===> f t2
545 The "Nothings" identify type arguments in which the specialised
546 version is polymorphic.
548 What can't be done this way?
549 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
550 There is no way, post-typechecker, to get a dictionary for (say)
551 Eq a from a dictionary for Eq [a]. So if we find
555 we can't transform to
560 eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
562 Of course, we currently have no way to automatically derive
563 eqList, nor to connect it to the Eq [a] instance decl, but you
564 can imagine that it might somehow be possible. Taking advantage
565 of this is permanently ruled out.
567 Still, this is no great hardship, because we intend to eliminate
568 overloading altogether anyway!
573 What about types/classes mentioned in SPECIALIZE pragmas spat out,
574 but not otherwise exported. Even if they are exported, what about
575 their original names.
577 Suggestion: use qualified names in pragmas, omitting module for
578 prelude and "this module".
585 f a (d::Num a) = let g = ...
587 ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
589 Here, g is only called at one type, but the dictionary isn't in scope at the
590 definition point for g. Usually the type checker would build a
591 definition for d1 which enclosed g, but the transformation system
592 might have moved d1's defn inward.
598 What should we do when a value is specialised to a *strict* unboxed value?
600 map_*_* f (x:xs) = let h = f x
604 Could convert let to case:
606 map_*_Int# f (x:xs) = case f x of h# ->
610 This may be undesirable since it forces evaluation here, but the value
611 may not be used in all branches of the body. In the general case this
612 transformation is impossible since the mutual recursion in a letrec
613 cannot be expressed as a case.
615 There is also a problem with top-level unboxed values, since our
616 implementation cannot handle unboxed values at the top level.
618 Solution: Lift the binding of the unboxed value and extract it when it
621 map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
626 Now give it to the simplifier and the _Lifting will be optimised away.
628 The benfit is that we have given the specialised "unboxed" values a
629 very simple lifted semantics and then leave it up to the simplifier to
630 optimise it --- knowing that the overheads will be removed in nearly
633 In particular, the value will only be evaluted in the branches of the
634 program which use it, rather than being forced at the point where the
635 value is bound. For example:
637 filtermap_*_* p f (x:xs)
644 filtermap_*_Int# p f (x:xs)
645 = let h = case (f x) of h# -> _Lift h#
648 True -> case h of _Lift h#
652 The binding for h can still be inlined in the one branch and the
656 Question: When won't the _Lifting be eliminated?
658 Answer: When they at the top-level (where it is necessary) or when
659 inlining would duplicate work (or possibly code depending on
660 options). However, the _Lifting will still be eliminated if the
661 strictness analyser deems the lifted binding strict.
664 A note about non-tyvar dictionaries
665 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
666 Some Ids have types like
668 forall a,b,c. Eq a -> Ord [a] -> tau
670 This seems curious at first, because we usually only have dictionary
671 args whose types are of the form (C a) where a is a type variable.
672 But this doesn't hold for the functions arising from instance decls,
673 which sometimes get arguements with types of form (C (T a)) for some
676 Should we specialise wrt this compound-type dictionary? We used to say
678 "This is a heuristic judgement, as indeed is the fact that we
679 specialise wrt only dictionaries. We choose *not* to specialise
680 wrt compound dictionaries because at the moment the only place
681 they show up is in instance decls, where they are simply plugged
682 into a returned dictionary. So nothing is gained by specialising
685 But it is simpler and more uniform to specialise wrt these dicts too;
686 and in future GHC is likely to support full fledged type signatures
688 f ;: Eq [(a,b)] => ...
691 %************************************************************************
693 \subsubsection[CallInstances]{@CallInstances@ data type}
695 %************************************************************************
698 type FreeVarsSet = IdSet
699 type FreeTyVarsSet = TyVarSet
703 Id -- This Id; *new* ie *cloned* id
704 [Maybe Type] -- Specialised at these types (*new*, cloned)
705 -- Nothing => no specialisation on this type arg
706 -- is required (flag dependent).
707 [CoreArg] -- And these dictionaries; all ValArgs
708 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
709 (Maybe SpecInfo) -- For specialisation with explicit SpecId
713 pprCI :: CallInstance -> Doc
714 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
715 = hang (hsep [ptext SLIT("Call inst for"), ppr id])
716 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]),
717 case maybe_specinfo of
718 Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts])
719 Just (SpecInfo _ _ spec_id)
720 -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id]
723 -- ToDo: instance Outputable CoreArg?
724 ppr_arg (TyArg t) = ppr sty t
725 ppr_arg (LitArg i) = ppr sty i
726 ppr_arg (VarArg v) = ppr sty v
728 isUnboxedCI :: CallInstance -> Bool
729 isUnboxedCI (CallInstance _ spec_tys _ _ _)
730 = any isUnboxedType (catMaybes spec_tys)
732 isExplicitCI :: CallInstance -> Bool
733 isExplicitCI (CallInstance _ _ _ _ (Just _))
735 isExplicitCI (CallInstance _ _ _ _ Nothing)
739 Comparisons are based on the {\em types}, ignoring the dictionary args:
743 cmpCI :: CallInstance -> CallInstance -> Ordering
744 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
745 = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
747 cmpCI_tys :: CallInstance -> CallInstance -> Ordering
748 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
749 = cmpUniTypeMaybeList tys1 tys2
751 eqCI_tys :: CallInstance -> CallInstance -> Bool
753 = case cmpCI_tys c1 c2 of { EQ -> True; other -> False }
755 isCIofTheseIds :: [Id] -> CallInstance -> Bool
756 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
757 = any ((==) ci_id) ids
759 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
760 singleCI id tys dicts
761 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
762 emptyBag [] emptyIdSet 0 0
764 fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
766 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
767 explicitCI id tys specinfo
768 = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
770 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
771 dicts = panic "Specialise:explicitCI:dicts"
772 fv_set = unitIdSet id
774 -- We do not process the CIs for top-level dfuns or defms
775 -- Instead we require an explicit SPEC inst pragma for dfuns
776 -- and an explict method within any instances for the defms
778 getCIids :: Bool -> [Id] -> [Id]
779 getCIids True ids = filter not_dict_or_defm ids
783 = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
785 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
786 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
788 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
789 cis_here_list = bagToList cis_here
791 -- pprTrace "getCIs:"
792 -- (hang (hcat [char '{',
795 -- 4 (vcat (map pprCI cis_here_list)))
796 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
798 dumpCIs :: Bag CallInstance -- The call instances
799 -> Bool -- True <=> top level bound Ids
800 -> Bool -- True <=> dict bindings to be floated (specBind only)
801 -> [CallInstance] -- Call insts for bound ids (instBind only)
802 -> [Id] -- Bound ids *new*
803 -> [Id] -- Full bound ids: includes dumped dicts
804 -> Bag CallInstance -- Kept call instances
806 -- CIs are dumped if:
807 -- 1) they are a CI for one of the bound ids, or
808 -- 2) they mention any of the dicts in a local unfloated binding
810 -- For top-level bindings we allow the call instances to
811 -- float past a dict bind and place all the top-level binds
812 -- in a *global* Rec.
813 -- We leave it to the simplifier will sort it all out ...
815 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
816 = (if not (isEmptyBag cis_of_bound_id) &&
817 not (isEmptyBag cis_of_bound_id_without_inst_cis)
819 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
820 " (may be a non-HM recursive call)\n")
821 (hang (hcat [char '{',
824 4 (vcat [ptext SLIT("Dumping CIs:"),
825 vcat (map pprCI (bagToList cis_of_bound_id)),
826 ptext SLIT("Instantiating CIs:"),
827 vcat (map pprCI inst_cis)]))
829 if top_lev || floating then
832 (if not (isEmptyBag cis_dump_unboxed)
833 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
834 (hang (hcat [char '{',
837 4 (vcat (map pprCI (bagToList cis_dump))))
839 cis_keep_not_bound_id
842 (cis_of_bound_id, cis_not_bound_id)
843 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
845 (cis_dump, cis_keep_not_bound_id)
846 = partitionBag ok_to_dump_ci cis_not_bound_id
848 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
849 = any (\ i -> i `elementOfIdSet` fv_set) full_ids
851 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
852 have_inst_ci ci = any (eqCI_tys ci) inst_cis
854 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
858 Any call instances of a bound_id can be safely dumped, because any
859 recursive calls should be at the same instance as the parent instance.
861 letrec f = /\a -> \x::a -> ...(f t x')...
863 Here, the type, t, at which f is used in its own RHS should be
864 just "a"; that is, the recursive call is at the same type as
865 the original call. That means that when specialising f at some
866 type, say Int#, we shouldn't find any *new* instances of f
867 arising from specialising f's RHS. The only instance we'll find
868 is another call of (f Int#).
870 We check this in dumpCIs by passing in all the instantiated call
871 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
872 for which there is no such instance.
874 We also report CIs dumped due to a bound dictionary arg if they
875 contain unboxed types.
877 %************************************************************************
879 \subsubsection[TyConInstances]{@TyConInstances@ data type}
881 %************************************************************************
885 = TyConInstance TyCon -- Type Constructor
886 [Maybe Type] -- Applied to these specialising types
888 cmpTyConI :: TyConInstance -> TyConInstance -> Ordering
889 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
890 = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
892 cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering
893 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
894 = cmpUniTypeMaybeList tys1 tys2
896 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
897 singleTyConI ty_con spec_tys
898 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
900 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
901 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
903 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
904 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
906 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
907 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
909 (tycon_cis_local, tycon_cis_global)
910 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
911 tycon_cis_local_list = bagToList tycon_cis_local
913 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
917 %************************************************************************
919 \subsubsection[UsageDetails]{@UsageDetails@ data type}
921 %************************************************************************
926 (Bag CallInstance) -- The collection of call-instances
927 (Bag TyConInstance) -- Constructor call-instances
928 [DictBindDetails] -- Dictionary bindings in data-dependence order!
929 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
930 Int -- no. of spec calls
931 Int -- no. of spec insts
934 The DictBindDetails are fully processed; their call-instance
935 information is incorporated in the call-instances of the UsageDetails
936 which includes the DictBindDetails. The free vars in a usage details
937 will *include* the binders of the DictBind details.
939 A @DictBindDetails@ contains bindings for dictionaries *only*.
944 [Id] -- Main binders, originally visible in scope of binding (cloned)
945 CoreBinding -- Fully processed
946 FreeVarsSet -- Free in binding group (cloned)
947 FreeTyVarsSet -- Free in binding group
951 emptyUDs :: UsageDetails
952 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
953 unionUDList :: [UsageDetails] -> UsageDetails
955 -- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
956 tickSpecInsts :: UsageDetails -> UsageDetails
958 -- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
959 -- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
961 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
962 = UsageDetails cis ty_cis dbs fvs c (i+1)
964 emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
966 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
967 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
968 (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
969 -- The append here is really redundant, since the bindings don't
970 -- scope over each other. ToDo.
972 unionUDList = foldr unionUDs emptyUDs
974 singleFvUDs (VarArg v) | not (isImportedId v)
975 = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
979 singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
981 dumpDBs :: [DictBindDetails]
982 -> Bool -- True <=> top level bound Ids
983 -> [TyVar] -- TyVars being bound (cloned)
984 -> [Id] -- Ids being bound (cloned)
985 -> FreeVarsSet -- Fvs of body
986 -> ([CoreBinding], -- These ones have to go here
987 [DictBindDetails], -- These can float further
988 [Id], -- Incoming list + names of dicts bound here
989 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
992 -- It is just to complex to try to float top-level
993 -- dict bindings with constant methods, inst methods,
994 -- auxillary derived instance defns and user instance
995 -- defns all getting in the way.
996 -- So we dump all dbinds as soon as we get to the top
997 -- level and place them in a *global* Rec.
998 -- We leave it to the simplifier will sort it all out ...
1000 dumpDBs [] top_lev bound_tyvars bound_ids fvs
1001 = ([], [], bound_ids, fvs)
1003 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
1004 top_lev bound_tyvars bound_ids fvs
1006 || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
1007 || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
1008 = let -- Ha! Dump it!
1009 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1010 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
1012 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1014 | otherwise -- This one can float out further
1016 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1017 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
1019 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
1023 dumpUDs :: UsageDetails
1024 -> Bool -- True <=> top level bound Ids
1025 -> Bool -- True <=> dict bindings to be floated (specBind only)
1026 -> [CallInstance] -- Call insts for bound Ids (instBind only)
1027 -> [Id] -- Ids which are just being bound; *new*
1028 -> [TyVar] -- TyVars which are just being bound
1029 -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
1030 UsageDetails) -- The above bindings removed, and
1031 -- any call-instances which mention the ids dumped too
1033 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
1035 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
1036 = dumpDBs dbs top_lev tvs bound_ids fvs
1037 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
1038 fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
1040 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
1044 addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
1045 -> UsageDetails -- The usage to augment
1047 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
1048 (UsageDetails cis tycon_cis dbs fvs c i)
1049 = UsageDetails (db_cis `unionBags` cis)
1050 (db_tycon_cis `unionBags` tycon_cis)
1051 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
1053 -- NB: We ignore counts from dictbinds since it is not user code
1055 -- The free tyvars of the dictionary bindings should really be
1056 -- gotten from the RHSs, but I'm pretty sure it's good enough just
1057 -- to look at the type of the dictionary itself.
1058 -- Doing the proper job would entail keeping track of free tyvars as
1059 -- well as free vars, which would be a bore.
1060 db_ftvs = tyVarsOfTypes (map idType dbinders)
1063 %************************************************************************
1065 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
1067 %************************************************************************
1069 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
1071 1) (NoLift LitArg l) : an Id which is bound to a literal
1073 2) (NoLift LitArg l) : an Id bound to a "new" Id
1074 The new Id is a possibly-type-specialised clone of the original
1076 3) Lifted lifted_id unlifted_id :
1078 This indicates that the original Id has been specialised to an
1079 unboxed value which must be lifted (see "Unboxed bindings" above)
1080 @unlifted_id@ is the unboxed clone of the original Id
1081 @lifted_id@ is a *lifted* version of the original Id
1083 When you lookup Ids which are Lifted, you have to insert a case
1084 expression to un-lift the value (done with @bindUnlift@)
1086 You also have to insert a case to lift the value in the binding
1087 (done with @liftExpr@)
1091 type SpecIdEnv = IdEnv CloneInfo
1094 = NoLift CoreArg -- refers to cloned id or literal
1096 | Lifted Id -- lifted, cloned id
1097 Id -- unlifted, cloned id
1101 %************************************************************************
1103 \subsection[specialise-data]{Data returned by specialiser}
1105 %************************************************************************
1112 -- True <=> Specialisation performed
1114 -- False <=> Specialisation completed with errors
1117 -- Local tycons declared in this module
1120 -- Those in-scope data types for which we want to
1121 -- generate code for their constructors.
1122 -- Namely: data types declared in this module +
1123 -- any big tuples used in this module
1124 -- The initial (and default) value is the local tycons
1126 (FiniteMap TyCon [(Bool, [Maybe Type])])
1127 -- TyCon specialisations to be generated
1128 -- We generate specialialised code (Bool=True) for data types
1129 -- defined in this module and any tuples used in this module
1130 -- The initial (and default) value is the specialisations
1131 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1132 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1134 (Bag (Id,[Maybe Type]))
1135 -- Imported specialisation errors
1136 (Bag (Id,[Maybe Type]))
1137 -- Imported specialisation warnings
1138 (Bag (TyCon,[Maybe Type]))
1139 -- Imported TyCon specialisation errors
1141 initSpecData local_tycons tycon_specs
1142 = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1147 ToDo[sansom]: Transformation data to process specialisation requests.
1149 %************************************************************************
1151 \subsection[specProgram]{Specialising a core program}
1153 %************************************************************************
1156 specProgram :: UniqSupply
1157 -> [CoreBinding] -- input ...
1159 -> ([CoreBinding], -- main result
1160 SpecialiseData) -- result specialise data
1162 specProgram uniqs binds
1163 (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1164 = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
1165 (final_binds, tycon_specs_list,
1166 UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1168 used_conids = filter isDataCon (uniqSetToList fvs)
1169 used_tycons = map dataConTyCon used_conids
1170 used_gen = filter isLocalGenTyCon used_tycons
1171 gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
1173 result_specs = addListToFM_C (++) init_specs tycon_specs_list
1175 uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
1176 cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1177 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1178 cis_warn = init_warn `unionBags` listToBag cis_other
1179 cis_errs = init_errs `unionBags` listToBag cis_unboxed
1181 uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
1182 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1183 tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
1185 no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
1186 && (not opt_SpecialiseImports || isEmptyBag cis_warn)
1188 (if opt_D_simplifier_stats then
1189 pprTrace "\nSpecialiser Stats:\n" (vcat [
1190 hcat [ptext SLIT("SpecCalls "), int spec_calls],
1191 hcat [ptext SLIT("SpecInsts "), int spec_insts],
1196 SpecData True no_errs local_tycons gen_tycons result_specs
1197 cis_errs cis_warn tycis_errs)
1199 specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
1200 = panic "Specialise:specProgram: specialiser called more than once"
1202 -- It may be possible safely to call the specialiser more than once,
1203 -- but I am not sure there is any benefit in doing so (Patrick)
1205 -- ToDo: What about unfoldings performed after specialisation ???
1208 %************************************************************************
1210 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1212 %************************************************************************
1214 In the specialiser we just collect up the specialisations which will
1215 be required. We don't create the specialised constructors in
1216 Core. These are only introduced when we convert to StgSyn.
1218 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1221 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1222 -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1224 specTyConsAndScope scopeM
1225 = scopeM `thenSM` \ (binds, scope_uds) ->
1227 (tycons_cis, gotci_scope_uds)
1228 = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds
1230 tycon_specs_list = collectTyConSpecs tycons_cis
1232 (if opt_SpecialiseTrace && not (null tycon_specs_list) then
1233 pprTrace "Specialising TyCons:\n"
1234 (vcat [ if not (null specs) then
1235 hang (hsep [(ppr tycon), ptext SLIT("at types")])
1236 4 (vcat (map pp_specs specs))
1238 | (tycon, specs) <- tycon_specs_list])
1240 returnSM (binds, tycon_specs_list, gotci_scope_uds)
1243 collectTyConSpecs []
1245 collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1246 = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1248 (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1249 uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1250 tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1252 pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys]
1256 %************************************************************************
1258 \subsection[specTopBinds]{Specialising top-level bindings}
1260 %************************************************************************
1263 specTopBinds :: [CoreBinding]
1264 -> SpecM ([CoreBinding], UsageDetails)
1267 = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1269 -- Add bindings for floated dbinds and collect fvs
1270 -- In actual fact many of these bindings are dead code since dict
1271 -- arguments are dropped when a specialised call is created
1272 -- The simplifier should be able to cope ...
1274 (dbinders_s, dbinds, dfvs_s)
1275 = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1277 full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
1278 fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
1280 -- It is just to complex to try to sort out top-level dependencies
1281 -- So we just place all the top-level binds in a *global* Rec and
1282 -- leave it to the simplifier to sort it all out ...
1285 returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1288 spec_top_binds (first_bind:rest_binds)
1289 = specBindAndScope True first_bind (
1290 spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1291 returnSM (ItsABinds rest_binds, rest_uds)
1292 ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1293 returnSM (first_binds ++ rest_binds, all_uds)
1296 = returnSM ([], emptyUDs)
1299 %************************************************************************
1301 \subsection[specExpr]{Specialising expressions}
1303 %************************************************************************
1306 specExpr :: CoreExpr
1307 -> [CoreArg] -- The arguments:
1308 -- TypeArgs are speced
1309 -- ValArgs are unprocessed
1310 -> SpecM (CoreExpr, -- Result expression with specialised versions installed
1311 UsageDetails)-- Details of usage of enclosing binders in the result
1314 specExpr (Var v) args
1315 = specId v $ \ v_arg ->
1317 LitArg lit -> ASSERT( null args )
1318 returnSM (Lit lit, emptyUDs)
1320 VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds ->
1321 returnSM (mkGenApp (Var new_v) args, uds)
1323 specExpr expr@(Lit _) null_args
1324 = ASSERT (null null_args)
1325 returnSM (expr, emptyUDs)
1327 specExpr (Con con args) null_args
1328 = ASSERT (null null_args)
1329 specArgs args $ \ args' ->
1330 mkTyConInstance con args' `thenSM` \ con_uds ->
1331 returnSM (Con con args', con_uds)
1333 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
1334 = ASSERT (null null_args)
1335 specArgs args $ \ args' ->
1336 mapSM specTy arg_tys `thenSM` \ arg_tys' ->
1337 specTy res_ty `thenSM` \ res_ty' ->
1338 returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs)
1340 specExpr (Prim prim args) null_args
1341 = ASSERT (null null_args)
1342 specArgs args $ \ args' ->
1343 -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
1344 returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
1348 specPrimOp :: PrimOp
1354 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1355 -- and/or chooses PrimOp specialised to any unboxed tys
1356 -- Errors are dealt with by returning a PrimOp call instance
1357 -- which will result in a cis_errs message
1359 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1363 specExpr (App fun arg) args
1364 = specArg arg `thenSM` \ new_arg ->
1365 specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
1366 returnSM (expr, uds)
1368 specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
1369 = lookup_arg arg `thenSM` \ arg ->
1370 bindId binder arg (specExpr body args)
1372 lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1373 lookup_arg (VarArg v) = lookupId v
1375 specExpr (Lam (ValBinder binder) body) []
1376 = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1377 returnSM (Lam (ValBinder binder) body, uds)
1379 specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
1380 = -- Type lambda with argument; argument already spec'd
1381 bindTyVar tyvar ty ( specExpr body args )
1383 specExpr (Lam (TyBinder tyvar) body) []
1385 cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
1386 bindTyVar tyvar (mkTyVarTy new_tyvar) (
1387 specExpr body [] `thenSM` \ (body, body_uds) ->
1389 (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1391 returnSM (Lam (TyBinder new_tyvar)
1392 (mkCoLetsNoUnboxed binds_here body),
1396 specExpr (Case scrutinee alts) args
1397 = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
1398 specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
1399 returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
1401 scrutinee_type = coreExprType scrutinee
1403 specExpr (Let bind body) args
1404 = specBindAndScope False bind (
1405 specExpr body args `thenSM` \ (body, body_uds) ->
1406 returnSM (ItsAnExpr body, body_uds)
1407 ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1408 returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1410 specExpr (SCC cc expr) args
1411 = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
1412 mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1415 = if squashableDictishCcExpr cc expr -- can toss the _scc_
1419 returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1420 unionUDList args_uds_s `unionUDs` expr_uds)
1422 specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
1424 -- ToDo: This may leave some unspec'd dictionaries!!
1427 %************************************************************************
1429 \subsubsection{Specialising a lambda}
1431 %************************************************************************
1434 specLambdaOrCaseBody :: [Id] -- The binders
1435 -> CoreExpr -- The body
1436 -> [CoreArg] -- Its args
1437 -> SpecM ([Id], -- New binders
1438 CoreExpr, -- New body
1441 specLambdaOrCaseBody bound_ids body args
1442 = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
1443 bindIds bound_ids clone_infos (
1445 specExpr body args `thenSM` \ (body, body_uds) ->
1448 -- Dump any dictionary bindings (and call instances)
1449 -- from the scope which mention things bound here
1450 (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1452 returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1455 -- ToDo: Opportunity here to common-up dictionaries with same type,
1456 -- thus avoiding recomputation.
1459 A variable bound in a lambda or case is normally monomorphic so no
1460 specialised versions will be required. This is just as well since we
1461 do not know what code to specialise!
1463 Unfortunately this is not always the case. For example a class Foo
1464 with polymorphic methods gives rise to a dictionary with polymorphic
1465 components as follows:
1472 instance Foo Int where
1480 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1481 d.Foo.Int = (op1_Int, op2_Int)
1483 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1485 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1488 N.B. The type of the dictionary is not Hindley Milner!
1490 Now we must specialise op1 at {* Int#} which requires a version of
1491 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1492 not have access to its code to create the specialised version.
1494 If we specialise on overloaded types as well we specialise op1 at
1495 {Int Int#} d.Foo.Int:
1497 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1499 Though this is still invalid, after further simplification we get:
1501 op1_Int_Int# = opInt1 {Int#}
1503 Another round of specialisation will result in the specialised
1504 version of op1Int being called directly.
1506 For now we PANIC if a polymorphic lambda/case bound variable is found
1507 in a call instance with an unboxed type. Other call instances, arising
1508 from overloaded type arguments, are discarded since the unspecialised
1509 version extracted from the method can be called as normal.
1511 ToDo: Implement and test second round of specialisation.
1514 %************************************************************************
1516 \subsubsection{Specialising case alternatives}
1518 %************************************************************************
1522 specAlts (AlgAlts alts deflt) scrutinee_ty args
1523 = mapSM specTy ty_args `thenSM` \ ty_args ->
1524 mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
1525 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1526 returnSM (AlgAlts alts deflt,
1527 unionUDList alts_uds_s `unionUDs` deflt_uds)
1529 -- We use ty_args of scrutinee type to identify specialisation of
1532 (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
1533 splitAlgTyConApp 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
1573 -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
1574 -> SpecM (CoreExpr, UsageDetails)
1576 = lookupId v `thenSM` \ vlookup ->
1580 -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) ->
1581 returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
1584 -> thing_inside vatom `thenSM` \ (expr, uds) ->
1585 returnSM (expr, singleFvUDs vatom `unionUDs` uds)
1588 -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
1589 -> SpecM (CoreExpr, UsageDetails))
1591 specArg (TyArg ty) thing_inside
1592 = specTy ty `thenSM` \ new_ty ->
1593 thing_inside (TyArg new_ty)
1595 specArg (LitArg lit)
1596 = thing_inside (LitArg lit)
1601 specArgs [] thing_inside
1604 specArgs (arg:args) thing_inside
1605 = specArg arg $ \ arg' ->
1606 specArgs args $ \ args' ->
1607 thing_inside (arg' : args')
1611 %************************************************************************
1613 \subsubsection{Specialising bindings}
1615 %************************************************************************
1617 A classic case of when having a polymorphic recursive function would help!
1620 data BindsOrExpr = ItsABinds [CoreBinding]
1621 | ItsAnExpr CoreExpr
1626 :: Bool -- True <=> a top level group
1627 -> CoreBinding -- As yet unprocessed
1628 -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
1629 -> SpecM ([CoreBinding], -- Processed
1630 BindsOrExpr, -- Combined result
1631 UsageDetails) -- Usage details of the whole lot
1633 specBindAndScope top_lev bind scopeM
1634 = cloneLetBinders top_lev (is_rec bind) binders
1635 `thenSM` \ (new_binders, clone_infos) ->
1637 -- Two cases now: either this is a bunch of local dictionaries,
1638 -- in which case we float them; or its a bunch of other values,
1639 -- in which case we see if they correspond to any call-instances
1640 -- we have from processing the scope
1642 if not top_lev && all (isDictTy . idType) binders
1644 -- Ha! A group of local dictionary bindings
1646 bindIds binders clone_infos (
1648 -- Process the dictionary bindings themselves
1649 specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
1651 -- Process their scope
1652 scopeM `thenSM` \ (thing, scope_uds) ->
1654 -- Add the bindings to the current stuff
1655 final_uds = addDictBinds new_binders bind rhs_uds scope_uds
1657 returnSM ([], thing, final_uds)
1660 -- Ho! A group of bindings
1662 fixSM (\ ~(_, _, _, rec_spec_infos) ->
1664 bindSpecIds binders clone_infos rec_spec_infos (
1665 -- It's ok to have new binders in scope in
1666 -- non-recursive decls too, cos name shadowing is gone by now
1668 -- Do the scope of the bindings
1669 scopeM `thenSM` \ (thing, scope_uds) ->
1671 (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
1673 equiv_ciss = equivClasses cmpCI_tys call_insts
1674 inst_cis = map head equiv_ciss
1677 -- Do the bindings themselves
1678 specBind top_lev False new_binders inst_cis bind
1679 `thenSM` \ (spec_bind, spec_uds) ->
1681 -- Create any necessary instances
1682 instBind top_lev new_binders bind equiv_ciss inst_cis
1683 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
1686 -- NB: dumpUDs only worries about new_binders since the free var
1687 -- stuff only records free new_binders
1688 -- The spec_ids only appear in SpecInfos and final speced calls
1690 -- Build final binding group and usage details
1691 (final_binds, final_uds)
1693 -- For a top-level binding we have to dumpUDs from
1694 -- spec_uds and inst_uds and scope_uds creating
1695 -- *global* dict bindings
1697 (scope_dict_binds, final_scope_uds)
1698 = dumpUDs gotci_scope_uds True False [] new_binders []
1699 (spec_dict_binds, final_spec_uds)
1700 = dumpUDs spec_uds True False inst_cis new_binders []
1701 (inst_dict_binds, final_inst_uds)
1702 = dumpUDs inst_uds True False inst_cis new_binders []
1704 ([spec_bind] ++ inst_binds ++ scope_dict_binds
1705 ++ spec_dict_binds ++ inst_dict_binds,
1706 final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
1708 -- For a local binding we only have to dumpUDs from
1709 -- scope_uds since the UDs from spec_uds and inst_uds
1710 -- have already been dumped by specBind and instBind
1712 (scope_dict_binds, final_scope_uds)
1713 = dumpUDs gotci_scope_uds False False [] new_binders []
1715 ([spec_bind] ++ inst_binds ++ scope_dict_binds,
1716 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
1718 -- inst_uds comes last, because there may be dict bindings
1719 -- floating outward in scope_uds which are mentioned
1720 -- in the call-instances, and hence in spec_uds.
1721 -- This ordering makes sure that the precedence order
1722 -- among the dict bindings finally floated out is maintained.
1724 returnSM (final_binds, thing, final_uds, spec_infos)
1726 ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
1727 returnSM (binds, thing, final_uds)
1729 binders = bindersOf bind
1731 is_rec (NonRec _ _) = False
1736 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
1738 -> SpecM (CoreBinding, UsageDetails)
1739 -- The UsageDetails returned has already had stuff to do with this group
1740 -- of binders deleted; that's why new_binders is passed in.
1741 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
1742 = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
1743 `thenSM` \ ((binder,rhs), rhs_uds) ->
1744 returnSM (NonRec binder rhs, rhs_uds)
1746 specBind top_lev floating new_binders inst_cis (Rec pairs)
1747 = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
1748 `thenSM` \ (pairs, rhs_uds_s) ->
1749 returnSM (Rec pairs, unionUDList rhs_uds_s)
1752 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
1754 -> SpecM ((Id,CoreExpr), UsageDetails)
1756 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
1757 = lookupId binder `thenSM` \ blookup ->
1758 specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
1760 specid_maybe_maybe = isSpecPragmaId_maybe binder
1761 is_specid = maybeToBool specid_maybe_maybe
1762 Just specinfo_maybe = specid_maybe_maybe
1763 specid_with_info = maybeToBool specinfo_maybe
1764 Just spec_info = specinfo_maybe
1766 -- If we have a SpecInfo stored in a SpecPragmaId binder
1767 -- it will contain a SpecInfo with an explicit SpecId
1768 -- We add the explicit ci to the usage details
1769 -- Any ordinary cis for orig_id (there should only be one)
1770 -- will be ignored later
1773 = if is_specid && specid_with_info then
1775 (SpecInfo spec_tys _ spec_id) = spec_info
1776 Just (orig_id, _) = isSpecId_maybe spec_id
1778 ASSERT(toplevelishId orig_id) -- must not be cloned!
1779 explicitCI orig_id spec_tys spec_info
1783 -- For a local binding we dump the usage details, creating
1784 -- any local dict bindings required
1785 -- At the top-level the uds will be dumped in specBindAndScope
1786 -- and the dict bindings made *global*
1788 (local_dict_binds, final_uds)
1789 = if not top_lev then
1790 dumpUDs rhs_uds False floating inst_cis new_binders []
1795 Lifted lift_binder unlift_binder
1796 -> -- We may need to record an unboxed instance of
1797 -- the _Lift data type in the usage details
1798 mkTyConInstance liftDataCon [idType unlift_binder]
1799 `thenSM` \ lift_uds ->
1800 returnSM ((lift_binder,
1801 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
1802 final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
1804 NoLift (VarArg binder)
1805 -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
1806 final_uds `unionUDs` pragma_uds)
1810 %************************************************************************
1812 \subsection{@instBind@}
1814 %************************************************************************
1817 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
1819 = returnSM ([], emptyUDs, [])
1821 | all same_overloading other_binders
1822 = -- For each call_inst, build an instance
1823 mapAndUnzip3SM do_this_class equiv_ciss
1824 `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
1826 -- Add in the remaining UDs
1827 returnSM (catMaybes inst_binds,
1828 unionUDList inst_uds_s,
1832 | otherwise -- Incompatible overloadings; see below by same_overloading
1833 = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
1834 then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
1836 then pprTrace "dumpCIs: not same overloading ... top level \n"
1838 ) (hang (hcat [ptext SLIT("{"),
1841 4 (vcat [vcat (map (pprGenType . idType) new_ids),
1842 vcat (map pprCI (concat equiv_ciss))]))
1843 (returnSM ([], emptyUDs, []))
1846 (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
1847 tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
1849 no_of_tyvars = length tyvar_tmpls
1850 no_of_dicts = length class_tyvar_pairs
1852 do_this_class equiv_cis
1853 = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
1855 (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
1856 do_cis = head (normal_cis ++ explicit_cis)
1857 -- must choose a normal_cis in preference since dict_args will
1858 -- not be defined for an explicit_cis
1860 -- same_overloading tests whether the types of all the binders
1861 -- are "compatible"; ie have the same type and dictionary abstractions
1862 -- Almost always this is the case, because a recursive group is abstracted
1863 -- all together. But, it can happen that it ain't the case, because of
1864 -- code generated from instance decls:
1867 -- dfun.Foo.Int :: (forall a. a -> Int, Int)
1868 -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
1870 -- const.op1.Int :: forall a. a -> Int
1871 -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
1873 -- const.op2.Int :: Int
1874 -- const.op2.Int = 3
1876 -- Note that the first two defns have different polymorphism, but they are
1877 -- mutually recursive!
1879 same_overloading :: Id -> Bool
1881 = no_of_tyvars == length this_id_tyvars
1882 -- Same no of tyvars
1883 && no_of_dicts == length this_id_class_tyvar_pairs
1884 -- Same no of vdicts
1885 && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
1886 && length class_tyvar_pairs == length this_id_class_tyvar_pairs
1889 (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
1890 tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
1892 same_ov (clas1,tyvar1) (clas2,tyvar2)
1894 tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
1898 - a call instance eg f [t1,t2,t3] [d1,d2]
1899 - the rhs of the function eg orig_rhs
1900 - a constraint vector, saying which of eg [T,F,T]
1901 the functions type args are constrained
1904 We return a new definition
1906 $f1 = /\a -> orig_rhs t1 a t3 d1 d2
1908 The SpecInfo for f will be:
1910 SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
1912 Based on this SpecInfo, a call instance of f
1916 should get replaced by
1918 ...(\d1 d2 -> $f1 t2)...
1920 (But that is the business of the simplifier.)
1923 mkOneInst :: CallInstance
1924 -> [CallInstance] -- Any explicit cis for this inst
1925 -> Int -- No of dicts to specialise
1926 -> Bool -- Top level binders?
1927 -> [CallInstance] -- Instantiated call insts for binders
1928 -> [Id] -- New binders
1929 -> CoreBinding -- Unprocessed
1930 -> SpecM (Maybe CoreBinding, -- Instantiated version of input
1932 [Maybe SpecInfo] -- One for each id in the original binding
1935 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
1936 no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
1937 = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
1938 `thenSM` \ spec_ids ->
1939 newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
1941 -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
1942 -- which correspond to unspecialised args
1944 (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
1947 args = map TyArg arg_tys ++ dict_args
1949 (new_id:_) = new_ids
1950 (spec_id:_) = spec_ids
1952 do_bind (NonRec orig_id rhs)
1953 = do_one_rhs (spec_id, new_id, (orig_id,rhs))
1954 `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
1956 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
1957 Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
1960 = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
1961 `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
1962 returnSM (Just (Rec (catMaybes maybe_pairs)),
1963 unionUDList rhss_uds_s, spec_infos)
1965 do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
1967 -- Avoid duplicating a spec which has already been created ...
1968 -- This can arise in a Rec involving a dfun for which a
1969 -- a specialised instance has been created but specialisation
1970 -- "required" by one of the other Ids in the Rec
1971 | top_lev && maybeToBool lookup_orig_spec
1972 = (if opt_SpecialiseTrace
1973 then trace_nospec " Exists: " orig_id
1976 returnSM (Nothing, emptyUDs, Nothing)
1979 -- Check for a (single) explicit call instance for this id
1980 | not (null explicit_cis_for_this_id)
1981 = ASSERT (length explicit_cis_for_this_id == 1)
1982 (if opt_SpecialiseTrace
1983 then trace_nospec " Explicit: " explicit_id
1986 returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
1989 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
1991 = ASSERT (no_of_dicts_to_specialise == length dict_args)
1992 specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
1994 -- For a local binding we dump the usage details, creating
1995 -- any local dict bindings required
1996 -- At the top-level the uds will be dumped in specBindAndScope
1997 -- and the dict bindings made *global*
1999 (local_dict_binds, final_uds)
2000 = if not top_lev then
2001 dumpUDs inst_uds False False inst_cis new_ids []
2005 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
2007 if isUnboxedType (idType spec_id) then
2008 ASSERT (null poly_tyvars)
2009 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2010 mkTyConInstance liftDataCon [idType unlift_spec_id]
2011 `thenSM` \ lift_uds ->
2012 returnSM (Just (lift_spec_id,
2013 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
2014 tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
2016 returnSM (Just (spec_id,
2017 mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
2018 tickSpecInsts final_uds, spec_info)
2020 lookup_orig_spec = matchSpecEnv (getIdSpecialisation orig_id) arg_tys
2022 explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
2023 [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
2024 SpecInfo _ _ explicit_id = explicit_spec_info
2026 trace_nospec :: String -> Id -> a -> a
2027 trace_nospec str spec_id
2029 (hsep [ppr new_id, hsep (map pp_ty arg_tys),
2030 ptext SLIT("==>"), ppr spec_id])
2032 (if opt_SpecialiseTrace then
2033 pprTrace "Specialising:"
2034 (hang (hcat [char '{',
2038 hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)],
2039 if isExplicitCI do_cis then empty else
2040 hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)],
2041 hcat [ptext SLIT("specs: "), ppr spec_ids]]))
2044 do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
2046 returnSM (maybe_inst_bind, inst_uds, spec_infos)
2049 pp_dict d = ppr_arg d
2050 pp_ty t = pprParendGenType t
2052 do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
2053 do_the_wotsit tyvars (Just ty) = (tyvars, ty)
2057 %************************************************************************
2059 \subsection[Misc]{Miscellaneous junk}
2061 %************************************************************************
2064 mkCallInstance :: Id
2067 -> SpecM UsageDetails
2069 mkCallInstance id new_id args
2070 | null args || -- No args at all
2071 idWantsToBeINLINEd id || -- It's going to be inlined anyway
2072 not enough_args || -- Not enough type and dict args
2073 not interesting_overloading -- Overloaded types are just tyvars
2077 = returnSM (singleCI new_id spec_tys dicts)
2080 (tyvars, theta, _) = splitSigmaTy (idType id)
2081 constrained_tyvars = tyvarsOfTypes (map snd class_tyvar_pairs)
2083 arg_res = take_type_args tyvars class_tyvar_pairs args
2084 enough_args = maybeToBool arg_res
2085 (Just (tys, dicts, rest_args)) = arg_res
2087 interesting_overloading = not (null (catMaybes spec_tys))
2088 spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys
2090 ---------------------------------------------------------------
2091 -- Should we specialise on this type argument?
2092 spec_ty tyvar ty | isTyVarTy ty = Nothing
2094 spec_ty tyvar ty | opt_SpecialiseAll
2095 || (opt_SpecialiseUnboxed
2097 && isBoxedTypeKind (tyVarKind tyvar))
2098 || (opt_SpecialiseOverloaded
2099 && tyvar `elemTyVarSet` constrained_tyvars)
2102 | otherwise = Nothing
2104 ----------------- Rather a gruesome help-function ---------------
2105 take_type_args (_:tyvars) (TyArg ty : args)
2106 = case (take_type_args tyvars args) of
2108 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2110 take_type_args (_:tyvars) [] = Nothing
2112 take_type_args [] args
2113 = case (take_dict_args class_tyvar_pairs args) of
2115 Just (dicts, others) -> Just ([], dicts, others)
2117 take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
2118 = case (take_dict_args class_tyvar_pairs args) of
2120 Just (dicts, others) -> Just (dict:dicts, others)
2122 take_dict_args (_:class_tyvar_pairs) args = Nothing
2124 take_dict_args [] args = Just ([], args)
2129 mkTyConInstance :: Id
2131 -> SpecM UsageDetails
2132 mkTyConInstance con tys
2133 = recordTyConInst con tys `thenSM` \ record_inst ->
2135 Nothing -- No TyCon instance
2136 -> -- pprTrace "NoTyConInst:"
2137 -- (hsep [ppr tycon, ptext SLIT("at"),
2138 -- ppr con, hsep (map (ppr) tys)])
2139 (returnSM (singleConUDs con))
2141 Just spec_tys -- Record TyCon instance
2142 -> -- pprTrace "TyConInst:"
2143 -- (hsep [ppr tycon, ptext SLIT("at"),
2144 -- ppr con, hsep (map (ppr) tys),
2146 -- hsep [pprMaybeTy ty | ty <- spec_tys],
2148 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2150 tycon = dataConTyCon con
2154 recordTyConInst :: Id
2156 -> SpecM (Maybe [Maybe Type])
2158 recordTyConInst con tys
2160 spec_tys = specialiseConstrTys tys
2162 do_tycon_spec = maybeToBool (firstJust spec_tys)
2164 spec_exists = maybeToBool (lookupSpecEnv
2165 (getIdSpecialisation con)
2168 -- pprTrace "ConSpecExists?: "
2169 -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")),
2170 -- ppr PprShowAll con, hsep (map ppr tys)])
2171 (if (not spec_exists && do_tycon_spec)
2172 then returnSM (Just spec_tys)
2173 else returnSM Nothing)
2176 %************************************************************************
2178 \subsection[monad-Specialise]{Monad used in specialisation}
2180 %************************************************************************
2184 inherited: control flags and
2185 recordInst functions with flags cached
2187 environment mapping tyvars to types
2188 environment mapping Ids to Atoms
2190 threaded in and out: unique supply
2193 type TypeEnv = TyVarEnv Type
2201 initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs
2203 returnSM :: a -> SpecM a
2204 thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
2205 fixSM :: (a -> SpecM a) -> SpecM a
2207 thenSM m k tvenv idenv us
2208 = case splitUniqSupply us of { (s1, s2) ->
2209 case (m tvenv idenv s1) of { r ->
2210 k r tvenv idenv s2 }}
2212 returnSM r tvenv idenv us = r
2214 fixSM k tvenv idenv us
2217 r = k r tvenv idenv us -- Recursive in r!
2220 The only interesting bit is figuring out the type of the SpecId!
2223 newSpecIds :: [Id] -- The id of which to make a specialised version
2224 -> [Maybe Type] -- Specialise to these types
2225 -> Int -- No of dicts to specialise
2228 newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
2229 = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2230 | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
2232 uniqs = getUniques (length new_ids) us
2233 spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2235 newTyVars :: Int -> SpecM [TyVar]
2236 newTyVars n tvenv idenv us
2237 = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
2240 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2241 binders, and build ``clones'' for them. The clones differ from the
2242 originals in three ways:
2244 (a) they have a fresh unique
2245 (b) they have the current type environment applied to their type
2246 (c) for Let binders which have been specialised to unboxed values
2247 the clone will have a lifted type
2249 As well as returning the list of cloned @Id@s they also return a list of
2250 @CloneInfo@s which the original binders should be bound to.
2253 cloneLambdaOrCaseBinders :: [Id] -- Old binders
2254 -> SpecM ([Id], [CloneInfo]) -- New ones
2256 cloneLambdaOrCaseBinders old_ids tvenv idenv us
2258 uniqs = getUniques (length old_ids) us
2260 unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
2262 clone_it old_id uniq
2263 = (new_id, NoLift (VarArg new_id))
2265 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2267 cloneLetBinders :: Bool -- Top level ?
2268 -> Bool -- Recursice
2269 -> [Id] -- Old binders
2270 -> SpecM ([Id], [CloneInfo]) -- New ones
2272 cloneLetBinders top_lev is_rec old_ids tvenv idenv us
2274 uniqs = getUniques (2 * length old_ids) us
2276 unzip (clone_them old_ids uniqs)
2278 clone_them [] [] = []
2280 clone_them (old_id:olds) (u1:u2:uniqs)
2283 NoLift (VarArg old_id)) : clone_rest
2285 -- Don't clone if it is a top-level thing. Why not?
2286 -- (a) we don't want to change the uniques
2288 -- (b) we don't have to be paranoid about name capture
2289 -- (c) the thing is polymorphic so no need to subst
2292 = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
2294 Lifted lifted_id unlifted_id) : clone_rest
2296 NoLift (VarArg new_id)) : clone_rest
2299 clone_rest = clone_them olds uniqs
2301 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2302 new_ty = idType new_id
2303 old_ty = idType old_id
2305 (lifted_id, unlifted_id) = mkLiftedId new_id u2
2308 cloneTyVarSM :: TyVar -> SpecM TyVar
2310 cloneTyVarSM old_tyvar tvenv idenv us
2314 cloneTyVar old_tyvar uniq -- new_tyvar
2316 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2318 bindId id val specm tvenv idenv us
2319 = specm tvenv (addOneToIdEnv idenv id val) us
2321 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2323 bindIds olds news specm tvenv idenv us
2324 = specm tvenv (growIdEnvList idenv (zip olds news)) us
2326 bindSpecIds :: [Id] -- Old
2327 -> [(CloneInfo)] -- New
2328 -> [[Maybe SpecInfo]] -- Corresponding specialisations
2329 -- Each sub-list corresponds to a different type,
2330 -- and contains one Maybe spec_info for each id
2334 bindSpecIds olds clones spec_infos specm tvenv idenv us
2335 = specm tvenv (growIdEnvList idenv old_to_clone) us
2337 old_to_clone = mk_old_to_clone olds clones spec_infos
2339 -- The important thing here is that we are *lazy* in spec_infos
2340 mk_old_to_clone [] [] _ = []
2341 mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2342 = (old, add_spec_info clone) :
2343 mk_old_to_clone rest_olds rest_clones spec_infos_rest
2345 add_spec_info (NoLift (VarArg new))
2346 = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)))
2347 add_spec_info lifted
2348 = lifted -- no specialised instances for unboxed lifted values
2350 spec_infos_this_id = catMaybes (map head spec_infos)
2351 spec_infos_rest = map tail spec_infos
2354 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2356 bindTyVar tyvar ty specm tvenv idenv us
2357 = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2361 lookupId :: Id -> SpecM CloneInfo
2363 lookupId id tvenv idenv us
2364 = case lookupIdEnv idenv id of
2365 Nothing -> NoLift (VarArg id)
2370 specTy :: Type -> SpecM Type -- Apply the current type envt to the type
2372 specTy ty tvenv idenv us
2373 = instantiateTy tvenv ty
2377 liftId :: Id -> SpecM (Id, Id)
2378 liftId id tvenv idenv us
2385 In other monads these @mapSM@ things are usually called @listM@.
2386 I think @mapSM@ is a much better name. The `2' and `3' variants are
2387 when you want to return two or three results, and get at them
2388 separately. It saves you having to do an (unzip stuff) right after.
2391 mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
2392 mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
2393 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2394 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2396 mapSM f [] = returnSM []
2397 mapSM f (x:xs) = f x `thenSM` \ r ->
2398 mapSM f xs `thenSM` \ rs ->
2401 mapAndUnzipSM f [] = returnSM ([],[])
2402 mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
2403 mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
2404 returnSM ((r1:rs1),(r2:rs2))
2406 mapAndUnzip3SM f [] = returnSM ([],[],[])
2407 mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
2408 mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
2409 returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2411 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2412 mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
2413 mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
2414 returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
2420 ===================== OLD CODE, scheduled for deletion =================
2425 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2428 mkCall new_id arg_infos = returnSM (
2430 | maybeToBool (isSuperDictSelId_maybe new_id)
2431 && any isUnboxedType ty_args
2432 -- No specialisations for super-dict selectors
2433 -- Specialise unboxed calls to SuperDictSelIds by extracting
2434 -- the super class dictionary directly form the super class
2435 -- NB: This should be dead code since all uses of this dictionary should
2436 -- have been specialised. We only do this to keep core-lint happy.
2438 Just (_, super_class) = isSuperDictSelId_maybe new_id
2439 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2440 Nothing -> panic "Specialise:mkCall:SuperDictId"
2443 returnSM (False, Var super_dict_id)
2446 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2447 Nothing -> checkUnspecOK new_id ty_args (
2448 returnSM (False, unspec_call)
2451 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2453 -- It may be necessary to specialsie a constant method spec_id again
2454 (spec_id, tys_left, dicts_to_toss) =
2455 case (maybeToBool (isConstMethodId_maybe spec_id_1),
2456 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2457 (False, _ ) -> spec_1_details
2458 (True, Nothing) -> spec_1_details
2459 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2460 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2462 args_left = toss_dicts dicts_to_toss val_args
2464 checkSpecOK new_id ty_args spec_id tys_left (
2466 -- The resulting spec_id may be a top-level unboxed value
2467 -- This can arise for:
2468 -- 1) constant method values
2469 -- eq: class Num a where pi :: a
2470 -- instance Num Double# where pi = 3.141#
2471 -- 2) specilised overloaded values
2472 -- eq: i1 :: Num a => a
2473 -- i1 Int# d.Num.Int# ==> i1.Int#
2474 -- These top level defns should have been lifted.
2475 -- We must add code to unlift such a spec_id.
2477 if isUnboxedType (idType spec_id) then
2478 ASSERT (null tys_left && null args_left)
2479 if toplevelishId spec_id then
2480 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2481 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2482 (Var unlift_spec_id))
2484 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2486 hsep (map (pprParendGenType) ty_args),
2491 (vals_left, _, unlifts_left) = unzip3 args_left
2492 applied_tys = mkTyApp (Var spec_id) tys_left
2493 applied_vals = mkGenApp applied_tys vals_left
2495 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2498 (tys_and_vals, _, unlifts) = unzip3 args
2499 unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2502 -- ty_args is the types at the front of the arg list
2503 -- val_args is the rest of the arg-list
2505 (ty_args, val_args) = get args
2507 get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2508 get args = ([], args)
2511 -- toss_dicts chucks away dict args, checking that they ain't types!
2512 toss_dicts 0 args = args
2513 toss_dicts n ((a,_,_) : args)
2514 | isValArg a = toss_dicts (n-1) args
2519 checkUnspecOK :: Id -> [Type] -> a -> a
2520 checkUnspecOK check_id tys
2521 = if isLocallyDefined check_id && any isUnboxedType tys
2522 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2523 (hsep [ppr check_id,
2524 hsep (map (pprParendGenType) tys)])
2527 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2528 checkSpecOK check_id tys spec_id tys_left
2529 = if any isUnboxedType tys_left
2530 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2531 (vcat [hsep [ppr check_id,
2532 hsep (map (pprParendGenType) tys)],
2534 hsep (map (pprParendGenType) tys_left)]])