2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
7 #include "HsVersions.h"
17 IMPORT_1_3(List(partition))
19 import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
20 partitionBag, listToBag, bagToList
22 import Class ( GenClass{-instance Eq-} )
23 import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
24 opt_CompilingGhcInternals, opt_SpecialiseTrace
26 import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
28 import CoreUtils ( coreExprType, squashableDictishCcExpr )
29 import FiniteMap ( addListToFM_C, FiniteMap )
30 import Kind ( mkBoxedTypeKind )
31 import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
32 isSuperDictSelId_maybe, isBottomingId,
33 isConstMethodId_maybe, isDataCon,
34 isImportedId, mkIdWithNewUniq,
35 dataConTyCon, applyTypeEnvToId,
36 nullIdEnv, addOneToIdEnv, growIdEnvList,
37 lookupIdEnv, SYN_IE(IdEnv),
38 emptyIdSet, mkIdSet, unitIdSet,
39 elementOfIdSet, minusIdSet,
40 unionIdSets, unionManyIdSets, SYN_IE(IdSet),
43 import Literal ( Literal{-instance Outputable-} )
44 import Maybes ( catMaybes, firstJust, maybeToBool )
45 import Name ( isLocallyDefined )
46 import Outputable ( interppSP, Outputable(..){-instance * []-} )
47 import PprStyle ( PprStyle(..) )
48 import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
49 GenType{-instance Outputable-}, GenTyVar{-ditto-},
52 import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, ppPStr, ppChar,
53 ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty)
55 import PrimOp ( PrimOp(..) )
57 import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
58 tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType, isDictTy
60 import TyCon ( TyCon{-instance Eq-} )
61 import TyVar ( cloneTyVar, mkSysTyVar,
62 elementOfTyVarSet, SYN_IE(TyVarSet),
63 nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv),
64 GenTyVar{-instance Eq-}
66 import TysWiredIn ( liftDataCon )
67 import Unique ( Unique{-instance Eq-} )
68 import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
69 import UniqSupply ( splitUniqSupply, getUniques, getUnique )
70 import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
71 thenCmp, panic, pprTrace, pprPanic, assertPanic
76 specProgram = panic "SpecProgram"
79 data SpecInfo = SpecInfo [Maybe Type] Int Id
83 lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
84 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
85 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
86 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
87 isClassOpId = panic "Specialise.isClassOpId (ToDo)"
88 isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
89 isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
90 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
91 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
92 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
93 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
94 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
95 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
96 specialiseTy = panic "Specialise.specialiseTy (ToDo)"
99 %************************************************************************
101 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
103 %************************************************************************
105 These notes describe how we implement specialisation to eliminate
106 overloading, and optionally to eliminate unboxed polymorphism, and
109 The specialisation pass is a partial evaluator which works on Core
110 syntax, complete with all the explicit dictionary application,
111 abstraction and construction as added by the type checker. The
112 existing type checker remains largely as it is.
114 One important thought: the {\em types} passed to an overloaded
115 function, and the {\em dictionaries} passed are mutually redundant.
116 If the same function is applied to the same type(s) then it is sure to
117 be applied to the same dictionary(s)---or rather to the same {\em
118 values}. (The arguments might look different but they will evaluate
121 Second important thought: we know that we can make progress by
122 treating dictionary arguments as static and worth specialising on. So
123 we can do without binding-time analysis, and instead specialise on
124 dictionary arguments and no others.
133 and suppose f is overloaded.
135 STEP 1: CALL-INSTANCE COLLECTION
137 We traverse <body>, accumulating all applications of f to types and
140 (Might there be partial applications, to just some of its types and
141 dictionaries? In principle yes, but in practice the type checker only
142 builds applications of f to all its types and dictionaries, so partial
143 applications could only arise as a result of transformation, and even
144 then I think it's unlikely. In any case, we simply don't accumulate such
145 partial applications.)
147 There's a choice of whether to collect details of all *polymorphic* functions
148 or simply all *overloaded* ones. How to sort this out?
149 Pass in a predicate on the function to say if it is "interesting"?
150 This is dependent on the user flags: SpecialiseOverloaded
156 So now we have a collection of calls to f:
160 Notice that f may take several type arguments. To avoid ambiguity, we
161 say that f is called at type t1/t2 and t3/t4.
163 We take equivalence classes using equality of the *types* (ignoring
164 the dictionary args, which as mentioned previously are redundant).
166 STEP 3: SPECIALISATION
168 For each equivalence class, choose a representative (f t1 t2 d1 d2),
169 and create a local instance of f, defined thus:
171 f@t1/t2 = <f_rhs> t1 t2 d1 d2
173 (f_rhs presumably has some big lambdas and dictionary lambdas, so lots
174 of simplification will now result.) Then we should recursively do
177 The new id has its own unique, but its print-name (if exported) has
178 an explicit representation of the instance types t1/t2.
180 Add this new id to f's IdInfo, to record that f has a specialised version.
182 Before doing any of this, check that f's IdInfo doesn't already
183 tell us about an existing instance of f at the required type/s.
184 (This might happen if specialisation was applied more than once, or
185 it might arise from user SPECIALIZE pragmas.)
189 Wait a minute! What if f is recursive? Then we can't just plug in
190 its right-hand side, can we?
192 But it's ok. The type checker *always* creates non-recursive definitions
193 for overloaded recursive functions. For example:
195 f x = f (x+x) -- Yes I know its silly
199 f a (d::Num a) = let p = +.sel a d
201 letrec fl (y::a) = fl (p y y)
205 We still have recusion for non-overloadd functions which we
206 speciailise, but the recursive call should get speciailised to the
207 same recursive version.
213 All this is crystal clear when the function is applied to *constant
214 types*; that is, types which have no type variables inside. But what if
215 it is applied to non-constant types? Suppose we find a call of f at type
216 t1/t2. There are two possibilities:
218 (a) The free type variables of t1, t2 are in scope at the definition point
219 of f. In this case there's no problem, we proceed just as before. A common
220 example is as follows. Here's the Haskell:
225 After typechecking we have
227 g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
228 in +.sel a d (f a d y) (f a d y)
230 Notice that the call to f is at type type "a"; a non-constant type.
231 Both calls to f are at the same type, so we can specialise to give:
233 g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
234 in +.sel a d (f@a y) (f@a y)
237 (b) The other case is when the type variables in the instance types
238 are *not* in scope at the definition point of f. The example we are
239 working with above is a good case. There are two instances of (+.sel a d),
240 but "a" is not in scope at the definition of +.sel. Can we do anything?
241 Yes, we can "common them up", a sort of limited common sub-expression deal.
244 g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
245 f@a (x::a) = +.sel@a x x
246 in +.sel@a (f@a y) (f@a y)
248 This can save work, and can't be spotted by the type checker, because
249 the two instances of +.sel weren't originally at the same type.
253 * There are quite a few variations here. For example, the defn of
254 +.sel could be floated ouside the \y, to attempt to gain laziness.
255 It certainly mustn't be floated outside the \d because the d has to
258 * We don't want to inline f_rhs in this case, because
259 that will duplicate code. Just commoning up the call is the point.
261 * Nothing gets added to +.sel's IdInfo.
263 * Don't bother unless the equivalence class has more than one item!
265 Not clear whether this is all worth it. It is of course OK to
266 simply discard call-instances when passing a big lambda.
268 Polymorphism 2 -- Overloading
270 Consider a function whose most general type is
272 f :: forall a b. Ord a => [a] -> b -> b
274 There is really no point in making a version of g at Int/Int and another
275 at Int/Bool, because it's only instancing the type variable "a" which
276 buys us any efficiency. Since g is completely polymorphic in b there
277 ain't much point in making separate versions of g for the different
280 That suggests that we should identify which of g's type variables
281 are constrained (like "a") and which are unconstrained (like "b").
282 Then when taking equivalence classes in STEP 2, we ignore the type args
283 corresponding to unconstrained type variable. In STEP 3 we make
284 polymorphic versions. Thus:
286 f@t1/ = /\b -> <f_rhs> t1 b d1 d2
288 This seems pretty simple, and a Good Thing.
290 Polymorphism 3 -- Unboxed
293 If we are speciailising at unboxed types we must speciailise
294 regardless of the overloading constraint. In the exaple above it is
295 worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
298 Note that specialising an overloaded type at an uboxed type requires
299 an unboxed instance -- we cannot default to an unspecialised version!
306 f x = let g p q = p==q
312 Before specialisation, leaving out type abstractions we have
314 f df x = let g :: Eq a => a -> a -> Bool
316 h :: Num a => a -> a -> (a, Bool)
317 h dh r s = let deq = eqFromNum dh
318 in (+ dh r s, g deq r s)
322 After specialising h we get a specialised version of h, like this:
324 h' r s = let deq = eqFromNum df
325 in (+ df r s, g deq r s)
327 But we can't naively make an instance for g from this, because deq is not in scope
328 at the defn of g. Instead, we have to float out the (new) defn of deq
329 to widen its scope. Notice that this floating can't be done in advance -- it only
330 shows up when specialisation is done.
332 DELICATE MATTER: the way we tell a dictionary binding is by looking to
333 see if it has a Dict type. If the type has been "undictify'd", so that
334 it looks like a tuple, then the dictionary binding won't be floated, and
335 an opportunity to specialise might be lost.
337 User SPECIALIZE pragmas
338 ~~~~~~~~~~~~~~~~~~~~~~~
339 Specialisation pragmas can be digested by the type checker, and implemented
340 by adding extra definitions along with that of f, in the same way as before
342 f@t1/t2 = <f_rhs> t1 t2 d1 d2
344 Indeed the pragmas *have* to be dealt with by the type checker, because
345 only it knows how to build the dictionaries d1 and d2! For example
347 g :: Ord a => [a] -> [a]
348 {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
350 Here, the specialised version of g is an application of g's rhs to the
351 Ord dictionary for (Tree Int), which only the type checker can conjure
352 up. There might not even *be* one, if (Tree Int) is not an instance of
353 Ord! (All the other specialision has suitable dictionaries to hand
356 Problem. The type checker doesn't have to hand a convenient <f_rhs>, because
357 it is buried in a complex (as-yet-un-desugared) binding group.
360 f@t1/t2 = f* t1 t2 d1 d2
362 where f* is the Id f with an IdInfo which says "inline me regardless!".
363 Indeed all the specialisation could be done in this way.
364 That in turn means that the simplifier has to be prepared to inline absolutely
365 any in-scope let-bound thing.
368 Again, the pragma should permit polymorphism in unconstrained variables:
370 h :: Ord a => [a] -> b -> b
371 {-# SPECIALIZE h :: [Int] -> b -> b #-}
373 We *insist* that all overloaded type variables are specialised to ground types,
374 (and hence there can be no context inside a SPECIALIZE pragma).
375 We *permit* unconstrained type variables to be specialised to
377 - or left as a polymorphic type variable
378 but nothing in between. So
380 {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
382 is *illegal*. (It can be handled, but it adds complication, and gains the
386 SPECIALISING INSTANCE DECLARATIONS
387 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
390 instance Foo a => Foo [a] where
392 {-# SPECIALIZE instance Foo [Int] #-}
394 The original instance decl creates a dictionary-function
397 dfun.Foo.List :: forall a. Foo a -> Foo [a]
399 The SPECIALIZE pragma just makes a specialised copy, just as for
400 ordinary function definitions:
402 dfun.Foo.List@Int :: Foo [Int]
403 dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
405 The information about what instance of the dfun exist gets added to
406 the dfun's IdInfo in the same way as a user-defined function too.
408 In fact, matters are a little bit more complicated than this.
409 When we make one of these specialised instances, we are defining
410 a constant dictionary, and so we want immediate access to its constant
411 methods and superclasses. Indeed, these constant methods and superclasses
412 must be in the IdInfo for the class selectors! We need help from the
413 typechecker to sort this out, perhaps by generating a separate IdInfo
416 Automatic instance decl specialisation?
417 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
418 Can instance decls be specialised automatically? It's tricky.
419 We could collect call-instance information for each dfun, but
420 then when we specialised their bodies we'd get new call-instances
421 for ordinary functions; and when we specialised their bodies, we might get
422 new call-instances of the dfuns, and so on. This all arises because of
423 the unrestricted mutual recursion between instance decls and value decls.
425 Furthermore, instance decls are usually exported and used non-locally,
426 so we'll want to compile enough to get those specialisations done.
428 Lastly, there's no such thing as a local instance decl, so we can
429 survive solely by spitting out *usage* information, and then reading that
430 back in as a pragma when next compiling the file. So for now,
431 we only specialise instance decls in response to pragmas.
433 That means that even if an instance decl ain't otherwise exported it
434 needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
435 something to say which module defined the instance, so the usage info
436 can be fed into the right reqts info file. Blegh.
439 SPECIAILISING DATA DECLARATIONS
440 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
442 With unboxed specialisation (or full specialisation) we also require
443 data types (and their constructors) to be speciailised on unboxed
446 In addition to normal call instances we gather TyCon call instances at
447 unboxed types, determine equivalence classes for the locally defined
448 TyCons and build speciailised data constructor Ids for each TyCon and
449 substitute these in the Con calls.
451 We need the list of local TyCons to partition the TyCon instance info.
452 We pass out a FiniteMap from local TyCons to Specialised Instances to
453 give to the interface and code genertors.
455 N.B. The specialised data constructors reference the original data
456 constructor and type constructor which do not have the updated
457 specialisation info attached. Any specialisation info must be
458 extracted from the TyCon map returned.
461 SPITTING OUT USAGE INFORMATION
462 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
464 To spit out usage information we need to traverse the code collecting
465 call-instance information for all imported (non-prelude?) functions
466 and data types. Then we equivalence-class it and spit it out.
468 This is done at the top-level when all the call instances which escape
469 must be for imported functions and data types.
472 Partial specialisation by pragmas
473 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
474 What about partial specialisation:
476 k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
477 {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
481 {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
483 Seems quite reasonable. Similar things could be done with instance decls:
485 instance (Foo a, Foo b) => Foo (a,b) where
487 {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
488 {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
490 Ho hum. Things are complex enough without this. I pass.
493 Requirements for the simplifer
494 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
495 The simplifier has to be able to take advantage of the specialisation.
497 * When the simplifier finds an application of a polymorphic f, it looks in
498 f's IdInfo in case there is a suitable instance to call instead. This converts
500 f t1 t2 d1 d2 ===> f_t1_t2
502 Note that the dictionaries get eaten up too!
504 * Dictionary selection operations on constant dictionaries must be
507 +.sel Int d ===> +Int
509 The obvious way to do this is in the same way as other specialised
510 calls: +.sel has inside it some IdInfo which tells that if it's applied
511 to the type Int then it should eat a dictionary and transform to +Int.
513 In short, dictionary selectors need IdInfo inside them for constant
516 * Exactly the same applies if a superclass dictionary is being
519 Eq.sel Int d ===> dEqInt
521 * Something similar applies to dictionary construction too. Suppose
522 dfun.Eq.List is the function taking a dictionary for (Eq a) to
523 one for (Eq [a]). Then we want
525 dfun.Eq.List Int d ===> dEq.List_Int
527 Where does the Eq [Int] dictionary come from? It is built in
528 response to a SPECIALIZE pragma on the Eq [a] instance decl.
530 In short, dfun Ids need IdInfo with a specialisation for each
531 constant instance of their instance declaration.
534 What does the specialisation IdInfo look like?
535 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
538 [Maybe Type] -- Instance types
539 Int -- No of dicts to eat
540 Id -- Specialised version
542 For example, if f has this SpecInfo:
544 SpecInfo [Just t1, Nothing, Just t3] 2 f'
548 f t1 t2 t3 d1 d2 ===> f t2
550 The "Nothings" identify type arguments in which the specialised
551 version is polymorphic.
553 What can't be done this way?
554 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
555 There is no way, post-typechecker, to get a dictionary for (say)
556 Eq a from a dictionary for Eq [a]. So if we find
560 we can't transform to
565 eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
567 Of course, we currently have no way to automatically derive
568 eqList, nor to connect it to the Eq [a] instance decl, but you
569 can imagine that it might somehow be possible. Taking advantage
570 of this is permanently ruled out.
572 Still, this is no great hardship, because we intend to eliminate
573 overloading altogether anyway!
578 What about types/classes mentioned in SPECIALIZE pragmas spat out,
579 but not otherwise exported. Even if they are exported, what about
580 their original names.
582 Suggestion: use qualified names in pragmas, omitting module for
583 prelude and "this module".
590 f a (d::Num a) = let g = ...
592 ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
594 Here, g is only called at one type, but the dictionary isn't in scope at the
595 definition point for g. Usually the type checker would build a
596 definition for d1 which enclosed g, but the transformation system
597 might have moved d1's defn inward.
603 What should we do when a value is specialised to a *strict* unboxed value?
605 map_*_* f (x:xs) = let h = f x
609 Could convert let to case:
611 map_*_Int# f (x:xs) = case f x of h# ->
615 This may be undesirable since it forces evaluation here, but the value
616 may not be used in all branches of the body. In the general case this
617 transformation is impossible since the mutual recursion in a letrec
618 cannot be expressed as a case.
620 There is also a problem with top-level unboxed values, since our
621 implementation cannot handle unboxed values at the top level.
623 Solution: Lift the binding of the unboxed value and extract it when it
626 map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
631 Now give it to the simplifier and the _Lifting will be optimised away.
633 The benfit is that we have given the specialised "unboxed" values a
634 very simple lifted semantics and then leave it up to the simplifier to
635 optimise it --- knowing that the overheads will be removed in nearly
638 In particular, the value will only be evaluted in the branches of the
639 program which use it, rather than being forced at the point where the
640 value is bound. For example:
642 filtermap_*_* p f (x:xs)
649 filtermap_*_Int# p f (x:xs)
650 = let h = case (f x) of h# -> _Lift h#
653 True -> case h of _Lift h#
657 The binding for h can still be inlined in the one branch and the
661 Question: When won't the _Lifting be eliminated?
663 Answer: When they at the top-level (where it is necessary) or when
664 inlining would duplicate work (or possibly code depending on
665 options). However, the _Lifting will still be eliminated if the
666 strictness analyser deems the lifted binding strict.
670 %************************************************************************
672 \subsubsection[CallInstances]{@CallInstances@ data type}
674 %************************************************************************
677 type FreeVarsSet = IdSet
678 type FreeTyVarsSet = TyVarSet
682 Id -- This Id; *new* ie *cloned* id
683 [Maybe Type] -- Specialised at these types (*new*, cloned)
684 -- Nothing => no specialisation on this type arg
685 -- is required (flag dependent).
686 [CoreArg] -- And these dictionaries; all ValArgs
687 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
688 (Maybe SpecInfo) -- For specialisation with explicit SpecId
692 pprCI :: CallInstance -> Pretty
693 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
694 = ppHang (ppCat [ppPStr SLIT("Call inst for"), ppr PprDebug id])
695 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
696 case maybe_specinfo of
697 Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
698 Just (SpecInfo _ _ spec_id)
699 -> ppCat [ppPStr SLIT("Explicit SpecId"), ppr PprDebug spec_id]
702 -- ToDo: instance Outputable CoreArg?
703 ppr_arg sty (TyArg t) = ppr sty t
704 ppr_arg sty (LitArg i) = ppr sty i
705 ppr_arg sty (VarArg v) = ppr sty v
707 isUnboxedCI :: CallInstance -> Bool
708 isUnboxedCI (CallInstance _ spec_tys _ _ _)
709 = any isUnboxedType (catMaybes spec_tys)
711 isExplicitCI :: CallInstance -> Bool
712 isExplicitCI (CallInstance _ _ _ _ (Just _))
714 isExplicitCI (CallInstance _ _ _ _ Nothing)
718 Comparisons are based on the {\em types}, ignoring the dictionary args:
722 cmpCI :: CallInstance -> CallInstance -> TAG_
723 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
724 = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
726 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
727 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
728 = cmpUniTypeMaybeList tys1 tys2
730 eqCI_tys :: CallInstance -> CallInstance -> Bool
732 = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
734 isCIofTheseIds :: [Id] -> CallInstance -> Bool
735 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
736 = any ((==) ci_id) ids
738 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
739 singleCI id tys dicts
740 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
741 emptyBag [] emptyIdSet 0 0
743 fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
745 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
746 explicitCI id tys specinfo
747 = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
749 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
750 dicts = panic "Specialise:explicitCI:dicts"
751 fv_set = unitIdSet id
753 -- We do not process the CIs for top-level dfuns or defms
754 -- Instead we require an explicit SPEC inst pragma for dfuns
755 -- and an explict method within any instances for the defms
757 getCIids :: Bool -> [Id] -> [Id]
758 getCIids True ids = filter not_dict_or_defm ids
762 = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
764 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
765 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
767 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
768 cis_here_list = bagToList cis_here
770 -- pprTrace "getCIs:"
771 -- (ppHang (ppBesides [ppChar '{',
772 -- interppSP PprDebug ids,
774 -- 4 (ppAboves (map pprCI cis_here_list)))
775 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
777 dumpCIs :: Bag CallInstance -- The call instances
778 -> Bool -- True <=> top level bound Ids
779 -> Bool -- True <=> dict bindings to be floated (specBind only)
780 -> [CallInstance] -- Call insts for bound ids (instBind only)
781 -> [Id] -- Bound ids *new*
782 -> [Id] -- Full bound ids: includes dumped dicts
783 -> Bag CallInstance -- Kept call instances
785 -- CIs are dumped if:
786 -- 1) they are a CI for one of the bound ids, or
787 -- 2) they mention any of the dicts in a local unfloated binding
789 -- For top-level bindings we allow the call instances to
790 -- float past a dict bind and place all the top-level binds
791 -- in a *global* Rec.
792 -- We leave it to the simplifier will sort it all out ...
794 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
795 = (if not (isEmptyBag cis_of_bound_id) &&
796 not (isEmptyBag cis_of_bound_id_without_inst_cis)
798 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
799 " (may be a non-HM recursive call)\n")
800 (ppHang (ppBesides [ppChar '{',
801 interppSP PprDebug bound_ids,
803 4 (ppAboves [ppPStr SLIT("Dumping CIs:"),
804 ppAboves (map pprCI (bagToList cis_of_bound_id)),
805 ppPStr SLIT("Instantiating CIs:"),
806 ppAboves (map pprCI inst_cis)]))
808 if top_lev || floating then
811 (if not (isEmptyBag cis_dump_unboxed)
812 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
813 (ppHang (ppBesides [ppChar '{',
814 interppSP PprDebug full_ids,
816 4 (ppAboves (map pprCI (bagToList cis_dump))))
818 cis_keep_not_bound_id
821 (cis_of_bound_id, cis_not_bound_id)
822 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
824 (cis_dump, cis_keep_not_bound_id)
825 = partitionBag ok_to_dump_ci cis_not_bound_id
827 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
828 = any (\ i -> i `elementOfIdSet` fv_set) full_ids
830 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
831 have_inst_ci ci = any (eqCI_tys ci) inst_cis
833 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
837 Any call instances of a bound_id can be safely dumped, because any
838 recursive calls should be at the same instance as the parent instance.
840 letrec f = /\a -> \x::a -> ...(f t x')...
842 Here, the type, t, at which f is used in its own RHS should be
843 just "a"; that is, the recursive call is at the same type as
844 the original call. That means that when specialising f at some
845 type, say Int#, we shouldn't find any *new* instances of f
846 arising from specialising f's RHS. The only instance we'll find
847 is another call of (f Int#).
849 We check this in dumpCIs by passing in all the instantiated call
850 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
851 for which there is no such instance.
853 We also report CIs dumped due to a bound dictionary arg if they
854 contain unboxed types.
856 %************************************************************************
858 \subsubsection[TyConInstances]{@TyConInstances@ data type}
860 %************************************************************************
864 = TyConInstance TyCon -- Type Constructor
865 [Maybe Type] -- Applied to these specialising types
867 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
868 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
869 = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
871 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
872 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
873 = cmpUniTypeMaybeList tys1 tys2
875 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
876 singleTyConI ty_con spec_tys
877 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
879 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
880 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
882 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
883 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
885 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
886 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
888 (tycon_cis_local, tycon_cis_global)
889 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
890 tycon_cis_local_list = bagToList tycon_cis_local
892 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
896 %************************************************************************
898 \subsubsection[UsageDetails]{@UsageDetails@ data type}
900 %************************************************************************
905 (Bag CallInstance) -- The collection of call-instances
906 (Bag TyConInstance) -- Constructor call-instances
907 [DictBindDetails] -- Dictionary bindings in data-dependence order!
908 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
909 Int -- no. of spec calls
910 Int -- no. of spec insts
913 The DictBindDetails are fully processed; their call-instance
914 information is incorporated in the call-instances of the UsageDetails
915 which includes the DictBindDetails. The free vars in a usage details
916 will *include* the binders of the DictBind details.
918 A @DictBindDetails@ contains bindings for dictionaries *only*.
923 [Id] -- Main binders, originally visible in scope of binding (cloned)
924 CoreBinding -- Fully processed
925 FreeVarsSet -- Free in binding group (cloned)
926 FreeTyVarsSet -- Free in binding group
930 emptyUDs :: UsageDetails
931 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
932 unionUDList :: [UsageDetails] -> UsageDetails
934 -- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
935 tickSpecInsts :: UsageDetails -> UsageDetails
937 -- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
938 -- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
940 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
941 = UsageDetails cis ty_cis dbs fvs c (i+1)
943 emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
945 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
946 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
947 (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
948 -- The append here is really redundant, since the bindings don't
949 -- scope over each other. ToDo.
951 unionUDList = foldr unionUDs emptyUDs
953 singleFvUDs (VarArg v) | not (isImportedId v)
954 = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
958 singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
960 dumpDBs :: [DictBindDetails]
961 -> Bool -- True <=> top level bound Ids
962 -> [TyVar] -- TyVars being bound (cloned)
963 -> [Id] -- Ids being bound (cloned)
964 -> FreeVarsSet -- Fvs of body
965 -> ([CoreBinding], -- These ones have to go here
966 [DictBindDetails], -- These can float further
967 [Id], -- Incoming list + names of dicts bound here
968 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
971 -- It is just to complex to try to float top-level
972 -- dict bindings with constant methods, inst methods,
973 -- auxillary derived instance defns and user instance
974 -- defns all getting in the way.
975 -- So we dump all dbinds as soon as we get to the top
976 -- level and place them in a *global* Rec.
977 -- We leave it to the simplifier will sort it all out ...
979 dumpDBs [] top_lev bound_tyvars bound_ids fvs
980 = ([], [], bound_ids, fvs)
982 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
983 top_lev bound_tyvars bound_ids fvs
985 || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
986 || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
987 = let -- Ha! Dump it!
988 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
989 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
991 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
993 | otherwise -- This one can float out further
995 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
996 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
998 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
1002 dumpUDs :: UsageDetails
1003 -> Bool -- True <=> top level bound Ids
1004 -> Bool -- True <=> dict bindings to be floated (specBind only)
1005 -> [CallInstance] -- Call insts for bound Ids (instBind only)
1006 -> [Id] -- Ids which are just being bound; *new*
1007 -> [TyVar] -- TyVars which are just being bound
1008 -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
1009 UsageDetails) -- The above bindings removed, and
1010 -- any call-instances which mention the ids dumped too
1012 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
1014 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
1015 = dumpDBs dbs top_lev tvs bound_ids fvs
1016 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
1017 fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
1019 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
1023 addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
1024 -> UsageDetails -- The usage to augment
1026 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
1027 (UsageDetails cis tycon_cis dbs fvs c i)
1028 = UsageDetails (db_cis `unionBags` cis)
1029 (db_tycon_cis `unionBags` tycon_cis)
1030 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
1032 -- NB: We ignore counts from dictbinds since it is not user code
1034 -- The free tyvars of the dictionary bindings should really be
1035 -- gotten from the RHSs, but I'm pretty sure it's good enough just
1036 -- to look at the type of the dictionary itself.
1037 -- Doing the proper job would entail keeping track of free tyvars as
1038 -- well as free vars, which would be a bore.
1039 db_ftvs = tyVarsOfTypes (map idType dbinders)
1042 %************************************************************************
1044 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
1046 %************************************************************************
1048 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
1050 1) (NoLift LitArg l) : an Id which is bound to a literal
1052 2) (NoLift LitArg l) : an Id bound to a "new" Id
1053 The new Id is a possibly-type-specialised clone of the original
1055 3) Lifted lifted_id unlifted_id :
1057 This indicates that the original Id has been specialised to an
1058 unboxed value which must be lifted (see "Unboxed bindings" above)
1059 @unlifted_id@ is the unboxed clone of the original Id
1060 @lifted_id@ is a *lifted* version of the original Id
1062 When you lookup Ids which are Lifted, you have to insert a case
1063 expression to un-lift the value (done with @bindUnlift@)
1065 You also have to insert a case to lift the value in the binding
1066 (done with @liftExpr@)
1070 type SpecIdEnv = IdEnv CloneInfo
1073 = NoLift CoreArg -- refers to cloned id or literal
1075 | Lifted Id -- lifted, cloned id
1076 Id -- unlifted, cloned id
1080 %************************************************************************
1082 \subsection[specialise-data]{Data returned by specialiser}
1084 %************************************************************************
1091 -- True <=> Specialisation performed
1093 -- False <=> Specialisation completed with errors
1096 -- Local tycons declared in this module
1099 -- Those in-scope data types for which we want to
1100 -- generate code for their constructors.
1101 -- Namely: data types declared in this module +
1102 -- any big tuples used in this module
1103 -- The initial (and default) value is the local tycons
1105 (FiniteMap TyCon [(Bool, [Maybe Type])])
1106 -- TyCon specialisations to be generated
1107 -- We generate specialialised code (Bool=True) for data types
1108 -- defined in this module and any tuples used in this module
1109 -- The initial (and default) value is the specialisations
1110 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1111 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1113 (Bag (Id,[Maybe Type]))
1114 -- Imported specialisation errors
1115 (Bag (Id,[Maybe Type]))
1116 -- Imported specialisation warnings
1117 (Bag (TyCon,[Maybe Type]))
1118 -- Imported TyCon specialisation errors
1120 initSpecData local_tycons tycon_specs
1121 = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1126 ToDo[sansom]: Transformation data to process specialisation requests.
1128 %************************************************************************
1130 \subsection[specProgram]{Specialising a core program}
1132 %************************************************************************
1135 specProgram :: UniqSupply
1136 -> [CoreBinding] -- input ...
1138 -> ([CoreBinding], -- main result
1139 SpecialiseData) -- result specialise data
1141 specProgram uniqs binds
1142 (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1143 = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
1144 (final_binds, tycon_specs_list,
1145 UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1147 used_conids = filter isDataCon (uniqSetToList fvs)
1148 used_tycons = map dataConTyCon used_conids
1149 used_gen = filter isLocalGenTyCon used_tycons
1150 gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
1152 result_specs = addListToFM_C (++) init_specs tycon_specs_list
1154 uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
1155 cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1156 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1157 cis_warn = init_warn `unionBags` listToBag cis_other
1158 cis_errs = init_errs `unionBags` listToBag cis_unboxed
1160 uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
1161 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1162 tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
1164 no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
1165 && (not opt_SpecialiseImports || isEmptyBag cis_warn)
1167 (if opt_D_simplifier_stats then
1168 pprTrace "\nSpecialiser Stats:\n" (ppAboves [
1169 ppBesides [ppPStr SLIT("SpecCalls "), ppInt spec_calls],
1170 ppBesides [ppPStr SLIT("SpecInsts "), ppInt spec_insts],
1175 SpecData True no_errs local_tycons gen_tycons result_specs
1176 cis_errs cis_warn tycis_errs)
1178 specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
1179 = panic "Specialise:specProgram: specialiser called more than once"
1181 -- It may be possible safely to call the specialiser more than once,
1182 -- but I am not sure there is any benefit in doing so (Patrick)
1184 -- ToDo: What about unfoldings performed after specialisation ???
1187 %************************************************************************
1189 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1191 %************************************************************************
1193 In the specialiser we just collect up the specialisations which will
1194 be required. We don't create the specialised constructors in
1195 Core. These are only introduced when we convert to StgSyn.
1197 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1200 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1201 -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1203 specTyConsAndScope scopeM
1204 = scopeM `thenSM` \ (binds, scope_uds) ->
1206 (tycons_cis, gotci_scope_uds)
1207 = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds
1209 tycon_specs_list = collectTyConSpecs tycons_cis
1211 (if opt_SpecialiseTrace && not (null tycon_specs_list) then
1212 pprTrace "Specialising TyCons:\n"
1213 (ppAboves [ if not (null specs) then
1214 ppHang (ppCat [(ppr PprDebug tycon), ppPStr SLIT("at types")])
1215 4 (ppAboves (map pp_specs specs))
1217 | (tycon, specs) <- tycon_specs_list])
1219 returnSM (binds, tycon_specs_list, gotci_scope_uds)
1222 collectTyConSpecs []
1224 collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1225 = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1227 (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1228 uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1229 tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1231 pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
1235 %************************************************************************
1237 \subsection[specTopBinds]{Specialising top-level bindings}
1239 %************************************************************************
1242 specTopBinds :: [CoreBinding]
1243 -> SpecM ([CoreBinding], UsageDetails)
1246 = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1248 -- Add bindings for floated dbinds and collect fvs
1249 -- In actual fact many of these bindings are dead code since dict
1250 -- arguments are dropped when a specialised call is created
1251 -- The simplifier should be able to cope ...
1253 (dbinders_s, dbinds, dfvs_s)
1254 = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1256 full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
1257 fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
1259 -- It is just to complex to try to sort out top-level dependencies
1260 -- So we just place all the top-level binds in a *global* Rec and
1261 -- leave it to the simplifier to sort it all out ...
1264 returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1267 spec_top_binds (first_bind:rest_binds)
1268 = specBindAndScope True first_bind (
1269 spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1270 returnSM (ItsABinds rest_binds, rest_uds)
1271 ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1272 returnSM (first_binds ++ rest_binds, all_uds)
1275 = returnSM ([], emptyUDs)
1278 %************************************************************************
1280 \subsection[specExpr]{Specialising expressions}
1282 %************************************************************************
1285 specExpr :: CoreExpr
1286 -> [CoreArg] -- The arguments:
1287 -- TypeArgs are speced
1288 -- ValArgs are unprocessed
1289 -> SpecM (CoreExpr, -- Result expression with specialised versions installed
1290 UsageDetails)-- Details of usage of enclosing binders in the result
1293 specExpr (Var v) args
1294 = specId v $ \ lookupId v `thenSM` \ vlookup ->
1297 -> -- Binding has been lifted, need to extract un-lifted value
1298 -- NB: a function binding will never be lifted => args always null
1299 -- i.e. no call instance required or call to be constructed
1301 returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
1303 NoLift vatom@(VarArg new_v)
1304 -> mapSM specOutArg args `thenSM` \ arg_info ->
1305 mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
1306 mkCall new_v arg_info `thenSM` \ call ->
1308 call mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
1309 uds = unionUDList [call_uds,
1311 unionUDList [uds | (_,uds,_) <- arg_info]
1314 returnSM (call, {- tickSpecCall speced -} uds)
1316 specExpr expr@(Lit _) null_args
1317 = ASSERT (null null_args)
1318 returnSM (expr, emptyUDs)
1320 specExpr (Con con args) null_args
1321 = ASSERT (null null_args)
1322 specArgs args $ \ args' ->
1323 mkTyConInstance con args' `thenSM` \ con_uds ->
1324 returnSM (Con con args', con_uds)
1326 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
1327 = ASSERT (null null_args)
1328 specArgs args $ \ args' ->
1329 mapSM specTy arg_tys `thenSM` \ arg_tys' ->
1330 specTy res_ty `thenSM` \ res_ty' ->
1331 returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs)
1333 specExpr (Prim prim args) null_args
1334 = ASSERT (null null_args)
1335 specArgs args $ \ args' ->
1336 -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
1337 returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
1341 specPrimOp :: PrimOp
1347 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1348 -- and/or chooses PrimOp specialised to any unboxed tys
1349 -- Errors are dealt with by returning a PrimOp call instance
1350 -- which will result in a cis_errs message
1352 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1356 specExpr (App fun arg) args
1357 = -- If TyArg, arg will be processed; otherwise, left alone
1358 specArg arg `thenSM` \ new_arg ->
1359 specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
1360 returnSM (expr, uds)
1362 specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
1363 = lookup_arg arg `thenSM` \ arg ->
1364 bindId binder arg (specExpr body args)
1366 lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1367 lookup_arg (VarArg v) = lookupId v
1369 specExpr (Lam (ValBinder binder) body) []
1370 = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1371 returnSM (Lam (ValBinder binder) body, uds)
1373 specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
1374 = -- Type lambda with argument; argument already spec'd
1375 bindTyVar tyvar ty ( specExpr body args )
1377 specExpr (Lam (TyBinder tyvar) body) []
1379 cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
1380 bindTyVar tyvar (mkTyVarTy new_tyvar) (
1381 specExpr body [] `thenSM` \ (body, body_uds) ->
1383 (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1385 returnSM (Lam (TyBinder new_tyvar)
1386 (mkCoLetsNoUnboxed binds_here body),
1390 specExpr (Case scrutinee alts) args
1391 = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
1392 specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
1393 returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
1395 scrutinee_type = coreExprType scrutinee
1397 specExpr (Let bind body) args
1398 = specBindAndScope False bind (
1399 specExpr body args `thenSM` \ (body, body_uds) ->
1400 returnSM (ItsAnExpr body, body_uds)
1401 ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1402 returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1404 specExpr (SCC cc expr) args
1405 = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
1406 mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1409 = if squashableDictishCcExpr cc expr -- can toss the _scc_
1413 returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1414 unionUDList args_uds_s `unionUDs` expr_uds)
1416 specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
1418 -- ToDo: This may leave some unspec'd dictionaries!!
1421 %************************************************************************
1423 \subsubsection{Specialising a lambda}
1425 %************************************************************************
1428 specLambdaOrCaseBody :: [Id] -- The binders
1429 -> CoreExpr -- The body
1430 -> [CoreArg] -- Its args
1431 -> SpecM ([Id], -- New binders
1432 CoreExpr, -- New body
1435 specLambdaOrCaseBody bound_ids body args
1436 = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
1437 bindIds bound_ids clone_infos (
1439 specExpr body args `thenSM` \ (body, body_uds) ->
1442 -- Dump any dictionary bindings (and call instances)
1443 -- from the scope which mention things bound here
1444 (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1446 returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1449 -- ToDo: Opportunity here to common-up dictionaries with same type,
1450 -- thus avoiding recomputation.
1453 A variable bound in a lambda or case is normally monomorphic so no
1454 specialised versions will be required. This is just as well since we
1455 do not know what code to specialise!
1457 Unfortunately this is not always the case. For example a class Foo
1458 with polymorphic methods gives rise to a dictionary with polymorphic
1459 components as follows:
1466 instance Foo Int where
1474 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1475 d.Foo.Int = (op1_Int, op2_Int)
1477 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1479 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1482 N.B. The type of the dictionary is not Hindley Milner!
1484 Now we must specialise op1 at {* Int#} which requires a version of
1485 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1486 not have access to its code to create the specialised version.
1488 If we specialise on overloaded types as well we specialise op1 at
1489 {Int Int#} d.Foo.Int:
1491 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1493 Though this is still invalid, after further simplification we get:
1495 op1_Int_Int# = opInt1 {Int#}
1497 Another round of specialisation will result in the specialised
1498 version of op1Int being called directly.
1500 For now we PANIC if a polymorphic lambda/case bound variable is found
1501 in a call instance with an unboxed type. Other call instances, arising
1502 from overloaded type arguments, are discarded since the unspecialised
1503 version extracted from the method can be called as normal.
1505 ToDo: Implement and test second round of specialisation.
1508 %************************************************************************
1510 \subsubsection{Specialising case alternatives}
1512 %************************************************************************
1516 specAlts (AlgAlts alts deflt) scrutinee_ty args
1517 = mapSM specTy ty_args `thenSM` \ ty_args ->
1518 mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
1519 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1520 returnSM (AlgAlts alts deflt,
1521 unionUDList alts_uds_s `unionUDs` deflt_uds)
1523 -- We use ty_args of scrutinee type to identify specialisation of
1526 (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
1527 getAppDataTyConExpandingDicts scrutinee_ty
1529 specAlgAlt ty_args (con,binders,rhs)
1530 = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
1531 mkTyConInstance con ty_args `thenSM` \ con_uds ->
1532 returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1534 specAlts (PrimAlts alts deflt) scrutinee_ty args
1535 = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
1536 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1537 returnSM (PrimAlts alts deflt,
1538 unionUDList alts_uds_s `unionUDs` deflt_uds)
1540 specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
1541 returnSM ((lit,rhs), uds)
1544 specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
1545 specDeflt (BindDefault binder rhs) args
1546 = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
1547 returnSM (BindDefault binder rhs, uds)
1551 %************************************************************************
1553 \subsubsection{Specialising an atom}
1555 %************************************************************************
1558 partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
1560 = span is_ty_arg args
1562 is_ty_arg (TyArg _) = True
1567 -> (Id -> SpecM (CoreExpr, UsageDetails))
1568 -> SpecM (CoreExpr, UsageDetails)
1570 = lookupId v `thenSM` \ vlookup ->
1574 -> thing_inside vu `thenSM` \ (expr, uds) ->
1575 returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
1578 -> thing_inside vatom `thenSM` \ (expr, uds) ->
1579 returnSM (expr, singleFvUDs vatom `unionUDs` uds)
1582 -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
1583 -> SpecM (CoreExpr, UsageDetails))
1585 specArg (TyArg ty) thing_inside
1586 = specTy ty `thenSM` \ new_ty ->
1587 thing_inside (TyArg new_ty)
1589 specArg (LitArg lit)
1590 = thing_inside (LitArg lit)
1595 specArgs [] thing_inside
1598 specArgs (arg:args) thing_inside
1599 = specArg arg $ \ arg' ->
1600 specArgs args $ \ args' ->
1601 thing_inside (arg' : args')
1605 %************************************************************************
1607 \subsubsection{Specialising bindings}
1609 %************************************************************************
1611 A classic case of when having a polymorphic recursive function would help!
1614 data BindsOrExpr = ItsABinds [CoreBinding]
1615 | ItsAnExpr CoreExpr
1620 :: Bool -- True <=> a top level group
1621 -> CoreBinding -- As yet unprocessed
1622 -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
1623 -> SpecM ([CoreBinding], -- Processed
1624 BindsOrExpr, -- Combined result
1625 UsageDetails) -- Usage details of the whole lot
1627 specBindAndScope top_lev bind scopeM
1628 = cloneLetBinders top_lev (is_rec bind) binders
1629 `thenSM` \ (new_binders, clone_infos) ->
1631 -- Two cases now: either this is a bunch of local dictionaries,
1632 -- in which case we float them; or its a bunch of other values,
1633 -- in which case we see if they correspond to any call-instances
1634 -- we have from processing the scope
1636 if not top_lev && all (isDictTy . idType) binders
1638 -- Ha! A group of local dictionary bindings
1640 bindIds binders clone_infos (
1642 -- Process the dictionary bindings themselves
1643 specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
1645 -- Process their scope
1646 scopeM `thenSM` \ (thing, scope_uds) ->
1648 -- Add the bindings to the current stuff
1649 final_uds = addDictBinds new_binders bind rhs_uds scope_uds
1651 returnSM ([], thing, final_uds)
1654 -- Ho! A group of bindings
1656 fixSM (\ ~(_, _, _, rec_spec_infos) ->
1658 bindSpecIds binders clone_infos rec_spec_infos (
1659 -- It's ok to have new binders in scope in
1660 -- non-recursive decls too, cos name shadowing is gone by now
1662 -- Do the scope of the bindings
1663 scopeM `thenSM` \ (thing, scope_uds) ->
1665 (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
1667 equiv_ciss = equivClasses cmpCI_tys call_insts
1668 inst_cis = map head equiv_ciss
1671 -- Do the bindings themselves
1672 specBind top_lev False new_binders inst_cis bind
1673 `thenSM` \ (spec_bind, spec_uds) ->
1675 -- Create any necessary instances
1676 instBind top_lev new_binders bind equiv_ciss inst_cis
1677 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
1680 -- NB: dumpUDs only worries about new_binders since the free var
1681 -- stuff only records free new_binders
1682 -- The spec_ids only appear in SpecInfos and final speced calls
1684 -- Build final binding group and usage details
1685 (final_binds, final_uds)
1687 -- For a top-level binding we have to dumpUDs from
1688 -- spec_uds and inst_uds and scope_uds creating
1689 -- *global* dict bindings
1691 (scope_dict_binds, final_scope_uds)
1692 = dumpUDs gotci_scope_uds True False [] new_binders []
1693 (spec_dict_binds, final_spec_uds)
1694 = dumpUDs spec_uds True False inst_cis new_binders []
1695 (inst_dict_binds, final_inst_uds)
1696 = dumpUDs inst_uds True False inst_cis new_binders []
1698 ([spec_bind] ++ inst_binds ++ scope_dict_binds
1699 ++ spec_dict_binds ++ inst_dict_binds,
1700 final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
1702 -- For a local binding we only have to dumpUDs from
1703 -- scope_uds since the UDs from spec_uds and inst_uds
1704 -- have already been dumped by specBind and instBind
1706 (scope_dict_binds, final_scope_uds)
1707 = dumpUDs gotci_scope_uds False False [] new_binders []
1709 ([spec_bind] ++ inst_binds ++ scope_dict_binds,
1710 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
1712 -- inst_uds comes last, because there may be dict bindings
1713 -- floating outward in scope_uds which are mentioned
1714 -- in the call-instances, and hence in spec_uds.
1715 -- This ordering makes sure that the precedence order
1716 -- among the dict bindings finally floated out is maintained.
1718 returnSM (final_binds, thing, final_uds, spec_infos)
1720 ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
1721 returnSM (binds, thing, final_uds)
1723 binders = bindersOf bind
1725 is_rec (NonRec _ _) = False
1730 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
1732 -> SpecM (CoreBinding, UsageDetails)
1733 -- The UsageDetails returned has already had stuff to do with this group
1734 -- of binders deleted; that's why new_binders is passed in.
1735 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
1736 = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
1737 `thenSM` \ ((binder,rhs), rhs_uds) ->
1738 returnSM (NonRec binder rhs, rhs_uds)
1740 specBind top_lev floating new_binders inst_cis (Rec pairs)
1741 = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
1742 `thenSM` \ (pairs, rhs_uds_s) ->
1743 returnSM (Rec pairs, unionUDList rhs_uds_s)
1746 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
1748 -> SpecM ((Id,CoreExpr), UsageDetails)
1750 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
1751 = lookupId binder `thenSM` \ blookup ->
1752 specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
1754 specid_maybe_maybe = isSpecPragmaId_maybe binder
1755 is_specid = maybeToBool specid_maybe_maybe
1756 Just specinfo_maybe = specid_maybe_maybe
1757 specid_with_info = maybeToBool specinfo_maybe
1758 Just spec_info = specinfo_maybe
1760 -- If we have a SpecInfo stored in a SpecPragmaId binder
1761 -- it will contain a SpecInfo with an explicit SpecId
1762 -- We add the explicit ci to the usage details
1763 -- Any ordinary cis for orig_id (there should only be one)
1764 -- will be ignored later
1767 = if is_specid && specid_with_info then
1769 (SpecInfo spec_tys _ spec_id) = spec_info
1770 Just (orig_id, _) = isSpecId_maybe spec_id
1772 ASSERT(toplevelishId orig_id) -- must not be cloned!
1773 explicitCI orig_id spec_tys spec_info
1777 -- For a local binding we dump the usage details, creating
1778 -- any local dict bindings required
1779 -- At the top-level the uds will be dumped in specBindAndScope
1780 -- and the dict bindings made *global*
1782 (local_dict_binds, final_uds)
1783 = if not top_lev then
1784 dumpUDs rhs_uds False floating inst_cis new_binders []
1789 Lifted lift_binder unlift_binder
1790 -> -- We may need to record an unboxed instance of
1791 -- the _Lift data type in the usage details
1792 mkTyConInstance liftDataCon [idType unlift_binder]
1793 `thenSM` \ lift_uds ->
1794 returnSM ((lift_binder,
1795 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
1796 final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
1798 NoLift (VarArg binder)
1799 -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
1800 final_uds `unionUDs` pragma_uds)
1804 %************************************************************************
1806 \subsection{@instBind@}
1808 %************************************************************************
1811 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
1813 = returnSM ([], emptyUDs, [])
1815 | all same_overloading other_binders
1816 = -- For each call_inst, build an instance
1817 mapAndUnzip3SM do_this_class equiv_ciss
1818 `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
1820 -- Add in the remaining UDs
1821 returnSM (catMaybes inst_binds,
1822 unionUDList inst_uds_s,
1826 | otherwise -- Incompatible overloadings; see below by same_overloading
1827 = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
1828 then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
1830 then pprTrace "dumpCIs: not same overloading ... top level \n"
1832 ) (ppHang (ppBesides [ppPStr SLIT("{"),
1833 interppSP PprDebug new_ids,
1835 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids),
1836 ppAboves (map pprCI (concat equiv_ciss))]))
1837 (returnSM ([], emptyUDs, []))
1840 (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
1841 tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
1843 no_of_tyvars = length tyvar_tmpls
1844 no_of_dicts = length class_tyvar_pairs
1846 do_this_class equiv_cis
1847 = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
1849 (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
1850 do_cis = head (normal_cis ++ explicit_cis)
1851 -- must choose a normal_cis in preference since dict_args will
1852 -- not be defined for an explicit_cis
1854 -- same_overloading tests whether the types of all the binders
1855 -- are "compatible"; ie have the same type and dictionary abstractions
1856 -- Almost always this is the case, because a recursive group is abstracted
1857 -- all together. But, it can happen that it ain't the case, because of
1858 -- code generated from instance decls:
1861 -- dfun.Foo.Int :: (forall a. a -> Int, Int)
1862 -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
1864 -- const.op1.Int :: forall a. a -> Int
1865 -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
1867 -- const.op2.Int :: Int
1868 -- const.op2.Int = 3
1870 -- Note that the first two defns have different polymorphism, but they are
1871 -- mutually recursive!
1873 same_overloading :: Id -> Bool
1875 = no_of_tyvars == length this_id_tyvars
1876 -- Same no of tyvars
1877 && no_of_dicts == length this_id_class_tyvar_pairs
1878 -- Same no of vdicts
1879 && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
1880 && length class_tyvar_pairs == length this_id_class_tyvar_pairs
1883 (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
1884 tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
1886 same_ov (clas1,tyvar1) (clas2,tyvar2)
1888 tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
1892 - a call instance eg f [t1,t2,t3] [d1,d2]
1893 - the rhs of the function eg orig_rhs
1894 - a constraint vector, saying which of eg [T,F,T]
1895 the functions type args are constrained
1898 We return a new definition
1900 $f1 = /\a -> orig_rhs t1 a t3 d1 d2
1902 The SpecInfo for f will be:
1904 SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
1906 Based on this SpecInfo, a call instance of f
1910 should get replaced by
1912 ...(\d1 d2 -> $f1 t2)...
1914 (But that is the business of the simplifier.)
1917 mkOneInst :: CallInstance
1918 -> [CallInstance] -- Any explicit cis for this inst
1919 -> Int -- No of dicts to specialise
1920 -> Bool -- Top level binders?
1921 -> [CallInstance] -- Instantiated call insts for binders
1922 -> [Id] -- New binders
1923 -> CoreBinding -- Unprocessed
1924 -> SpecM (Maybe CoreBinding, -- Instantiated version of input
1926 [Maybe SpecInfo] -- One for each id in the original binding
1929 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
1930 no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
1931 = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
1932 `thenSM` \ spec_ids ->
1933 newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
1935 -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
1936 -- which correspond to unspeciailsed args
1938 (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
1941 args = map TyArg arg_tys ++ dict_args
1943 (new_id:_) = new_ids
1944 (spec_id:_) = spec_ids
1946 do_bind (NonRec orig_id rhs)
1947 = do_one_rhs (spec_id, new_id, (orig_id,rhs))
1948 `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
1950 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
1951 Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
1954 = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
1955 `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
1956 returnSM (Just (Rec (catMaybes maybe_pairs)),
1957 unionUDList rhss_uds_s, spec_infos)
1959 do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
1961 -- Avoid duplicating a spec which has already been created ...
1962 -- This can arise in a Rec involving a dfun for which a
1963 -- a specialised instance has been created but specialisation
1964 -- "required" by one of the other Ids in the Rec
1965 | top_lev && maybeToBool lookup_orig_spec
1966 = (if opt_SpecialiseTrace
1967 then trace_nospec " Exists: " orig_id
1970 returnSM (Nothing, emptyUDs, Nothing)
1973 -- Check for a (single) explicit call instance for this id
1974 | not (null explicit_cis_for_this_id)
1975 = ASSERT (length explicit_cis_for_this_id == 1)
1976 (if opt_SpecialiseTrace
1977 then trace_nospec " Explicit: " explicit_id
1980 returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
1983 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
1985 = ASSERT (no_of_dicts_to_specialise == length dict_args)
1986 specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
1988 -- For a local binding we dump the usage details, creating
1989 -- any local dict bindings required
1990 -- At the top-level the uds will be dumped in specBindAndScope
1991 -- and the dict bindings made *global*
1993 (local_dict_binds, final_uds)
1994 = if not top_lev then
1995 dumpUDs inst_uds False False inst_cis new_ids []
1999 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
2001 if isUnboxedType (idType spec_id) then
2002 ASSERT (null poly_tyvars)
2003 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2004 mkTyConInstance liftDataCon [idType unlift_spec_id]
2005 `thenSM` \ lift_uds ->
2006 returnSM (Just (lift_spec_id,
2007 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
2008 tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
2010 returnSM (Just (spec_id,
2011 mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
2012 tickSpecInsts final_uds, spec_info)
2014 lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
2016 explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
2017 [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
2018 SpecInfo _ _ explicit_id = explicit_spec_info
2020 trace_nospec :: String -> Id -> a -> a
2021 trace_nospec str spec_id
2023 (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys),
2024 ppPStr SLIT("==>"), ppr PprDebug spec_id])
2026 (if opt_SpecialiseTrace then
2027 pprTrace "Specialising:"
2028 (ppHang (ppBesides [ppChar '{',
2029 interppSP PprDebug new_ids,
2032 ppBesides [ppPStr SLIT("types: "), ppInterleave ppNil (map pp_ty arg_tys)],
2033 if isExplicitCI do_cis then ppNil else
2034 ppBesides [ppPStr SLIT("dicts: "), ppInterleave ppNil (map pp_dict dict_args)],
2035 ppBesides [ppPStr SLIT("specs: "), ppr PprDebug spec_ids]]))
2038 do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
2040 returnSM (maybe_inst_bind, inst_uds, spec_infos)
2043 pp_dict d = ppr_arg PprDebug d
2044 pp_ty t = pprParendGenType PprDebug t
2046 do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
2047 do_the_wotsit tyvars (Just ty) = (tyvars, ty)
2051 %************************************************************************
2053 \subsection[Misc]{Miscellaneous junk}
2055 %************************************************************************
2058 mkCallInstance :: Id
2061 -> SpecM UsageDetails
2063 mkCallInstance id new_id []
2066 mkCallInstance id new_id args
2068 -- No specialised versions for "error" and friends are req'd.
2069 -- This is a special case in core lint etc.
2074 -- No call instances for SuperDictSelIds
2075 -- These are a special case in mkCall
2077 | maybeToBool (isSuperDictSelId_maybe id)
2080 -- There are also no call instances for ClassOpIds
2081 -- However, we need to process it to get any second-level call
2082 -- instances for a ConstMethodId extracted from its SpecEnv
2086 (tyvars, class_tyvar_pairs) = getIdOverloading id
2087 constrained_tyvars = map snd class_tyvar_pairs -- May contain dups
2088 constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars]
2090 arg_res = take_type_args tyvars class_tyvar_pairs args
2091 enough_args = maybeToBool arg_res
2094 (Just (tys, dicts, rest_args)) = arg_res
2097 = (record, lookup, spec_tys)
2099 spec_tys = specialiseCallTys constraint_vec tys
2101 record = any (not . isTyVarTy) (catMaybes spec_tys)
2103 lookup = lookupSpecEnv (getIdSpecialisation id) tys
2105 if (not enough_args) then
2106 pprTrace "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
2107 (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) args)) $
2111 case record_spec id tys of
2113 -> -- pprTrace "CallInst:NotReqd\n"
2114 -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
2117 (True, Nothing, spec_tys)
2118 -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
2121 -- pprTrace "CallInst:Reqd\n"
2122 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2123 -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys),
2124 -- ppCat (map (ppr PprDebug) dicts)]])
2125 (returnSM (singleCI new_id spec_tys dicts))
2127 (True, Just (spec_id, tys_left, toss), _)
2128 -> if maybeToBool (isConstMethodId_maybe spec_id) then
2129 -- If we got a const method spec_id see if further spec required
2130 -- NB: const method is top-level so spec_id will not be cloned
2131 case record_spec spec_id tys_left of
2133 -> -- pprTrace "CallInst:Exists\n"
2134 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2135 -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
2136 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2139 (True, Nothing, spec_tys)
2140 -> -- pprTrace "CallInst:Exists:Reqd\n"
2141 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2142 -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
2143 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2144 -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys),
2145 -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
2146 (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
2148 (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
2149 -> -- pprTrace "CallInst:Exists:Exists\n"
2150 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2151 -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
2152 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2153 -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_spec_id,
2154 -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
2158 -- pprTrace "CallInst:Exists\n"
2159 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2160 -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id,
2161 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2165 take_type_args (_:tyvars) class_tyvar_pairs (TyArg ty : args)
2166 = case (take_type_args tyvars class_tyvar_pairs args) of
2168 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2170 take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing
2172 take_type_args [] class_tyvar_pairs args
2173 = case (take_dict_args class_tyvar_pairs args) of
2175 Just (dicts, others) -> Just ([], dicts, others)
2177 take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
2178 = case (take_dict_args class_tyvar_pairs args) of
2180 Just (dicts, others) -> Just (dict:dicts, others)
2182 take_dict_args (_:class_tyvar_pairs) [] = Nothing
2184 take_dict_args [] args = Just ([], args)
2189 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2192 mkCall new_id arg_infos = returnSM (
2195 | maybeToBool (isSuperDictSelId_maybe new_id)
2196 && any isUnboxedType ty_args
2197 -- No specialisations for super-dict selectors
2198 -- Specialise unboxed calls to SuperDictSelIds by extracting
2199 -- the super class dictionary directly form the super class
2200 -- NB: This should be dead code since all uses of this dictionary should
2201 -- have been specialised. We only do this to keep core-lint happy.
2203 Just (_, super_class) = isSuperDictSelId_maybe new_id
2204 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2205 Nothing -> panic "Specialise:mkCall:SuperDictId"
2208 returnSM (False, Var super_dict_id)
2211 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2212 Nothing -> checkUnspecOK new_id ty_args (
2213 returnSM (False, unspec_call)
2216 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2218 -- It may be necessary to specialsie a constant method spec_id again
2219 (spec_id, tys_left, dicts_to_toss) =
2220 case (maybeToBool (isConstMethodId_maybe spec_id_1),
2221 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2222 (False, _ ) -> spec_1_details
2223 (True, Nothing) -> spec_1_details
2224 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2225 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2227 args_left = toss_dicts dicts_to_toss val_args
2229 checkSpecOK new_id ty_args spec_id tys_left (
2231 -- The resulting spec_id may be a top-level unboxed value
2232 -- This can arise for:
2233 -- 1) constant method values
2234 -- eq: class Num a where pi :: a
2235 -- instance Num Double# where pi = 3.141#
2236 -- 2) specilised overloaded values
2237 -- eq: i1 :: Num a => a
2238 -- i1 Int# d.Num.Int# ==> i1.Int#
2239 -- These top level defns should have been lifted.
2240 -- We must add code to unlift such a spec_id.
2242 if isUnboxedType (idType spec_id) then
2243 ASSERT (null tys_left && null args_left)
2244 if toplevelishId spec_id then
2245 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2246 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2247 (Var unlift_spec_id))
2249 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2250 (ppCat [ppr PprDebug new_id,
2251 ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
2253 ppr PprDebug spec_id])
2256 (vals_left, _, unlifts_left) = unzip3 args_left
2257 applied_tys = mkTyApp (Var spec_id) tys_left
2258 applied_vals = mkGenApp applied_tys vals_left
2260 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2263 (tys_and_vals, _, unlifts) = unzip3 args
2264 unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2267 -- ty_args is the types at the front of the arg list
2268 -- val_args is the rest of the arg-list
2270 (ty_args, val_args) = get args
2272 get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2273 get args = ([], args)
2276 -- toss_dicts chucks away dict args, checking that they ain't types!
2277 toss_dicts 0 args = args
2278 toss_dicts n ((a,_,_) : args)
2279 | isValArg a = toss_dicts (n-1) args
2284 checkUnspecOK :: Id -> [Type] -> a -> a
2285 checkUnspecOK check_id tys
2286 = if isLocallyDefined check_id && any isUnboxedType tys
2287 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2288 (ppCat [ppr PprDebug check_id,
2289 ppInterleave ppNil (map (pprParendGenType PprDebug) tys)])
2292 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2293 checkSpecOK check_id tys spec_id tys_left
2294 = if any isUnboxedType tys_left
2295 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2296 (ppAboves [ppCat [ppr PprDebug check_id,
2297 ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
2298 ppCat [ppr PprDebug spec_id,
2299 ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
2305 mkTyConInstance :: Id
2307 -> SpecM UsageDetails
2308 mkTyConInstance con tys
2309 = recordTyConInst con tys `thenSM` \ record_inst ->
2311 Nothing -- No TyCon instance
2312 -> -- pprTrace "NoTyConInst:"
2313 -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"),
2314 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
2315 (returnSM (singleConUDs con))
2317 Just spec_tys -- Record TyCon instance
2318 -> -- pprTrace "TyConInst:"
2319 -- (ppCat [ppr PprDebug tycon, ppPStr SLIT("at"),
2320 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
2321 -- ppBesides [ppChar '(',
2322 -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
2324 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2326 tycon = dataConTyCon con
2330 recordTyConInst :: Id
2332 -> SpecM (Maybe [Maybe Type])
2334 recordTyConInst con tys
2336 spec_tys = specialiseConstrTys tys
2338 do_tycon_spec = maybeToBool (firstJust spec_tys)
2340 spec_exists = maybeToBool (lookupSpecEnv
2341 (getIdSpecialisation con)
2344 -- pprTrace "ConSpecExists?: "
2345 -- (ppAboves [ppPStr (if spec_exists then SLIT("True") else SLIT("False")),
2346 -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
2347 (if (not spec_exists && do_tycon_spec)
2348 then returnSM (Just spec_tys)
2349 else returnSM Nothing)
2352 %************************************************************************
2354 \subsection[monad-Specialise]{Monad used in specialisation}
2356 %************************************************************************
2360 inherited: control flags and
2361 recordInst functions with flags cached
2363 environment mapping tyvars to types
2364 environment mapping Ids to Atoms
2366 threaded in and out: unique supply
2369 type TypeEnv = TyVarEnv Type
2378 = m nullTyVarEnv nullIdEnv uniqs
2380 returnSM :: a -> SpecM a
2381 thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
2382 fixSM :: (a -> SpecM a) -> SpecM a
2384 thenSM m k tvenv idenv us
2385 = case splitUniqSupply us of { (s1, s2) ->
2386 case (m tvenv idenv s1) of { r ->
2387 k r tvenv idenv s2 }}
2389 returnSM r tvenv idenv us = r
2391 fixSM k tvenv idenv us
2394 r = k r tvenv idenv us -- Recursive in r!
2397 The only interesting bit is figuring out the type of the SpecId!
2400 newSpecIds :: [Id] -- The id of which to make a specialised version
2401 -> [Maybe Type] -- Specialise to these types
2402 -> Int -- No of dicts to specialise
2405 newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
2406 = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2407 | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
2409 uniqs = getUniques (length new_ids) us
2410 spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2412 newTyVars :: Int -> SpecM [TyVar]
2413 newTyVars n tvenv idenv us
2414 = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
2417 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2418 binders, and build ``clones'' for them. The clones differ from the
2419 originals in three ways:
2421 (a) they have a fresh unique
2422 (b) they have the current type environment applied to their type
2423 (c) for Let binders which have been specialised to unboxed values
2424 the clone will have a lifted type
2426 As well as returning the list of cloned @Id@s they also return a list of
2427 @CloneInfo@s which the original binders should be bound to.
2430 cloneLambdaOrCaseBinders :: [Id] -- Old binders
2431 -> SpecM ([Id], [CloneInfo]) -- New ones
2433 cloneLambdaOrCaseBinders old_ids tvenv idenv us
2435 uniqs = getUniques (length old_ids) us
2437 unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
2439 clone_it old_id uniq
2440 = (new_id, NoLift (VarArg new_id))
2442 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2444 cloneLetBinders :: Bool -- Top level ?
2445 -> Bool -- Recursice
2446 -> [Id] -- Old binders
2447 -> SpecM ([Id], [CloneInfo]) -- New ones
2449 cloneLetBinders top_lev is_rec old_ids tvenv idenv us
2451 uniqs = getUniques (2 * length old_ids) us
2453 unzip (clone_them old_ids uniqs)
2455 clone_them [] [] = []
2457 clone_them (old_id:olds) (u1:u2:uniqs)
2460 NoLift (VarArg old_id)) : clone_rest
2462 -- Don't clone if it is a top-level thing. Why not?
2463 -- (a) we don't want to change the uniques
2465 -- (b) we don't have to be paranoid about name capture
2466 -- (c) the thing is polymorphic so no need to subst
2469 = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
2471 Lifted lifted_id unlifted_id) : clone_rest
2473 NoLift (VarArg new_id)) : clone_rest
2476 clone_rest = clone_them olds uniqs
2478 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2479 new_ty = idType new_id
2480 old_ty = idType old_id
2482 (lifted_id, unlifted_id) = mkLiftedId new_id u2
2485 cloneTyVarSM :: TyVar -> SpecM TyVar
2487 cloneTyVarSM old_tyvar tvenv idenv us
2491 cloneTyVar old_tyvar uniq -- new_tyvar
2493 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2495 bindId id val specm tvenv idenv us
2496 = specm tvenv (addOneToIdEnv idenv id val) us
2498 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2500 bindIds olds news specm tvenv idenv us
2501 = specm tvenv (growIdEnvList idenv (zip olds news)) us
2503 bindSpecIds :: [Id] -- Old
2504 -> [(CloneInfo)] -- New
2505 -> [[Maybe SpecInfo]] -- Corresponding specialisations
2506 -- Each sub-list corresponds to a different type,
2507 -- and contains one Maybe spec_info for each id
2511 bindSpecIds olds clones spec_infos specm tvenv idenv us
2512 = specm tvenv (growIdEnvList idenv old_to_clone) us
2514 old_to_clone = mk_old_to_clone olds clones spec_infos
2516 -- The important thing here is that we are *lazy* in spec_infos
2517 mk_old_to_clone [] [] _ = []
2518 mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2519 = (old, add_spec_info clone) :
2520 mk_old_to_clone rest_olds rest_clones spec_infos_rest
2522 add_spec_info (NoLift (VarArg new))
2523 = NoLift (VarArg (new `addIdSpecialisation`
2524 (mkSpecEnv spec_infos_this_id)))
2525 add_spec_info lifted
2526 = lifted -- no specialised instances for unboxed lifted values
2528 spec_infos_this_id = catMaybes (map head spec_infos)
2529 spec_infos_rest = map tail spec_infos
2532 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2534 bindTyVar tyvar ty specm tvenv idenv us
2535 = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2539 lookupId :: Id -> SpecM CloneInfo
2541 lookupId id tvenv idenv us
2542 = case lookupIdEnv idenv id of
2543 Nothing -> NoLift (VarArg id)
2548 specTy :: Type -> SpecM Type -- Apply the current type envt to the type
2550 specTy ty tvenv idenv us
2551 = applyTypeEnvToTy tvenv ty
2555 liftId :: Id -> SpecM (Id, Id)
2556 liftId id tvenv idenv us
2563 In other monads these @mapSM@ things are usually called @listM@.
2564 I think @mapSM@ is a much better name. The `2' and `3' variants are
2565 when you want to return two or three results, and get at them
2566 separately. It saves you having to do an (unzip stuff) right after.
2569 mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
2570 mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
2571 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2572 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2574 mapSM f [] = returnSM []
2575 mapSM f (x:xs) = f x `thenSM` \ r ->
2576 mapSM f xs `thenSM` \ rs ->
2579 mapAndUnzipSM f [] = returnSM ([],[])
2580 mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
2581 mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
2582 returnSM ((r1:rs1),(r2:rs2))
2584 mapAndUnzip3SM f [] = returnSM ([],[],[])
2585 mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
2586 mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
2587 returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2589 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2590 mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
2591 mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
2592 returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))