2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
7 #include "HsVersions.h"
20 import PrelInfo ( liftDataCon, PrimOp(..), PrimRep -- for CCallOp
21 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
22 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
26 import CmdLineOpts ( GlobalSwitch(..) )
27 import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
30 import IdInfo -- All of it
31 import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) )
32 import UniqSet -- All of it
39 %************************************************************************
41 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
43 %************************************************************************
45 These notes describe how we implement specialisation to eliminate
46 overloading, and optionally to eliminate unboxed polymorphism, and
49 The specialisation pass is a partial evaluator which works on Core
50 syntax, complete with all the explicit dictionary application,
51 abstraction and construction as added by the type checker. The
52 existing type checker remains largely as it is.
54 One important thought: the {\em types} passed to an overloaded
55 function, and the {\em dictionaries} passed are mutually redundant.
56 If the same function is applied to the same type(s) then it is sure to
57 be applied to the same dictionary(s)---or rather to the same {\em
58 values}. (The arguments might look different but they will evaluate
61 Second important thought: we know that we can make progress by
62 treating dictionary arguments as static and worth specialising on. So
63 we can do without binding-time analysis, and instead specialise on
64 dictionary arguments and no others.
73 and suppose f is overloaded.
75 STEP 1: CALL-INSTANCE COLLECTION
77 We traverse <body>, accumulating all applications of f to types and
80 (Might there be partial applications, to just some of its types and
81 dictionaries? In principle yes, but in practice the type checker only
82 builds applications of f to all its types and dictionaries, so partial
83 applications could only arise as a result of transformation, and even
84 then I think it's unlikely. In any case, we simply don't accumulate such
85 partial applications.)
87 There's a choice of whether to collect details of all *polymorphic* functions
88 or simply all *overloaded* ones. How to sort this out?
89 Pass in a predicate on the function to say if it is "interesting"?
90 This is dependent on the user flags: SpecialiseOverloaded
96 So now we have a collection of calls to f:
100 Notice that f may take several type arguments. To avoid ambiguity, we
101 say that f is called at type t1/t2 and t3/t4.
103 We take equivalence classes using equality of the *types* (ignoring
104 the dictionary args, which as mentioned previously are redundant).
106 STEP 3: SPECIALISATION
108 For each equivalence class, choose a representative (f t1 t2 d1 d2),
109 and create a local instance of f, defined thus:
111 f@t1/t2 = <f_rhs> t1 t2 d1 d2
113 (f_rhs presumably has some big lambdas and dictionary lambdas, so lots
114 of simplification will now result.) Then we should recursively do
117 The new id has its own unique, but its print-name (if exported) has
118 an explicit representation of the instance types t1/t2.
120 Add this new id to f's IdInfo, to record that f has a specialised version.
122 Before doing any of this, check that f's IdInfo doesn't already
123 tell us about an existing instance of f at the required type/s.
124 (This might happen if specialisation was applied more than once, or
125 it might arise from user SPECIALIZE pragmas.)
129 Wait a minute! What if f is recursive? Then we can't just plug in
130 its right-hand side, can we?
132 But it's ok. The type checker *always* creates non-recursive definitions
133 for overloaded recursive functions. For example:
135 f x = f (x+x) -- Yes I know its silly
139 f a (d::Num a) = let p = +.sel a d
141 letrec fl (y::a) = fl (p y y)
145 We still have recusion for non-overloadd functions which we
146 speciailise, but the recursive call should get speciailised to the
147 same recursive version.
153 All this is crystal clear when the function is applied to *constant
154 types*; that is, types which have no type variables inside. But what if
155 it is applied to non-constant types? Suppose we find a call of f at type
156 t1/t2. There are two possibilities:
158 (a) The free type variables of t1, t2 are in scope at the definition point
159 of f. In this case there's no problem, we proceed just as before. A common
160 example is as follows. Here's the Haskell:
165 After typechecking we have
167 g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
168 in +.sel a d (f a d y) (f a d y)
170 Notice that the call to f is at type type "a"; a non-constant type.
171 Both calls to f are at the same type, so we can specialise to give:
173 g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
174 in +.sel a d (f@a y) (f@a y)
177 (b) The other case is when the type variables in the instance types
178 are *not* in scope at the definition point of f. The example we are
179 working with above is a good case. There are two instances of (+.sel a d),
180 but "a" is not in scope at the definition of +.sel. Can we do anything?
181 Yes, we can "common them up", a sort of limited common sub-expression deal.
184 g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
185 f@a (x::a) = +.sel@a x x
186 in +.sel@a (f@a y) (f@a y)
188 This can save work, and can't be spotted by the type checker, because
189 the two instances of +.sel weren't originally at the same type.
193 * There are quite a few variations here. For example, the defn of
194 +.sel could be floated ouside the \y, to attempt to gain laziness.
195 It certainly mustn't be floated outside the \d because the d has to
198 * We don't want to inline f_rhs in this case, because
199 that will duplicate code. Just commoning up the call is the point.
201 * Nothing gets added to +.sel's IdInfo.
203 * Don't bother unless the equivalence class has more than one item!
205 Not clear whether this is all worth it. It is of course OK to
206 simply discard call-instances when passing a big lambda.
208 Polymorphism 2 -- Overloading
210 Consider a function whose most general type is
212 f :: forall a b. Ord a => [a] -> b -> b
214 There is really no point in making a version of g at Int/Int and another
215 at Int/Bool, because it's only instancing the type variable "a" which
216 buys us any efficiency. Since g is completely polymorphic in b there
217 ain't much point in making separate versions of g for the different
220 That suggests that we should identify which of g's type variables
221 are constrained (like "a") and which are unconstrained (like "b").
222 Then when taking equivalence classes in STEP 2, we ignore the type args
223 corresponding to unconstrained type variable. In STEP 3 we make
224 polymorphic versions. Thus:
226 f@t1/ = /\b -> <f_rhs> t1 b d1 d2
228 This seems pretty simple, and a Good Thing.
230 Polymorphism 3 -- Unboxed
233 If we are speciailising at unboxed types we must speciailise
234 regardless of the overloading constraint. In the exaple above it is
235 worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
238 Note that specialising an overloaded type at an uboxed type requires
239 an unboxed instance -- we cannot default to an unspecialised version!
246 f x = let g p q = p==q
252 Before specialisation, leaving out type abstractions we have
254 f df x = let g :: Eq a => a -> a -> Bool
256 h :: Num a => a -> a -> (a, Bool)
257 h dh r s = let deq = eqFromNum dh
258 in (+ dh r s, g deq r s)
262 After specialising h we get a specialised version of h, like this:
264 h' r s = let deq = eqFromNum df
265 in (+ df r s, g deq r s)
267 But we can't naively make an instance for g from this, because deq is not in scope
268 at the defn of g. Instead, we have to float out the (new) defn of deq
269 to widen its scope. Notice that this floating can't be done in advance -- it only
270 shows up when specialisation is done.
272 DELICATE MATTER: the way we tell a dictionary binding is by looking to
273 see if it has a Dict type. If the type has been "undictify'd", so that
274 it looks like a tuple, then the dictionary binding won't be floated, and
275 an opportunity to specialise might be lost.
277 User SPECIALIZE pragmas
278 ~~~~~~~~~~~~~~~~~~~~~~~
279 Specialisation pragmas can be digested by the type checker, and implemented
280 by adding extra definitions along with that of f, in the same way as before
282 f@t1/t2 = <f_rhs> t1 t2 d1 d2
284 Indeed the pragmas *have* to be dealt with by the type checker, because
285 only it knows how to build the dictionaries d1 and d2! For example
287 g :: Ord a => [a] -> [a]
288 {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
290 Here, the specialised version of g is an application of g's rhs to the
291 Ord dictionary for (Tree Int), which only the type checker can conjure
292 up. There might not even *be* one, if (Tree Int) is not an instance of
293 Ord! (All the other specialision has suitable dictionaries to hand
296 Problem. The type checker doesn't have to hand a convenient <f_rhs>, because
297 it is buried in a complex (as-yet-un-desugared) binding group.
300 f@t1/t2 = f* t1 t2 d1 d2
302 where f* is the Id f with an IdInfo which says "inline me regardless!".
303 Indeed all the specialisation could be done in this way.
304 That in turn means that the simplifier has to be prepared to inline absolutely
305 any in-scope let-bound thing.
308 Again, the pragma should permit polymorphism in unconstrained variables:
310 h :: Ord a => [a] -> b -> b
311 {-# SPECIALIZE h :: [Int] -> b -> b #-}
313 We *insist* that all overloaded type variables are specialised to ground types,
314 (and hence there can be no context inside a SPECIALIZE pragma).
315 We *permit* unconstrained type variables to be specialised to
317 - or left as a polymorphic type variable
318 but nothing in between. So
320 {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
322 is *illegal*. (It can be handled, but it adds complication, and gains the
326 SPECIALISING INSTANCE DECLARATIONS
327 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
330 instance Foo a => Foo [a] where
332 {-# SPECIALIZE instance Foo [Int] #-}
334 The original instance decl creates a dictionary-function
337 dfun.Foo.List :: forall a. Foo a -> Foo [a]
339 The SPECIALIZE pragma just makes a specialised copy, just as for
340 ordinary function definitions:
342 dfun.Foo.List@Int :: Foo [Int]
343 dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
345 The information about what instance of the dfun exist gets added to
346 the dfun's IdInfo in the same way as a user-defined function too.
348 In fact, matters are a little bit more complicated than this.
349 When we make one of these specialised instances, we are defining
350 a constant dictionary, and so we want immediate access to its constant
351 methods and superclasses. Indeed, these constant methods and superclasses
352 must be in the IdInfo for the class selectors! We need help from the
353 typechecker to sort this out, perhaps by generating a separate IdInfo
356 Automatic instance decl specialisation?
357 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
358 Can instance decls be specialised automatically? It's tricky.
359 We could collect call-instance information for each dfun, but
360 then when we specialised their bodies we'd get new call-instances
361 for ordinary functions; and when we specialised their bodies, we might get
362 new call-instances of the dfuns, and so on. This all arises because of
363 the unrestricted mutual recursion between instance decls and value decls.
365 Furthermore, instance decls are usually exported and used non-locally,
366 so we'll want to compile enough to get those specialisations done.
368 Lastly, there's no such thing as a local instance decl, so we can
369 survive solely by spitting out *usage* information, and then reading that
370 back in as a pragma when next compiling the file. So for now,
371 we only specialise instance decls in response to pragmas.
373 That means that even if an instance decl ain't otherwise exported it
374 needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
375 something to say which module defined the instance, so the usage info
376 can be fed into the right reqts info file. Blegh.
379 SPECIAILISING DATA DECLARATIONS
380 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
382 With unboxed specialisation (or full specialisation) we also require
383 data types (and their constructors) to be speciailised on unboxed
386 In addition to normal call instances we gather TyCon call instances at
387 unboxed types, determine equivalence classes for the locally defined
388 TyCons and build speciailised data constructor Ids for each TyCon and
389 substitute these in the Con calls.
391 We need the list of local TyCons to partition the TyCon instance info.
392 We pass out a FiniteMap from local TyCons to Specialised Instances to
393 give to the interface and code genertors.
395 N.B. The specialised data constructors reference the original data
396 constructor and type constructor which do not have the updated
397 specialisation info attached. Any specialisation info must be
398 extracted from the TyCon map returned.
401 SPITTING OUT USAGE INFORMATION
402 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
404 To spit out usage information we need to traverse the code collecting
405 call-instance information for all imported (non-prelude?) functions
406 and data types. Then we equivalence-class it and spit it out.
408 This is done at the top-level when all the call instances which escape
409 must be for imported functions and data types.
412 Partial specialisation by pragmas
413 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
414 What about partial specialisation:
416 k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
417 {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
421 {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
423 Seems quite reasonable. Similar things could be done with instance decls:
425 instance (Foo a, Foo b) => Foo (a,b) where
427 {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
428 {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
430 Ho hum. Things are complex enough without this. I pass.
433 Requirements for the simplifer
434 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
435 The simplifier has to be able to take advantage of the specialisation.
437 * When the simplifier finds an application of a polymorphic f, it looks in
438 f's IdInfo in case there is a suitable instance to call instead. This converts
440 f t1 t2 d1 d2 ===> f_t1_t2
442 Note that the dictionaries get eaten up too!
444 * Dictionary selection operations on constant dictionaries must be
447 +.sel Int d ===> +Int
449 The obvious way to do this is in the same way as other specialised
450 calls: +.sel has inside it some IdInfo which tells that if it's applied
451 to the type Int then it should eat a dictionary and transform to +Int.
453 In short, dictionary selectors need IdInfo inside them for constant
456 * Exactly the same applies if a superclass dictionary is being
459 Eq.sel Int d ===> dEqInt
461 * Something similar applies to dictionary construction too. Suppose
462 dfun.Eq.List is the function taking a dictionary for (Eq a) to
463 one for (Eq [a]). Then we want
465 dfun.Eq.List Int d ===> dEq.List_Int
467 Where does the Eq [Int] dictionary come from? It is built in
468 response to a SPECIALIZE pragma on the Eq [a] instance decl.
470 In short, dfun Ids need IdInfo with a specialisation for each
471 constant instance of their instance declaration.
474 What does the specialisation IdInfo look like?
475 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
478 [Maybe Type] -- Instance types
479 Int -- No of dicts to eat
480 Id -- Specialised version
482 For example, if f has this SpecInfo:
484 SpecInfo [Just t1, Nothing, Just t3] 2 f'
488 f t1 t2 t3 d1 d2 ===> f t2
490 The "Nothings" identify type arguments in which the specialised
491 version is polymorphic.
493 What can't be done this way?
494 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
495 There is no way, post-typechecker, to get a dictionary for (say)
496 Eq a from a dictionary for Eq [a]. So if we find
500 we can't transform to
505 eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
507 Of course, we currently have no way to automatically derive
508 eqList, nor to connect it to the Eq [a] instance decl, but you
509 can imagine that it might somehow be possible. Taking advantage
510 of this is permanently ruled out.
512 Still, this is no great hardship, because we intend to eliminate
513 overloading altogether anyway!
518 What about types/classes mentioned in SPECIALIZE pragmas spat out,
519 but not otherwise exported. Even if they are exported, what about
520 their original names.
522 Suggestion: use qualified names in pragmas, omitting module for
523 prelude and "this module".
530 f a (d::Num a) = let g = ...
532 ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
534 Here, g is only called at one type, but the dictionary isn't in scope at the
535 definition point for g. Usually the type checker would build a
536 definition for d1 which enclosed g, but the transformation system
537 might have moved d1's defn inward.
543 What should we do when a value is specialised to a *strict* unboxed value?
545 map_*_* f (x:xs) = let h = f x
549 Could convert let to case:
551 map_*_Int# f (x:xs) = case f x of h# ->
555 This may be undesirable since it forces evaluation here, but the value
556 may not be used in all branches of the body. In the general case this
557 transformation is impossible since the mutual recursion in a letrec
558 cannot be expressed as a case.
560 There is also a problem with top-level unboxed values, since our
561 implementation cannot handle unboxed values at the top level.
563 Solution: Lift the binding of the unboxed value and extract it when it
566 map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
571 Now give it to the simplifier and the _Lifting will be optimised away.
573 The benfit is that we have given the specialised "unboxed" values a
574 very simple lifted semantics and then leave it up to the simplifier to
575 optimise it --- knowing that the overheads will be removed in nearly
578 In particular, the value will only be evaluted in the branches of the
579 program which use it, rather than being forced at the point where the
580 value is bound. For example:
582 filtermap_*_* p f (x:xs)
589 filtermap_*_Int# p f (x:xs)
590 = let h = case (f x) of h# -> _Lift h#
593 True -> case h of _Lift h#
597 The binding for h can still be inlined in the one branch and the
601 Question: When won't the _Lifting be eliminated?
603 Answer: When they at the top-level (where it is necessary) or when
604 inlining would duplicate work (or possibly code depending on
605 options). However, the _Lifting will still be eliminated if the
606 strictness analyser deems the lifted binding strict.
610 %************************************************************************
612 \subsubsection[CallInstances]{@CallInstances@ data type}
614 %************************************************************************
617 type FreeVarsSet = UniqSet Id
618 type FreeTyVarsSet = UniqSet TyVar
622 Id -- This Id; *new* ie *cloned* id
623 [Maybe Type] -- Specialised at these types (*new*, cloned)
624 -- Nothing => no specialisation on this type arg
625 -- is required (flag dependent).
626 [CoreArg] -- And these dictionaries; all ValArgs
627 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
628 (Maybe SpecInfo) -- For specialisation with explicit SpecId
632 pprCI :: CallInstance -> Pretty
633 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
634 = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
635 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
636 case maybe_specinfo of
637 Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts])
638 Just (SpecInfo _ _ spec_id)
639 -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
642 isUnboxedCI :: CallInstance -> Bool
643 isUnboxedCI (CallInstance _ spec_tys _ _ _)
644 = any isUnboxedDataType (catMaybes spec_tys)
646 isExplicitCI :: CallInstance -> Bool
647 isExplicitCI (CallInstance _ _ _ _ (Just _))
649 isExplicitCI (CallInstance _ _ _ _ Nothing)
653 Comparisons are based on the {\em types}, ignoring the dictionary args:
657 cmpCI :: CallInstance -> CallInstance -> TAG_
658 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
659 = case (id1 `cmp` id2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
661 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
662 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
663 = cmpUniTypeMaybeList tys1 tys2
665 eqCI_tys :: CallInstance -> CallInstance -> Bool
667 = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
669 isCIofTheseIds :: [Id] -> CallInstance -> Bool
670 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
671 = any (eqId ci_id) ids
673 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
674 singleCI id tys dicts
675 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
676 emptyBag [] emptyUniqSet 0 0
678 fv_set = mkUniqSet (id : [dict | ValArg (VarArg dict) <- dicts])
680 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
681 explicitCI id tys specinfo
682 = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0
684 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
685 dicts = panic "Specialise:explicitCI:dicts"
686 fv_set = singletonUniqSet id
688 -- We do not process the CIs for top-level dfuns or defms
689 -- Instead we require an explicit SPEC inst pragma for dfuns
690 -- and an explict method within any instances for the defms
692 getCIids :: Bool -> [Id] -> [Id]
693 getCIids True ids = filter not_dict_or_defm ids
697 = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
699 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
700 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
702 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
703 cis_here_list = bagToList cis_here
705 -- pprTrace "getCIs:"
706 -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"])
707 -- 4 (ppAboves (map pprCI cis_here_list)))
708 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
710 dumpCIs :: Bag CallInstance -- The call instances
711 -> Bool -- True <=> top level bound Ids
712 -> Bool -- True <=> dict bindings to be floated (specBind only)
713 -> [CallInstance] -- Call insts for bound ids (instBind only)
714 -> [Id] -- Bound ids *new*
715 -> [Id] -- Full bound ids: includes dumped dicts
716 -> Bag CallInstance -- Kept call instances
718 -- CIs are dumped if:
719 -- 1) they are a CI for one of the bound ids, or
720 -- 2) they mention any of the dicts in a local unfloated binding
722 -- For top-level bindings we allow the call instances to
723 -- float past a dict bind and place all the top-level binds
724 -- in a *global* Rec.
725 -- We leave it to the simplifier will sort it all out ...
727 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
728 = (if not (isEmptyBag cis_of_bound_id) &&
729 not (isEmptyBag cis_of_bound_id_without_inst_cis)
731 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
732 " (may be a non-HM recursive call)\n")
733 (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
734 4 (ppAboves [ppStr "Dumping CIs:",
735 ppAboves (map pprCI (bagToList cis_of_bound_id)),
736 ppStr "Instantiating CIs:",
737 ppAboves (map pprCI inst_cis)]))
739 if top_lev || floating then
742 (if not (isEmptyBag cis_dump_unboxed)
743 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
744 (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
745 4 (ppAboves (map pprCI (bagToList cis_dump))))
747 cis_keep_not_bound_id
750 (cis_of_bound_id, cis_not_bound_id)
751 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
753 (cis_dump, cis_keep_not_bound_id)
754 = partitionBag ok_to_dump_ci cis_not_bound_id
756 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
757 = or [i `elementOfUniqSet` fv_set | i <- full_ids]
759 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
760 have_inst_ci ci = any (eqCI_tys ci) inst_cis
762 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
766 Any call instances of a bound_id can be safely dumped, because any
767 recursive calls should be at the same instance as the parent instance.
769 letrec f = /\a -> \x::a -> ...(f t x')...
771 Here, the type, t, at which f is used in its own RHS should be
772 just "a"; that is, the recursive call is at the same type as
773 the original call. That means that when specialising f at some
774 type, say Int#, we shouldn't find any *new* instances of f
775 arising from specialising f's RHS. The only instance we'll find
776 is another call of (f Int#).
778 We check this in dumpCIs by passing in all the instantiated call
779 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
780 for which there is no such instance.
782 We also report CIs dumped due to a bound dictionary arg if they
783 contain unboxed types.
785 %************************************************************************
787 \subsubsection[TyConInstances]{@TyConInstances@ data type}
789 %************************************************************************
793 = TyConInstance TyCon -- Type Constructor
794 [Maybe Type] -- Applied to these specialising types
796 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
797 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
798 = case (cmp tc1 tc2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
800 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
801 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
802 = cmpUniTypeMaybeList tys1 tys2
804 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
805 singleTyConI ty_con spec_tys
806 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0
808 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
809 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con
811 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
812 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
814 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
815 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
817 (tycon_cis_local, tycon_cis_global)
818 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
819 tycon_cis_local_list = bagToList tycon_cis_local
821 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
825 %************************************************************************
827 \subsubsection[UsageDetails]{@UsageDetails@ data type}
829 %************************************************************************
834 (Bag CallInstance) -- The collection of call-instances
835 (Bag TyConInstance) -- Constructor call-instances
836 [DictBindDetails] -- Dictionary bindings in data-dependence order!
837 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
838 Int -- no. of spec calls
839 Int -- no. of spec insts
842 The DictBindDetails are fully processed; their call-instance information is
843 incorporated in the call-instances of the
844 UsageDetails which includes the DictBindDetails. The free vars in a usage details
845 will *include* the binders of the DictBind details.
847 A @DictBindDetails@ contains bindings for dictionaries *only*.
852 [Id] -- Main binders, originally visible in scope of binding (cloned)
853 CoreBinding -- Fully processed
854 FreeVarsSet -- Free in binding group (cloned)
855 FreeTyVarsSet -- Free in binding group
859 emptyUDs :: UsageDetails
860 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
861 unionUDList :: [UsageDetails] -> UsageDetails
863 tickSpecCall :: Bool -> UsageDetails -> UsageDetails
864 tickSpecInsts :: UsageDetails -> UsageDetails
866 tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
867 = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
869 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
870 = UsageDetails cis ty_cis dbs fvs c (i+1)
872 emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet 0 0
874 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
875 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
876 (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
877 -- The append here is really redundant, since the bindings don't
878 -- scope over each other. ToDo.
880 unionUDList = foldr unionUDs emptyUDs
882 singleFvUDs (VarArg v) | not (isImportedId v)
883 = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0
887 singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0
889 dumpDBs :: [DictBindDetails]
890 -> Bool -- True <=> top level bound Ids
891 -> [TyVar] -- TyVars being bound (cloned)
892 -> [Id] -- Ids being bound (cloned)
893 -> FreeVarsSet -- Fvs of body
894 -> ([CoreBinding], -- These ones have to go here
895 [DictBindDetails], -- These can float further
896 [Id], -- Incoming list + names of dicts bound here
897 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
900 -- It is just to complex to try to float top-level
901 -- dict bindings with constant methods, inst methods,
902 -- auxillary derived instance defns and user instance
903 -- defns all getting in the way.
904 -- So we dump all dbinds as soon as we get to the top
905 -- level and place them in a *global* Rec.
906 -- We leave it to the simplifier will sort it all out ...
908 dumpDBs [] top_lev bound_tyvars bound_ids fvs
909 = ([], [], bound_ids, fvs)
911 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
912 top_lev bound_tyvars bound_ids fvs
914 || or [i `elementOfUniqSet` db_fvs | i <- bound_ids]
915 || or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars]
916 = let -- Ha! Dump it!
917 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
918 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs)
920 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
922 | otherwise -- This one can float out further
924 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
925 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
927 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
931 dumpUDs :: UsageDetails
932 -> Bool -- True <=> top level bound Ids
933 -> Bool -- True <=> dict bindings to be floated (specBind only)
934 -> [CallInstance] -- Call insts for bound Ids (instBind only)
935 -> [Id] -- Ids which are just being bound; *new*
936 -> [TyVar] -- TyVars which are just being bound
937 -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
938 UsageDetails) -- The above bindings removed, and
939 -- any call-instances which mention the ids dumped too
941 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
943 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
944 = dumpDBs dbs top_lev tvs bound_ids fvs
945 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
946 fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids)
948 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
952 addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
953 -> UsageDetails -- The usage to augment
955 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
956 (UsageDetails cis tycon_cis dbs fvs c i)
957 = UsageDetails (db_cis `unionBags` cis)
958 (db_tycon_cis `unionBags` tycon_cis)
959 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
961 -- NB: We ignore counts from dictbinds since it is not user code
963 -- The free tyvars of the dictionary bindings should really be
964 -- gotten from the RHSs, but I'm pretty sure it's good enough just
965 -- to look at the type of the dictionary itself.
966 -- Doing the proper job would entail keeping track of free tyvars as
967 -- well as free vars, which would be a bore.
968 db_ftvs = tyVarsOfTypes (map idType dbinders)
971 %************************************************************************
973 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
975 %************************************************************************
977 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
979 1) (NoLift LitArg l) : an Id which is bound to a literal
981 2) (NoLift LitArg l) : an Id bound to a "new" Id
982 The new Id is a possibly-type-specialised clone of the original
984 3) Lifted lifted_id unlifted_id :
986 This indicates that the original Id has been specialised to an
987 unboxed value which must be lifted (see "Unboxed bindings" above)
988 @unlifted_id@ is the unboxed clone of the original Id
989 @lifted_id@ is a *lifted* version of the original Id
991 When you lookup Ids which are Lifted, you have to insert a case
992 expression to un-lift the value (done with @bindUnlift@)
994 You also have to insert a case to lift the value in the binding
995 (done with @liftExpr@)
999 type SpecIdEnv = IdEnv CloneInfo
1002 = NoLift CoreArg -- refers to cloned id or literal
1004 | Lifted Id -- lifted, cloned id
1005 Id -- unlifted, cloned id
1009 %************************************************************************
1011 \subsection[specialise-data]{Data returned by specialiser}
1013 %************************************************************************
1018 -- True <=> Specialisation performed
1020 -- False <=> Specialisation completed with errors
1023 -- Local tycons declared in this module
1026 -- Those in-scope data types for which we want to
1027 -- generate code for their constructors.
1028 -- Namely: data types declared in this module +
1029 -- any big tuples used in this module
1030 -- The initial (and default) value is the local tycons
1032 (FiniteMap TyCon [(Bool, [Maybe Type])])
1033 -- TyCon specialisations to be generated
1034 -- We generate specialialised code (Bool=True) for data types
1035 -- defined in this module and any tuples used in this module
1036 -- The initial (and default) value is the specialisations
1037 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1038 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1040 (Bag (Id,[Maybe Type]))
1041 -- Imported specialisation errors
1042 (Bag (Id,[Maybe Type]))
1043 -- Imported specialisation warnings
1044 (Bag (TyCon,[Maybe Type]))
1045 -- Imported TyCon specialisation errors
1047 initSpecData local_tycons tycon_specs
1048 = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1051 ToDo[sansom]: Transformation data to process specialisation requests.
1053 %************************************************************************
1055 \subsection[specProgram]{Specialising a core program}
1057 %************************************************************************
1060 specProgram :: (GlobalSwitch -> Bool)
1062 -> [CoreBinding] -- input ...
1064 -> ([CoreBinding], -- main result
1065 SpecialiseData) -- result specialise data
1067 specProgram sw_chker uniqs binds
1068 (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1069 = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of
1070 (final_binds, tycon_specs_list,
1071 UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1073 used_conids = filter isDataCon (uniqSetToList fvs)
1074 used_tycons = map getDataConTyCon used_conids
1075 used_gen = filter isLocalGenTyCon used_tycons
1076 gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen)
1078 result_specs = addListToFM_C (++) init_specs tycon_specs_list
1080 uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
1081 cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1082 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1083 cis_warn = init_warn `unionBags` listToBag cis_other
1084 cis_errs = init_errs `unionBags` listToBag cis_unboxed
1086 uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
1087 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1088 tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
1090 no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
1091 && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn)
1093 (if sw_chker D_simplifier_stats then
1094 pprTrace "\nSpecialiser Stats:\n" (ppAboves [
1095 ppBesides [ppStr "SpecCalls ", ppInt spec_calls],
1096 ppBesides [ppStr "SpecInsts ", ppInt spec_insts],
1101 SpecData True no_errs local_tycons gen_tycons result_specs
1102 cis_errs cis_warn tycis_errs)
1104 specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _)
1105 = panic "Specialise:specProgram: specialiser called more than once"
1107 -- It may be possible safely to call the specialiser more than once,
1108 -- but I am not sure there is any benefit in doing so (Patrick)
1110 -- ToDo: What about unfoldings performed after specialisation ???
1113 %************************************************************************
1115 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1117 %************************************************************************
1119 In the specialiser we just collect up the specialisations which will
1120 be required. We don't create the specialised constructors in
1121 Core. These are only introduced when we convert to StgSyn.
1123 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1126 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1127 -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1129 specTyConsAndScope scopeM
1130 = scopeM `thenSM` \ (binds, scope_uds) ->
1131 getSwitchCheckerSM `thenSM` \ sw_chkr ->
1133 (tycons_cis, gotci_scope_uds)
1134 = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
1136 tycon_specs_list = collectTyConSpecs tycons_cis
1138 (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then
1139 pprTrace "Specialising TyCons:\n"
1140 (ppAboves [ if not (null specs) then
1141 ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
1142 4 (ppAboves (map pp_specs specs))
1144 | (tycon, specs) <- tycon_specs_list])
1146 returnSM (binds, tycon_specs_list, gotci_scope_uds)
1149 collectTyConSpecs []
1151 collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1152 = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1154 (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1155 uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1156 tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1158 pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
1162 %************************************************************************
1164 \subsection[specTopBinds]{Specialising top-level bindings}
1166 %************************************************************************
1169 specTopBinds :: [CoreBinding]
1170 -> SpecM ([CoreBinding], UsageDetails)
1173 = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1175 -- Add bindings for floated dbinds and collect fvs
1176 -- In actual fact many of these bindings are dead code since dict
1177 -- arguments are dropped when a specialised call is created
1178 -- The simplifier should be able to cope ...
1180 (dbinders_s, dbinds, dfvs_s)
1181 = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1183 full_fvs = fvs `unionUniqSets` unionManyUniqSets dfvs_s
1184 fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s))
1186 -- It is just to complex to try to sort out top-level dependencies
1187 -- So we just place all the top-level binds in a *global* Rec and
1188 -- leave it to the simplifier to sort it all out ...
1191 returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1194 spec_top_binds (first_bind:rest_binds)
1195 = specBindAndScope True first_bind (
1196 spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1197 returnSM (ItsABinds rest_binds, rest_uds)
1198 ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1199 returnSM (first_binds ++ rest_binds, all_uds)
1202 = returnSM ([], emptyUDs)
1205 %************************************************************************
1207 \subsection[specExpr]{Specialising expressions}
1209 %************************************************************************
1212 specExpr :: CoreExpr
1213 -> [CoreArg] -- The arguments:
1214 -- TypeArgs are speced
1215 -- ValArgs are unprocessed
1216 -> SpecM (CoreExpr, -- Result expression with specialised versions installed
1217 UsageDetails) -- Details of usage of enclosing binders in the result
1220 specExpr (Var v) args
1221 = lookupId v `thenSM` \ vlookup ->
1224 -> -- Binding has been lifted, need to extract un-lifted value
1225 -- NB: a function binding will never be lifted => args always null
1226 -- i.e. no call instance required or call to be constructed
1228 returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl))
1230 NoLift vatom@(VarArg new_v)
1231 -> mapSM specArg args `thenSM` \ arg_info ->
1232 mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
1233 mkCall new_v arg_info `thenSM` \ ~(speced, call) ->
1235 uds = unionUDList [call_uds,
1237 unionUDList [uds | (_,uds,_) <- arg_info]
1240 returnSM (call, tickSpecCall speced uds)
1242 specExpr expr@(Lit _) null_args
1243 = ASSERT (null null_args)
1244 returnSM (expr, emptyUDs)
1246 specExpr (Con con tys args) null_args
1247 = ASSERT (null null_args)
1248 mapSM specTy tys `thenSM` \ tys ->
1249 mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
1250 mkTyConInstance con tys `thenSM` \ con_uds ->
1251 returnSM (applyBindUnlifts unlifts (Con con tys args),
1252 unionUDList args_uds_s `unionUDs` con_uds)
1254 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
1255 = ASSERT (null null_args)
1257 mapSM specTy arg_tys `thenSM` \ arg_tys ->
1258 specTy res_ty `thenSM` \ res_ty ->
1259 mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
1260 returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) tys args),
1261 unionUDList args_uds_s)
1263 specExpr (Prim prim tys args) null_args
1264 = ASSERT (null null_args)
1265 mapSM specTy tys `thenSM` \ tys ->
1266 mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
1267 -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
1268 returnSM (applyBindUnlifts unlifts (Prim prim tys args),
1269 unionUDList args_uds_s {-`unionUDs` prim_uds-} )
1273 specPrimOp :: PrimOp
1279 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1280 -- and/or chooses PrimOp specialised to any unboxed tys
1281 -- Errors are dealt with by returning a PrimOp call instance
1282 -- which will result in a cis_errs message
1284 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1288 specExpr (App fun arg) args
1289 = -- Arg is passed on unprocessed
1290 specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) ->
1291 returnSM (expr, uds)
1293 specExpr (CoTyApp fun ty) args
1294 = -- Spec the tyarg and pass it on
1295 specTy ty `thenSM` \ ty ->
1296 specExpr fun (TypeArg ty : args)
1298 specExpr (Lam binder body) (ValArg arg : args)
1299 = lookup_arg arg `thenSM` \ arg ->
1300 bindId binder arg (specExpr body args)
1302 lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1303 lookup_arg (VarArg v) = lookupId v
1305 specExpr (Lam binder body) []
1306 = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1307 returnSM (Lam binder body, uds)
1309 specExpr (CoTyLam tyvar body) (TypeArg ty : args)
1310 = -- Type lambda with argument; argument already spec'd
1311 bindTyVar tyvar ty (
1315 specExpr (CoTyLam tyvar body) []
1317 cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
1318 bindTyVar tyvar (mkTyVarTy new_tyvar) (
1319 specExpr body [] `thenSM` \ (body, body_uds) ->
1321 (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1323 returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds)
1326 specExpr (Case scrutinee alts) args
1327 = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
1328 specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
1329 returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
1331 scrutinee_type = coreExprType scrutinee
1334 specExpr (Let bind body) args
1335 = specBindAndScope False bind (
1336 specExpr body args `thenSM` \ (body, body_uds) ->
1337 returnSM (ItsAnExpr body, body_uds)
1338 ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1339 returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1341 specExpr (SCC cc expr) args
1342 = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
1343 mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1346 = if squashableDictishCcExpr cc expr -- can toss the _scc_
1350 returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1351 unionUDList args_uds_s `unionUDs` expr_uds)
1353 -- ToDo: This may leave some unspec'd dictionaries!!
1356 %************************************************************************
1358 \subsubsection{Specialising a lambda}
1360 %************************************************************************
1363 specLambdaOrCaseBody :: [Id] -- The binders
1364 -> CoreExpr -- The body
1365 -> [CoreArg] -- Its args
1366 -> SpecM ([Id], -- New binders
1367 CoreExpr, -- New body
1370 specLambdaOrCaseBody bound_ids body args
1371 = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
1372 bindIds bound_ids clone_infos (
1374 specExpr body args `thenSM` \ (body, body_uds) ->
1377 -- Dump any dictionary bindings (and call instances)
1378 -- from the scope which mention things bound here
1379 (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1381 returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1384 -- ToDo: Opportunity here to common-up dictionaries with same type,
1385 -- thus avoiding recomputation.
1388 A variable bound in a lambda or case is normally monomorphic so no
1389 specialised versions will be required. This is just as well since we
1390 do not know what code to specialise!
1392 Unfortunately this is not always the case. For example a class Foo
1393 with polymorphic methods gives rise to a dictionary with polymorphic
1394 components as follows:
1401 instance Foo Int where
1409 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1410 d.Foo.Int = (op1_Int, op2_Int)
1412 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1414 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1417 N.B. The type of the dictionary is not Hindley Milner!
1419 Now we must specialise op1 at {* Int#} which requires a version of
1420 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1421 not have access to its code to create the specialised version.
1424 If we specialise on overloaded types as well we specialise op1 at
1425 {Int Int#} d.Foo.Int:
1427 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1429 Though this is still invalid, after further simplification we get:
1431 op1_Int_Int# = opInt1 {Int#}
1433 Another round of specialisation will result in the specialised
1434 version of op1Int being called directly.
1436 For now we PANIC if a polymorphic lambda/case bound variable is found
1437 in a call instance with an unboxed type. Other call instances, arising
1438 from overloaded type arguments, are discarded since the unspecialised
1439 version extracted from the method can be called as normal.
1441 ToDo: Implement and test second round of specialisation.
1444 %************************************************************************
1446 \subsubsection{Specialising case alternatives}
1448 %************************************************************************
1452 specAlts (AlgAlts alts deflt) scrutinee_ty args
1453 = mapSM specTy ty_args `thenSM` \ ty_args ->
1454 mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
1455 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1456 returnSM (AlgAlts alts deflt,
1457 unionUDList alts_uds_s `unionUDs` deflt_uds)
1460 -- We use ty_args of scrutinee type to identify specialisation of alternatives
1461 (_, ty_args, _) = getAppDataTyCon scrutinee_ty
1463 specAlgAlt ty_args (con,binders,rhs)
1464 = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
1465 mkTyConInstance con ty_args `thenSM` \ con_uds ->
1466 returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1468 specAlts (PrimAlts alts deflt) scrutinee_ty args
1469 = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
1470 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1471 returnSM (PrimAlts alts deflt,
1472 unionUDList alts_uds_s `unionUDs` deflt_uds)
1474 specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
1475 returnSM ((lit,rhs), uds)
1478 specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
1479 specDeflt (BindDefault binder rhs) args
1480 = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
1481 returnSM (BindDefault binder rhs, uds)
1485 %************************************************************************
1487 \subsubsection{Specialising an atom}
1489 %************************************************************************
1492 specAtom :: CoreArg -> SpecM (CoreArg, UsageDetails,
1493 CoreExpr -> CoreExpr)
1495 specAtom (LitArg lit)
1496 = returnSM (LitArg lit, emptyUDs, id)
1499 = lookupId v `thenSM` \ vlookup ->
1502 -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
1505 -> returnSM (vatom, singleFvUDs vatom, id)
1508 specArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
1509 CoreExpr -> CoreExpr)
1511 specArg (ValArg arg) -- unprocessed; spec the atom
1512 = specAtom arg `thenSM` \ (arg, uds, unlift) ->
1513 returnSM (ValArg arg, uds, unlift)
1515 specArg (TypeArg ty) -- already speced; no action
1516 = returnSM (TypeArg ty, emptyUDs, id)
1520 %************************************************************************
1522 \subsubsection{Specialising bindings}
1524 %************************************************************************
1526 A classic case of when having a polymorphic recursive function would help!
1529 data BindsOrExpr = ItsABinds [CoreBinding]
1530 | ItsAnExpr CoreExpr
1535 :: Bool -- True <=> a top level group
1536 -> CoreBinding -- As yet unprocessed
1537 -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
1538 -> SpecM ([CoreBinding], -- Processed
1539 BindsOrExpr, -- Combined result
1540 UsageDetails) -- Usage details of the whole lot
1542 specBindAndScope top_lev bind scopeM
1543 = cloneLetBinders top_lev (is_rec bind) binders
1544 `thenSM` \ (new_binders, clone_infos) ->
1546 -- Two cases now: either this is a bunch of local dictionaries,
1547 -- in which case we float them; or its a bunch of other values,
1548 -- in which case we see if they correspond to any call-instances
1549 -- we have from processing the scope
1551 if not top_lev && all (isDictTy . idType) binders
1553 -- Ha! A group of local dictionary bindings
1555 bindIds binders clone_infos (
1557 -- Process the dictionary bindings themselves
1558 specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
1560 -- Process their scope
1561 scopeM `thenSM` \ (thing, scope_uds) ->
1563 -- Add the bindings to the current stuff
1564 final_uds = addDictBinds new_binders bind rhs_uds scope_uds
1566 returnSM ([], thing, final_uds)
1569 -- Ho! A group of bindings
1571 fixSM (\ ~(_, _, _, rec_spec_infos) ->
1573 bindSpecIds binders clone_infos rec_spec_infos (
1574 -- It's ok to have new binders in scope in
1575 -- non-recursive decls too, cos name shadowing is gone by now
1577 -- Do the scope of the bindings
1578 scopeM `thenSM` \ (thing, scope_uds) ->
1580 (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
1582 equiv_ciss = equivClasses cmpCI_tys call_insts
1583 inst_cis = map head equiv_ciss
1586 -- Do the bindings themselves
1587 specBind top_lev False new_binders inst_cis bind
1588 `thenSM` \ (spec_bind, spec_uds) ->
1590 -- Create any necessary instances
1591 instBind top_lev new_binders bind equiv_ciss inst_cis
1592 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
1595 -- NB: dumpUDs only worries about new_binders since the free var
1596 -- stuff only records free new_binders
1597 -- The spec_ids only appear in SpecInfos and final speced calls
1599 -- Build final binding group and usage details
1600 (final_binds, final_uds)
1602 -- For a top-level binding we have to dumpUDs from
1603 -- spec_uds and inst_uds and scope_uds creating
1604 -- *global* dict bindings
1606 (scope_dict_binds, final_scope_uds)
1607 = dumpUDs gotci_scope_uds True False [] new_binders []
1608 (spec_dict_binds, final_spec_uds)
1609 = dumpUDs spec_uds True False inst_cis new_binders []
1610 (inst_dict_binds, final_inst_uds)
1611 = dumpUDs inst_uds True False inst_cis new_binders []
1613 ([spec_bind] ++ inst_binds ++ scope_dict_binds
1614 ++ spec_dict_binds ++ inst_dict_binds,
1615 final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
1617 -- For a local binding we only have to dumpUDs from
1618 -- scope_uds since the UDs from spec_uds and inst_uds
1619 -- have already been dumped by specBind and instBind
1621 (scope_dict_binds, final_scope_uds)
1622 = dumpUDs gotci_scope_uds False False [] new_binders []
1624 ([spec_bind] ++ inst_binds ++ scope_dict_binds,
1625 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
1627 -- inst_uds comes last, because there may be dict bindings
1628 -- floating outward in scope_uds which are mentioned
1629 -- in the call-instances, and hence in spec_uds.
1630 -- This ordering makes sure that the precedence order
1631 -- among the dict bindings finally floated out is maintained.
1633 returnSM (final_binds, thing, final_uds, spec_infos)
1635 ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
1636 returnSM (binds, thing, final_uds)
1638 binders = bindersOf bind
1640 is_rec (NonRec _ _) = False
1645 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
1647 -> SpecM (CoreBinding, UsageDetails)
1648 -- The UsageDetails returned has already had stuff to do with this group
1649 -- of binders deleted; that's why new_binders is passed in.
1650 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
1651 = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
1652 `thenSM` \ ((binder,rhs), rhs_uds) ->
1653 returnSM (NonRec binder rhs, rhs_uds)
1655 specBind top_lev floating new_binders inst_cis (Rec pairs)
1656 = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
1657 `thenSM` \ (pairs, rhs_uds_s) ->
1658 returnSM (Rec pairs, unionUDList rhs_uds_s)
1661 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
1663 -> SpecM ((Id,CoreExpr), UsageDetails)
1665 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
1666 = lookupId binder `thenSM` \ blookup ->
1667 specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
1669 specid_maybe_maybe = isSpecPragmaId_maybe binder
1670 is_specid = maybeToBool specid_maybe_maybe
1671 Just specinfo_maybe = specid_maybe_maybe
1672 specid_with_info = maybeToBool specinfo_maybe
1673 Just spec_info = specinfo_maybe
1675 -- If we have a SpecInfo stored in a SpecPragmaId binder
1676 -- it will contain a SpecInfo with an explicit SpecId
1677 -- We add the explicit ci to the usage details
1678 -- Any ordinary cis for orig_id (there should only be one)
1679 -- will be ignored later
1682 = if is_specid && specid_with_info then
1684 (SpecInfo spec_tys _ spec_id) = spec_info
1685 Just (orig_id, _) = isSpecId_maybe spec_id
1687 ASSERT(toplevelishId orig_id) -- must not be cloned!
1688 explicitCI orig_id spec_tys spec_info
1692 -- For a local binding we dump the usage details, creating
1693 -- any local dict bindings required
1694 -- At the top-level the uds will be dumped in specBindAndScope
1695 -- and the dict bindings made *global*
1697 (local_dict_binds, final_uds)
1698 = if not top_lev then
1699 dumpUDs rhs_uds False floating inst_cis new_binders []
1704 Lifted lift_binder unlift_binder
1705 -> -- We may need to record an unboxed instance of
1706 -- the _Lift data type in the usage details
1707 mkTyConInstance liftDataCon [idType unlift_binder]
1708 `thenSM` \ lift_uds ->
1709 returnSM ((lift_binder,
1710 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
1711 final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
1713 NoLift (VarArg binder)
1714 -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
1715 final_uds `unionUDs` pragma_uds)
1719 %************************************************************************
1721 \subsection{@instBind@}
1723 %************************************************************************
1726 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
1728 = returnSM ([], emptyUDs, [])
1730 | all same_overloading other_binders
1731 = -- For each call_inst, build an instance
1732 mapAndUnzip3SM do_this_class equiv_ciss
1733 `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
1735 -- Add in the remaining UDs
1736 returnSM (catMaybes inst_binds,
1737 unionUDList inst_uds_s,
1741 | otherwise -- Incompatible overloadings; see below by same_overloading
1742 = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
1743 then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
1745 then pprTrace "dumpCIs: not same overloading ... top level \n"
1747 ) (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
1748 4 (ppAboves [ppAboves (map (pprType PprDebug . idType) new_ids),
1749 ppAboves (map pprCI (concat equiv_ciss))]))
1750 (returnSM ([], emptyUDs, []))
1753 (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
1754 tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls
1756 no_of_tyvars = length tyvar_tmpls
1757 no_of_dicts = length class_tyvar_pairs
1759 do_this_class equiv_cis
1760 = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
1762 (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
1763 do_cis = head (normal_cis ++ explicit_cis)
1764 -- must choose a normal_cis in preference since dict_args will
1765 -- not be defined for an explicit_cis
1767 -- same_overloading tests whether the types of all the binders
1768 -- are "compatible"; ie have the same type and dictionary abstractions
1769 -- Almost always this is the case, because a recursive group is abstracted
1770 -- all together. But, it can happen that it ain't the case, because of
1771 -- code generated from instance decls:
1774 -- dfun.Foo.Int :: (forall a. a -> Int, Int)
1775 -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
1777 -- const.op1.Int :: forall a. a -> Int
1778 -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
1780 -- const.op2.Int :: Int
1781 -- const.op2.Int = 3
1783 -- Note that the first two defns have different polymorphism, but they are
1784 -- mutually recursive!
1786 same_overloading :: Id -> Bool
1788 = no_of_tyvars == length this_id_tyvars
1789 -- Same no of tyvars
1790 && no_of_dicts == length this_id_class_tyvar_pairs
1791 -- Same no of vdicts
1792 && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
1793 && length class_tyvar_pairs == length this_id_class_tyvar_pairs
1796 (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
1797 tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
1799 same_ov (clas1,tyvar1) (clas2,tyvar2)
1801 tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
1805 - a call instance eg f [t1,t2,t3] [d1,d2]
1806 - the rhs of the function eg orig_rhs
1807 - a constraint vector, saying which of eg [T,F,T]
1808 the functions type args are constrained
1811 We return a new definition
1813 f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2
1815 The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
1817 SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
1819 Based on this SpecInfo, a call instance of f
1821 ...(f t1 t2 t3 d1 d2)...
1823 should get replaced by
1827 (But that is the business of @mkCall@.)
1830 mkOneInst :: CallInstance
1831 -> [CallInstance] -- Any explicit cis for this inst
1832 -> Int -- No of dicts to specialise
1833 -> Bool -- Top level binders?
1834 -> [CallInstance] -- Instantiated call insts for binders
1835 -> [Id] -- New binders
1836 -> CoreBinding -- Unprocessed
1837 -> SpecM (Maybe CoreBinding, -- Instantiated version of input
1839 [Maybe SpecInfo] -- One for each id in the original binding
1842 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
1843 no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
1844 = getSwitchCheckerSM `thenSM` \ sw_chkr ->
1845 newSpecIds new_ids spec_tys no_of_dicts_to_specialise
1846 `thenSM` \ spec_ids ->
1847 newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
1849 -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
1850 -- which correspond to unspeciailsed args
1852 (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
1855 args = map TypeArg arg_tys ++ dict_args
1857 (new_id:_) = new_ids
1858 (spec_id:_) = spec_ids
1860 do_bind (NonRec orig_id rhs)
1861 = do_one_rhs (spec_id, new_id, (orig_id,rhs))
1862 `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
1864 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
1865 Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
1868 = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
1869 `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
1870 returnSM (Just (Rec (catMaybes maybe_pairs)),
1871 unionUDList rhss_uds_s, spec_infos)
1873 do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
1875 -- Avoid duplicating a spec which has already been created ...
1876 -- This can arise in a Rec involving a dfun for which a
1877 -- a specialised instance has been created but specialisation
1878 -- "required" by one of the other Ids in the Rec
1879 | top_lev && maybeToBool lookup_orig_spec
1880 = (if sw_chkr SpecialiseTrace
1881 then trace_nospec " Exists: " exists_id
1884 returnSM (Nothing, emptyUDs, Nothing)
1887 -- Check for a (single) explicit call instance for this id
1888 | not (null explicit_cis_for_this_id)
1889 = ASSERT (length explicit_cis_for_this_id == 1)
1890 (if sw_chkr SpecialiseTrace
1891 then trace_nospec " Explicit: " explicit_id
1894 returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
1897 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
1899 = ASSERT (no_of_dicts_to_specialise == length dict_args)
1900 specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
1902 -- For a local binding we dump the usage details, creating
1903 -- any local dict bindings required
1904 -- At the top-level the uds will be dumped in specBindAndScope
1905 -- and the dict bindings made *global*
1907 (local_dict_binds, final_uds)
1908 = if not top_lev then
1909 dumpUDs inst_uds False False inst_cis new_ids []
1913 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
1915 if isUnboxedDataType (idType spec_id) then
1916 ASSERT (null poly_tyvars)
1917 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
1918 mkTyConInstance liftDataCon [idType unlift_spec_id]
1919 `thenSM` \ lift_uds ->
1920 returnSM (Just (lift_spec_id,
1921 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
1922 tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
1924 returnSM (Just (spec_id,
1925 mkCoLetsNoUnboxed local_dict_binds (mkCoTyLam poly_tyvars inst_rhs)),
1926 tickSpecInsts final_uds, spec_info)
1928 lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
1929 Just (exists_id, _, _) = lookup_orig_spec
1931 explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
1932 [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
1933 SpecInfo _ _ explicit_id = explicit_spec_info
1935 trace_nospec str spec_id
1937 (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys),
1938 ppStr "==>", ppr PprDebug spec_id])
1940 (if sw_chkr SpecialiseTrace then
1941 pprTrace "Specialising:"
1942 (ppHang (ppBesides [ppStr "{", ppr PprDebug new_ids, ppStr "}"])
1944 ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
1945 if isExplicitCI do_cis then ppNil else
1946 ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
1947 ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
1950 do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
1952 returnSM (maybe_inst_bind, inst_uds, spec_infos)
1955 pp_dict (ValArg d) = ppr PprDebug d
1956 pp_ty t = pprParendType PprDebug t
1958 do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
1959 do_the_wotsit tyvars (Just ty) = (tyvars, ty)
1963 %************************************************************************
1965 \subsection[Misc]{Miscellaneous junk}
1967 %************************************************************************
1970 mkCallInstance :: Id
1972 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
1973 -> SpecM UsageDetails
1975 mkCallInstance id new_id []
1978 mkCallInstance id new_id args
1980 -- No specialised versions for "error" and friends are req'd.
1981 -- This is a special case in core lint etc.
1986 -- No call instances for SuperDictSelIds
1987 -- These are a special case in mkCall
1989 | maybeToBool (isSuperDictSelId_maybe id)
1992 -- There are also no call instances for ClassOpIds
1993 -- However, we need to process it to get any second-level call
1994 -- instances for a ConstMethodId extracted from its SpecEnv
1997 = getSwitchCheckerSM `thenSM` \ sw_chkr ->
1999 spec_overloading = sw_chkr SpecialiseOverloaded
2000 spec_unboxed = sw_chkr SpecialiseUnboxed
2001 spec_all = sw_chkr SpecialiseAll
2003 (tyvars, class_tyvar_pairs) = getIdOverloading id
2005 arg_res = take_type_args tyvars class_tyvar_pairs args
2006 enough_args = maybeToBool arg_res
2008 (Just (tys, dicts, rest_args)) = arg_res
2011 = (record, lookup, spec_tys)
2013 spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
2014 (mkConstraintVector id) tys
2016 record = any (not . isTyVarTy) (catMaybes spec_tys)
2018 lookup = lookupSpecEnv (getIdSpecialisation id) tys
2020 if (not enough_args) then
2021 pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
2022 (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
2024 case record_spec id tys of
2026 -> -- pprTrace "CallInst:NotReqd\n"
2027 -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
2030 (True, Nothing, spec_tys)
2031 -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
2034 -- pprTrace "CallInst:Reqd\n"
2035 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2036 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
2037 -- ppCat (map (ppr PprDebug) dicts)]])
2038 (returnSM (singleCI new_id spec_tys dicts))
2040 (True, Just (spec_id, tys_left, toss), _)
2041 -> if maybeToBool (isConstMethodId_maybe spec_id) then
2042 -- If we got a const method spec_id see if further spec required
2043 -- NB: const method is top-level so spec_id will not be cloned
2044 case record_spec spec_id tys_left of
2046 -> -- pprTrace "CallInst:Exists\n"
2047 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2048 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2049 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2052 (True, Nothing, spec_tys)
2053 -> -- pprTrace "CallInst:Exists:Reqd\n"
2054 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2055 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2056 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2057 -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
2058 -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
2059 (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
2061 (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
2062 -> -- pprTrace "CallInst:Exists:Exists\n"
2063 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2064 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2065 -- ppr PprDebug (tys_left ++ drop toss dicts)],
2066 -- ppCat [ppStr "->", ppr PprDebug spec_spec_id,
2067 -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
2071 -- pprTrace "CallInst:Exists\n"
2072 -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
2073 -- ppCat [ppStr "->", ppr PprDebug spec_id,
2074 -- ppr PprDebug (tys_left ++ drop toss dicts)]])
2078 take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
2079 = case take_type_args tyvars class_tyvar_pairs args of
2081 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2082 take_type_args (_:tyvars) class_tyvar_pairs []
2084 take_type_args [] class_tyvar_pairs args
2085 = case take_dict_args class_tyvar_pairs args of
2087 Just (dicts, others) -> Just ([], dicts, others)
2089 take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
2090 = case take_dict_args class_tyvar_pairs args of
2092 Just (dicts, others) -> Just (dict:dicts, others)
2093 take_dict_args (_:class_tyvar_pairs) []
2095 take_dict_args [] args
2101 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2102 -> SpecM (Bool, CoreExpr)
2105 | maybeToBool (isSuperDictSelId_maybe new_id)
2106 && any isUnboxedDataType ty_args
2107 -- No specialisations for super-dict selectors
2108 -- Specialise unboxed calls to SuperDictSelIds by extracting
2109 -- the super class dictionary directly form the super class
2110 -- NB: This should be dead code since all uses of this dictionary should
2111 -- have been specialised. We only do this to keep core-lint happy.
2113 Just (_, super_class) = isSuperDictSelId_maybe new_id
2114 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2115 Nothing -> panic "Specialise:mkCall:SuperDictId"
2118 returnSM (False, Var super_dict_id)
2121 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2122 Nothing -> checkUnspecOK new_id ty_args (
2123 returnSM (False, unspec_call)
2126 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2128 -- It may be necessary to specialsie a constant method spec_id again
2129 (spec_id, tys_left, dicts_to_toss) =
2130 case (maybeToBool (isConstMethodId_maybe spec_id_1),
2131 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2132 (False, _ ) -> spec_1_details
2133 (True, Nothing) -> spec_1_details
2134 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2135 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2137 args_left = toss_dicts dicts_to_toss val_args
2139 checkSpecOK new_id ty_args spec_id tys_left (
2141 -- The resulting spec_id may be a top-level unboxed value
2142 -- This can arise for:
2143 -- 1) constant method values
2144 -- eq: class Num a where pi :: a
2145 -- instance Num Double# where pi = 3.141#
2146 -- 2) specilised overloaded values
2147 -- eq: i1 :: Num a => a
2148 -- i1 Int# d.Num.Int# ==> i1.Int#
2149 -- These top level defns should have been lifted.
2150 -- We must add code to unlift such a spec_id.
2152 if isUnboxedDataType (idType spec_id) then
2153 ASSERT (null tys_left && null args_left)
2154 if toplevelishId spec_id then
2155 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2156 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2157 (Var unlift_spec_id))
2159 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2160 (ppCat [ppr PprDebug new_id,
2161 ppInterleave ppNil (map (pprParendType PprDebug) ty_args),
2163 ppr PprDebug spec_id])
2166 (vals_left, _, unlifts_left) = unzip3 args_left
2167 applied_tys = mkCoTyApps (Var spec_id) tys_left
2168 applied_vals = mkGenApp applied_tys vals_left
2170 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2173 (tys_and_vals, _, unlifts) = unzip3 args
2174 unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2177 -- ty_args is the types at the front of the arg list
2178 -- val_args is the rest of the arg-list
2180 (ty_args, val_args) = get args
2182 get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2183 get args = ([], args)
2186 -- toss_dicts chucks away dict args, checking that they ain't types!
2187 toss_dicts 0 args = args
2188 toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args
2193 checkUnspecOK :: Id -> [Type] -> a -> a
2194 checkUnspecOK check_id tys
2195 = if isLocallyDefined check_id && any isUnboxedDataType tys
2196 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2197 (ppCat [ppr PprDebug check_id,
2198 ppInterleave ppNil (map (pprParendType PprDebug) tys)])
2201 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2202 checkSpecOK check_id tys spec_id tys_left
2203 = if any isUnboxedDataType tys_left
2204 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2205 (ppAboves [ppCat [ppr PprDebug check_id,
2206 ppInterleave ppNil (map (pprParendType PprDebug) tys)],
2207 ppCat [ppr PprDebug spec_id,
2208 ppInterleave ppNil (map (pprParendType PprDebug) tys_left)]])
2213 mkTyConInstance :: Id
2215 -> SpecM UsageDetails
2216 mkTyConInstance con tys
2217 = recordTyConInst con tys `thenSM` \ record_inst ->
2219 Nothing -- No TyCon instance
2220 -> -- pprTrace "NoTyConInst:"
2221 -- (ppCat [ppr PprDebug tycon, ppStr "at",
2222 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
2223 (returnSM (singleConUDs con))
2225 Just spec_tys -- Record TyCon instance
2226 -> -- pprTrace "TyConInst:"
2227 -- (ppCat [ppr PprDebug tycon, ppStr "at",
2228 -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
2229 -- ppBesides [ppStr "(",
2230 -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
2232 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2234 tycon = getDataConTyCon con
2238 recordTyConInst :: Id
2240 -> SpecM (Maybe [Maybe Type])
2242 recordTyConInst con tys
2244 spec_tys = specialiseConstrTys tys
2246 do_tycon_spec = maybeToBool (firstJust spec_tys)
2248 spec_exists = maybeToBool (lookupSpecEnv
2249 (getIdSpecialisation con)
2252 -- pprTrace "ConSpecExists?: "
2253 -- (ppAboves [ppStr (if spec_exists then "True" else "False"),
2254 -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
2255 (if (not spec_exists && do_tycon_spec)
2256 then returnSM (Just spec_tys)
2257 else returnSM Nothing)
2260 %************************************************************************
2262 \subsection[monad-Specialise]{Monad used in specialisation}
2264 %************************************************************************
2268 inherited: control flags and
2269 recordInst functions with flags cached
2271 environment mapping tyvars to types
2272 environment mapping Ids to Atoms
2274 threaded in and out: unique supply
2278 = (GlobalSwitch -> Bool)
2284 initSM m sw_chker uniqs
2285 = m sw_chker nullTyVarEnv nullIdEnv uniqs
2287 returnSM :: a -> SpecM a
2288 thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
2289 fixSM :: (a -> SpecM a) -> SpecM a
2291 thenSM m k sw_chkr tvenv idenv us
2292 = case splitUniqSupply us of { (s1, s2) ->
2293 case (m sw_chkr tvenv idenv s1) of { r ->
2294 k r sw_chkr tvenv idenv s2 }}
2296 returnSM r sw_chkr tvenv idenv us = r
2298 fixSM k sw_chkr tvenv idenv us
2301 r = k r sw_chkr tvenv idenv us -- Recursive in r!
2305 getSwitchCheckerSM sw_chkr tvenv idenv us = sw_chkr
2308 The only interesting bit is figuring out the type of the SpecId!
2311 newSpecIds :: [Id] -- The id of which to make a specialised version
2312 -> [Maybe Type] -- Specialise to these types
2313 -> Int -- No of dicts to specialise
2316 newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us
2317 = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2318 | (id,uniq) <- new_ids `zip` uniqs ]
2320 uniqs = getUniques (length new_ids) us
2321 spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2323 newTyVars :: Int -> SpecM [TyVar]
2324 newTyVars n sw_chkr tvenv idenv us
2325 = map mkPolySysTyVar uniqs
2327 uniqs = getUniques n us
2330 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2331 binders, and build ``clones'' for them. The clones differ from the
2332 originals in three ways:
2334 (a) they have a fresh unique
2335 (b) they have the current type environment applied to their type
2336 (c) for Let binders which have been specialised to unboxed values
2337 the clone will have a lifted type
2339 As well as returning the list of cloned @Id@s they also return a list of
2340 @CloneInfo@s which the original binders should be bound to.
2343 cloneLambdaOrCaseBinders :: [Id] -- Old binders
2344 -> SpecM ([Id], [CloneInfo]) -- New ones
2346 cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us
2348 uniqs = getUniques (length old_ids) us
2350 unzip (zipWithEqual clone_it old_ids uniqs)
2352 clone_it old_id uniq
2353 = (new_id, NoLift (VarArg new_id))
2355 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2357 cloneLetBinders :: Bool -- Top level ?
2358 -> Bool -- Recursice
2359 -> [Id] -- Old binders
2360 -> SpecM ([Id], [CloneInfo]) -- New ones
2362 cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us
2364 uniqs = getUniques (2 * length old_ids) us
2366 unzip (clone_them old_ids uniqs)
2368 clone_them [] [] = []
2370 clone_them (old_id:olds) (u1:u2:uniqs)
2373 NoLift (VarArg old_id)) : clone_rest
2375 -- Don't clone if it is a top-level thing. Why not?
2376 -- (a) we don't want to change the uniques
2377 -- on such things (see TopLevId in Id.lhs)
2378 -- (b) we don't have to be paranoid about name capture
2379 -- (c) the thing is polymorphic so no need to subst
2382 = if (is_rec && isUnboxedDataType new_ty && not (isUnboxedDataType old_ty))
2384 Lifted lifted_id unlifted_id) : clone_rest
2386 NoLift (VarArg new_id)) : clone_rest
2389 clone_rest = clone_them olds uniqs
2391 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2392 new_ty = idType new_id
2393 old_ty = idType old_id
2395 (lifted_id, unlifted_id) = mkLiftedId new_id u2
2398 cloneTyVarSM :: TyVar -> SpecM TyVar
2400 cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
2404 cloneTyVar old_tyvar uniq -- new_tyvar
2406 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2408 bindId id val specm sw_chkr tvenv idenv us
2409 = specm sw_chkr tvenv (addOneToIdEnv idenv id val) us
2411 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2413 bindIds olds news specm sw_chkr tvenv idenv us
2414 = specm sw_chkr tvenv (growIdEnvList idenv (zip olds news)) us
2416 bindSpecIds :: [Id] -- Old
2417 -> [(CloneInfo)] -- New
2418 -> [[Maybe SpecInfo]] -- Corresponding specialisations
2419 -- Each sub-list corresponds to a different type,
2420 -- and contains one Maybe spec_info for each id
2424 bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
2425 = specm sw_chkr tvenv (growIdEnvList idenv old_to_clone) us
2427 old_to_clone = mk_old_to_clone olds clones spec_infos
2429 -- The important thing here is that we are *lazy* in spec_infos
2430 mk_old_to_clone [] [] _ = []
2431 mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2432 = (old, add_spec_info clone) :
2433 mk_old_to_clone rest_olds rest_clones spec_infos_rest
2435 add_spec_info (NoLift (VarArg new))
2436 = NoLift (VarArg (new `addIdSpecialisation`
2437 (mkSpecEnv spec_infos_this_id)))
2438 add_spec_info lifted
2439 = lifted -- no specialised instances for unboxed lifted values
2441 spec_infos_this_id = catMaybes (map head spec_infos)
2442 spec_infos_rest = map tail spec_infos
2445 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2447 bindTyVar tyvar ty specm sw_chkr tvenv idenv us
2448 = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2452 lookupId :: Id -> SpecM CloneInfo
2454 lookupId id sw_chkr tvenv idenv us
2455 = case lookupIdEnv idenv id of
2456 Nothing -> NoLift (VarArg id)
2461 specTy :: Type -> SpecM Type -- Apply the current type envt to the type
2463 specTy ty sw_chkr tvenv idenv us
2464 = applyTypeEnvToTy tvenv ty
2468 liftId :: Id -> SpecM (Id, Id)
2469 liftId id sw_chkr tvenv idenv us
2476 In other monads these @mapSM@ things are usually called @listM@.
2477 I think @mapSM@ is a much better name. The `2' and `3' variants are
2478 when you want to return two or three results, and get at them
2479 separately. It saves you having to do an (unzip stuff) right after.
2482 mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
2483 mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
2484 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2485 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2487 mapSM f [] = returnSM []
2488 mapSM f (x:xs) = f x `thenSM` \ r ->
2489 mapSM f xs `thenSM` \ rs ->
2492 mapAndUnzipSM f [] = returnSM ([],[])
2493 mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
2494 mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
2495 returnSM ((r1:rs1),(r2:rs2))
2497 mapAndUnzip3SM f [] = returnSM ([],[],[])
2498 mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
2499 mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
2500 returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2502 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2503 mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
2504 mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
2505 returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
projects / ghc-hetmet.git / blob