2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
14 #include "HsVersions.h"
16 import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
17 partitionBag, listToBag, bagToList, Bag
19 import Class ( Class )
20 import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
23 import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
25 import CoreUtils ( coreExprType, squashableDictishCcExpr )
26 import FiniteMap ( addListToFM_C, FiniteMap )
27 import Kind ( mkBoxedTypeKind, isBoxedTypeKind )
28 import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
31 isImportedId, mkIdWithNewUniq,
32 dataConTyCon, applyTypeEnvToId,
33 nullIdEnv, addOneToIdEnv, growIdEnvList,
35 emptyIdSet, mkIdSet, unitIdSet,
36 elementOfIdSet, minusIdSet,
37 unionIdSets, unionManyIdSets, IdSet,
38 GenId{-instance Eq-}, Id
40 import Literal ( Literal{-instance Outputable-} )
41 import Maybes ( catMaybes, firstJust, maybeToBool )
42 import Name ( isLocallyDefined )
43 import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
44 GenType{-instance Outputable-}, GenTyVar{-ditto-},
47 import PrimOp ( PrimOp(..) )
49 import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp,
50 tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy,
53 import TyCon ( TyCon{-instance Eq-} )
54 import TyVar ( cloneTyVar, mkSysTyVar,
55 elementOfTyVarSet, TyVarSet,
56 emptyTyVarEnv, growTyVarEnvList, TyVarEnv,
57 GenTyVar{-instance Eq-}
59 import TysWiredIn ( liftDataCon )
60 import Unique ( Unique{-instance Eq-} )
61 import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
62 import UniqSupply ( splitUniqSupply, getUniques, getUnique )
63 import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
66 import List ( partition )
71 specProgram = panic "SpecProgram"
74 data SpecInfo = SpecInfo [Maybe Type] Int Id
78 lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
79 addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
80 cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
81 getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
82 isClassOpId = panic "Specialise.isClassOpId (ToDo)"
83 isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
84 isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
85 isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
86 isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
87 lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
88 mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
89 mkSpecId = panic "Specialise.mkSpecId (ToDo)"
90 selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
91 specialiseTy = panic "Specialise.specialiseTy (ToDo)"
94 %************************************************************************
96 \subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
98 %************************************************************************
100 These notes describe how we implement specialisation to eliminate
101 overloading, and optionally to eliminate unboxed polymorphism, and
104 The specialisation pass is a partial evaluator which works on Core
105 syntax, complete with all the explicit dictionary application,
106 abstraction and construction as added by the type checker. The
107 existing type checker remains largely as it is.
109 One important thought: the {\em types} passed to an overloaded
110 function, and the {\em dictionaries} passed are mutually redundant.
111 If the same function is applied to the same type(s) then it is sure to
112 be applied to the same dictionary(s)---or rather to the same {\em
113 values}. (The arguments might look different but they will evaluate
116 Second important thought: we know that we can make progress by
117 treating dictionary arguments as static and worth specialising on. So
118 we can do without binding-time analysis, and instead specialise on
119 dictionary arguments and no others.
128 and suppose f is overloaded.
130 STEP 1: CALL-INSTANCE COLLECTION
132 We traverse <body>, accumulating all applications of f to types and
135 (Might there be partial applications, to just some of its types and
136 dictionaries? In principle yes, but in practice the type checker only
137 builds applications of f to all its types and dictionaries, so partial
138 applications could only arise as a result of transformation, and even
139 then I think it's unlikely. In any case, we simply don't accumulate such
140 partial applications.)
142 There's a choice of whether to collect details of all *polymorphic* functions
143 or simply all *overloaded* ones. How to sort this out?
144 Pass in a predicate on the function to say if it is "interesting"?
145 This is dependent on the user flags: SpecialiseOverloaded
151 So now we have a collection of calls to f:
155 Notice that f may take several type arguments. To avoid ambiguity, we
156 say that f is called at type t1/t2 and t3/t4.
158 We take equivalence classes using equality of the *types* (ignoring
159 the dictionary args, which as mentioned previously are redundant).
161 STEP 3: SPECIALISATION
163 For each equivalence class, choose a representative (f t1 t2 d1 d2),
164 and create a local instance of f, defined thus:
166 f@t1/t2 = <f_rhs> t1 t2 d1 d2
168 (f_rhs presumably has some big lambdas and dictionary lambdas, so lots
169 of simplification will now result.) Then we should recursively do
172 The new id has its own unique, but its print-name (if exported) has
173 an explicit representation of the instance types t1/t2.
175 Add this new id to f's IdInfo, to record that f has a specialised version.
177 Before doing any of this, check that f's IdInfo doesn't already
178 tell us about an existing instance of f at the required type/s.
179 (This might happen if specialisation was applied more than once, or
180 it might arise from user SPECIALIZE pragmas.)
184 Wait a minute! What if f is recursive? Then we can't just plug in
185 its right-hand side, can we?
187 But it's ok. The type checker *always* creates non-recursive definitions
188 for overloaded recursive functions. For example:
190 f x = f (x+x) -- Yes I know its silly
194 f a (d::Num a) = let p = +.sel a d
196 letrec fl (y::a) = fl (p y y)
200 We still have recusion for non-overloadd functions which we
201 speciailise, but the recursive call should get speciailised to the
202 same recursive version.
208 All this is crystal clear when the function is applied to *constant
209 types*; that is, types which have no type variables inside. But what if
210 it is applied to non-constant types? Suppose we find a call of f at type
211 t1/t2. There are two possibilities:
213 (a) The free type variables of t1, t2 are in scope at the definition point
214 of f. In this case there's no problem, we proceed just as before. A common
215 example is as follows. Here's the Haskell:
220 After typechecking we have
222 g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
223 in +.sel a d (f a d y) (f a d y)
225 Notice that the call to f is at type type "a"; a non-constant type.
226 Both calls to f are at the same type, so we can specialise to give:
228 g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
229 in +.sel a d (f@a y) (f@a y)
232 (b) The other case is when the type variables in the instance types
233 are *not* in scope at the definition point of f. The example we are
234 working with above is a good case. There are two instances of (+.sel a d),
235 but "a" is not in scope at the definition of +.sel. Can we do anything?
236 Yes, we can "common them up", a sort of limited common sub-expression deal.
239 g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
240 f@a (x::a) = +.sel@a x x
241 in +.sel@a (f@a y) (f@a y)
243 This can save work, and can't be spotted by the type checker, because
244 the two instances of +.sel weren't originally at the same type.
248 * There are quite a few variations here. For example, the defn of
249 +.sel could be floated ouside the \y, to attempt to gain laziness.
250 It certainly mustn't be floated outside the \d because the d has to
253 * We don't want to inline f_rhs in this case, because
254 that will duplicate code. Just commoning up the call is the point.
256 * Nothing gets added to +.sel's IdInfo.
258 * Don't bother unless the equivalence class has more than one item!
260 Not clear whether this is all worth it. It is of course OK to
261 simply discard call-instances when passing a big lambda.
263 Polymorphism 2 -- Overloading
265 Consider a function whose most general type is
267 f :: forall a b. Ord a => [a] -> b -> b
269 There is really no point in making a version of g at Int/Int and another
270 at Int/Bool, because it's only instancing the type variable "a" which
271 buys us any efficiency. Since g is completely polymorphic in b there
272 ain't much point in making separate versions of g for the different
275 That suggests that we should identify which of g's type variables
276 are constrained (like "a") and which are unconstrained (like "b").
277 Then when taking equivalence classes in STEP 2, we ignore the type args
278 corresponding to unconstrained type variable. In STEP 3 we make
279 polymorphic versions. Thus:
281 f@t1/ = /\b -> <f_rhs> t1 b d1 d2
283 This seems pretty simple, and a Good Thing.
285 Polymorphism 3 -- Unboxed
288 If we are speciailising at unboxed types we must speciailise
289 regardless of the overloading constraint. In the exaple above it is
290 worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
293 Note that specialising an overloaded type at an uboxed type requires
294 an unboxed instance -- we cannot default to an unspecialised version!
301 f x = let g p q = p==q
307 Before specialisation, leaving out type abstractions we have
309 f df x = let g :: Eq a => a -> a -> Bool
311 h :: Num a => a -> a -> (a, Bool)
312 h dh r s = let deq = eqFromNum dh
313 in (+ dh r s, g deq r s)
317 After specialising h we get a specialised version of h, like this:
319 h' r s = let deq = eqFromNum df
320 in (+ df r s, g deq r s)
322 But we can't naively make an instance for g from this, because deq is not in scope
323 at the defn of g. Instead, we have to float out the (new) defn of deq
324 to widen its scope. Notice that this floating can't be done in advance -- it only
325 shows up when specialisation is done.
327 DELICATE MATTER: the way we tell a dictionary binding is by looking to
328 see if it has a Dict type. If the type has been "undictify'd", so that
329 it looks like a tuple, then the dictionary binding won't be floated, and
330 an opportunity to specialise might be lost.
332 User SPECIALIZE pragmas
333 ~~~~~~~~~~~~~~~~~~~~~~~
334 Specialisation pragmas can be digested by the type checker, and implemented
335 by adding extra definitions along with that of f, in the same way as before
337 f@t1/t2 = <f_rhs> t1 t2 d1 d2
339 Indeed the pragmas *have* to be dealt with by the type checker, because
340 only it knows how to build the dictionaries d1 and d2! For example
342 g :: Ord a => [a] -> [a]
343 {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
345 Here, the specialised version of g is an application of g's rhs to the
346 Ord dictionary for (Tree Int), which only the type checker can conjure
347 up. There might not even *be* one, if (Tree Int) is not an instance of
348 Ord! (All the other specialision has suitable dictionaries to hand
351 Problem. The type checker doesn't have to hand a convenient <f_rhs>, because
352 it is buried in a complex (as-yet-un-desugared) binding group.
355 f@t1/t2 = f* t1 t2 d1 d2
357 where f* is the Id f with an IdInfo which says "inline me regardless!".
358 Indeed all the specialisation could be done in this way.
359 That in turn means that the simplifier has to be prepared to inline absolutely
360 any in-scope let-bound thing.
363 Again, the pragma should permit polymorphism in unconstrained variables:
365 h :: Ord a => [a] -> b -> b
366 {-# SPECIALIZE h :: [Int] -> b -> b #-}
368 We *insist* that all overloaded type variables are specialised to ground types,
369 (and hence there can be no context inside a SPECIALIZE pragma).
370 We *permit* unconstrained type variables to be specialised to
372 - or left as a polymorphic type variable
373 but nothing in between. So
375 {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
377 is *illegal*. (It can be handled, but it adds complication, and gains the
381 SPECIALISING INSTANCE DECLARATIONS
382 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
385 instance Foo a => Foo [a] where
387 {-# SPECIALIZE instance Foo [Int] #-}
389 The original instance decl creates a dictionary-function
392 dfun.Foo.List :: forall a. Foo a -> Foo [a]
394 The SPECIALIZE pragma just makes a specialised copy, just as for
395 ordinary function definitions:
397 dfun.Foo.List@Int :: Foo [Int]
398 dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
400 The information about what instance of the dfun exist gets added to
401 the dfun's IdInfo in the same way as a user-defined function too.
403 In fact, matters are a little bit more complicated than this.
404 When we make one of these specialised instances, we are defining
405 a constant dictionary, and so we want immediate access to its constant
406 methods and superclasses. Indeed, these constant methods and superclasses
407 must be in the IdInfo for the class selectors! We need help from the
408 typechecker to sort this out, perhaps by generating a separate IdInfo
411 Automatic instance decl specialisation?
412 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
413 Can instance decls be specialised automatically? It's tricky.
414 We could collect call-instance information for each dfun, but
415 then when we specialised their bodies we'd get new call-instances
416 for ordinary functions; and when we specialised their bodies, we might get
417 new call-instances of the dfuns, and so on. This all arises because of
418 the unrestricted mutual recursion between instance decls and value decls.
420 Furthermore, instance decls are usually exported and used non-locally,
421 so we'll want to compile enough to get those specialisations done.
423 Lastly, there's no such thing as a local instance decl, so we can
424 survive solely by spitting out *usage* information, and then reading that
425 back in as a pragma when next compiling the file. So for now,
426 we only specialise instance decls in response to pragmas.
428 That means that even if an instance decl ain't otherwise exported it
429 needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
430 something to say which module defined the instance, so the usage info
431 can be fed into the right reqts info file. Blegh.
434 SPECIAILISING DATA DECLARATIONS
435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
437 With unboxed specialisation (or full specialisation) we also require
438 data types (and their constructors) to be speciailised on unboxed
441 In addition to normal call instances we gather TyCon call instances at
442 unboxed types, determine equivalence classes for the locally defined
443 TyCons and build speciailised data constructor Ids for each TyCon and
444 substitute these in the Con calls.
446 We need the list of local TyCons to partition the TyCon instance info.
447 We pass out a FiniteMap from local TyCons to Specialised Instances to
448 give to the interface and code genertors.
450 N.B. The specialised data constructors reference the original data
451 constructor and type constructor which do not have the updated
452 specialisation info attached. Any specialisation info must be
453 extracted from the TyCon map returned.
456 SPITTING OUT USAGE INFORMATION
457 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
459 To spit out usage information we need to traverse the code collecting
460 call-instance information for all imported (non-prelude?) functions
461 and data types. Then we equivalence-class it and spit it out.
463 This is done at the top-level when all the call instances which escape
464 must be for imported functions and data types.
467 Partial specialisation by pragmas
468 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
469 What about partial specialisation:
471 k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
472 {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
476 {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
478 Seems quite reasonable. Similar things could be done with instance decls:
480 instance (Foo a, Foo b) => Foo (a,b) where
482 {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
483 {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
485 Ho hum. Things are complex enough without this. I pass.
488 Requirements for the simplifer
489 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
490 The simplifier has to be able to take advantage of the specialisation.
492 * When the simplifier finds an application of a polymorphic f, it looks in
493 f's IdInfo in case there is a suitable instance to call instead. This converts
495 f t1 t2 d1 d2 ===> f_t1_t2
497 Note that the dictionaries get eaten up too!
499 * Dictionary selection operations on constant dictionaries must be
502 +.sel Int d ===> +Int
504 The obvious way to do this is in the same way as other specialised
505 calls: +.sel has inside it some IdInfo which tells that if it's applied
506 to the type Int then it should eat a dictionary and transform to +Int.
508 In short, dictionary selectors need IdInfo inside them for constant
511 * Exactly the same applies if a superclass dictionary is being
514 Eq.sel Int d ===> dEqInt
516 * Something similar applies to dictionary construction too. Suppose
517 dfun.Eq.List is the function taking a dictionary for (Eq a) to
518 one for (Eq [a]). Then we want
520 dfun.Eq.List Int d ===> dEq.List_Int
522 Where does the Eq [Int] dictionary come from? It is built in
523 response to a SPECIALIZE pragma on the Eq [a] instance decl.
525 In short, dfun Ids need IdInfo with a specialisation for each
526 constant instance of their instance declaration.
529 What does the specialisation IdInfo look like?
530 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
533 [Maybe Type] -- Instance types
534 Int -- No of dicts to eat
535 Id -- Specialised version
537 For example, if f has this SpecInfo:
539 SpecInfo [Just t1, Nothing, Just t3] 2 f'
543 f t1 t2 t3 d1 d2 ===> f t2
545 The "Nothings" identify type arguments in which the specialised
546 version is polymorphic.
548 What can't be done this way?
549 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
550 There is no way, post-typechecker, to get a dictionary for (say)
551 Eq a from a dictionary for Eq [a]. So if we find
555 we can't transform to
560 eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
562 Of course, we currently have no way to automatically derive
563 eqList, nor to connect it to the Eq [a] instance decl, but you
564 can imagine that it might somehow be possible. Taking advantage
565 of this is permanently ruled out.
567 Still, this is no great hardship, because we intend to eliminate
568 overloading altogether anyway!
573 What about types/classes mentioned in SPECIALIZE pragmas spat out,
574 but not otherwise exported. Even if they are exported, what about
575 their original names.
577 Suggestion: use qualified names in pragmas, omitting module for
578 prelude and "this module".
585 f a (d::Num a) = let g = ...
587 ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
589 Here, g is only called at one type, but the dictionary isn't in scope at the
590 definition point for g. Usually the type checker would build a
591 definition for d1 which enclosed g, but the transformation system
592 might have moved d1's defn inward.
598 What should we do when a value is specialised to a *strict* unboxed value?
600 map_*_* f (x:xs) = let h = f x
604 Could convert let to case:
606 map_*_Int# f (x:xs) = case f x of h# ->
610 This may be undesirable since it forces evaluation here, but the value
611 may not be used in all branches of the body. In the general case this
612 transformation is impossible since the mutual recursion in a letrec
613 cannot be expressed as a case.
615 There is also a problem with top-level unboxed values, since our
616 implementation cannot handle unboxed values at the top level.
618 Solution: Lift the binding of the unboxed value and extract it when it
621 map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
626 Now give it to the simplifier and the _Lifting will be optimised away.
628 The benfit is that we have given the specialised "unboxed" values a
629 very simplep lifted semantics and then leave it up to the simplifier to
630 optimise it --- knowing that the overheads will be removed in nearly
633 In particular, the value will only be evaluted in the branches of the
634 program which use it, rather than being forced at the point where the
635 value is bound. For example:
637 filtermap_*_* p f (x:xs)
644 filtermap_*_Int# p f (x:xs)
645 = let h = case (f x) of h# -> _Lift h#
648 True -> case h of _Lift h#
652 The binding for h can still be inlined in the one branch and the
656 Question: When won't the _Lifting be eliminated?
658 Answer: When they at the top-level (where it is necessary) or when
659 inlining would duplicate work (or possibly code depending on
660 options). However, the _Lifting will still be eliminated if the
661 strictness analyser deems the lifted binding strict.
664 A note about non-tyvar dictionaries
665 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
666 Some Ids have types like
668 forall a,b,c. Eq a -> Ord [a] -> tau
670 This seems curious at first, because we usually only have dictionary
671 args whose types are of the form (C a) where a is a type variable.
672 But this doesn't hold for the functions arising from instance decls,
673 which sometimes get arguements with types of form (C (T a)) for some
676 Should we specialise wrt this compound-type dictionary? We used to say
678 "This is a heuristic judgement, as indeed is the fact that we
679 specialise wrt only dictionaries. We choose *not* to specialise
680 wrt compound dictionaries because at the moment the only place
681 they show up is in instance decls, where they are simply plugged
682 into a returned dictionary. So nothing is gained by specialising
685 But it is simpler and more uniform to specialise wrt these dicts too;
686 and in future GHC is likely to support full fledged type signatures
688 f ;: Eq [(a,b)] => ...
691 %************************************************************************
693 \subsubsection{The new specialiser}
695 %************************************************************************
697 Our basic game plan is this. For let(rec) bound function
698 f :: (C a, D c) => (a,b,c,d) -> Bool
700 * Find any specialised calls of f, (f ts ds), where
701 ts are the type arguments t1 .. t4, and
702 ds are the dictionary arguments d1 .. d2.
704 * Add a new definition for f1 (say):
706 f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
708 Note that we abstract over the unconstrained type arguments.
712 [t1,b,t3,d] |-> \d1 d2 -> f1 b d
714 to the specialisations of f. This will be used by the
715 simplifier to replace calls
716 (f t1 t2 t3 t4) da db
718 (\d1 d1 -> f1 t2 t4) da db
720 All the stuff about how many dictionaries to discard, and what types
721 to apply the specialised function to, are handled by the fact that the
722 SpecEnv contains a template for the result of the specialisation.
724 We don't build *partial* specialisations for f. For example:
726 f :: Eq a => a -> a -> Bool
727 {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
729 Here, little is gained by making a specialised copy of f.
730 There's a distinct danger that the specialised version would
731 first build a dictionary for (Eq b, Eq c), and then select the (==)
732 method from it! Even if it didn't, not a great deal is saved.
734 We do, however, generate polymorphic, but not overloaded, specialisations:
736 f :: Eq a => [a] -> b -> b -> b
737 {#- SPECIALISE f :: [Int] -> b -> b -> b #-}
739 Hence, the invariant is this:
741 *** no specialised version is overloaded ***
745 specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
747 ---------------- First the easy cases --------------------
748 specExpr e@(Var _) = returnSM (e, emptyUDs)
749 specExpr e@(Lit _) = returnSM (e, emptyUDs)
750 specExpr e@(Con _ _) = returnSM (e, emptyUDs)
751 specExpr e@(Prim _ _) = returnSM (e, emptyUDs)
753 specExpr (Coerce co ty body)
754 = specExpr body `thenSM` \ (body', uds) ->
755 returnSM (Coerce co ty body')
757 specExpr (SCC cc body)
758 = specExpr body `thenSM` \ (body', uds) ->
759 returnSM (SCC cc body')
762 ---------------- Applications might generate a call instance --------------------
763 specExpr e@(App fun arg)
766 go (App fun arg) args = go fun (arg:args)
767 go (Var f) args = returnSM (e, mkCallUDs f args)
768 go other args = specExpr other `thenSM` \ (e', uds) ->
769 returnSM (foldl App e' args, uds)
771 ---------------- Lambda/case require dumping of usage details --------------------
773 = specExpr body `thenSM` \ (body', uds) ->
775 (filtered_uds, body'') = dumpUDs bndrs uds body'
777 returnSM (Lam bndr body'', filtered_uds)
779 (bndrs, body) = go [] e
781 -- More efficient to collect a group of binders together all at once
782 go bndrs (Lam bndr e) = go (bndr:bndrs) e
783 go bndrs e = (reverse bndrs, e)
786 specExpr (Case scrut alts)
787 = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
788 spec_alts alts `thenSM` \ (alts', uds_alts) ->
789 returnSM (Case scrut' alts', uds_scrut `plusUDs` uds_alts)
791 spec_alts (AlgAlts alts deflt)
792 = mapAndCombineSM spec_alg_alt alts `thenSM` \ (alts', uds1) ->
793 spec_deflt deflt `thenSM` \ (deflt', uds2) ->
794 returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2)
796 spec_alts (PrimAlts alts deflt)
797 = mapAndCombineSM spec_prim_alt alts `thenSM` \ (alts', uds1) ->
798 spec_deflt deflt `thenSM` \ (deflt', uds2) ->
799 returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2)
801 spec_alg_alt (con, args, rhs)
802 = specExpr rhs `thenSM` \ (rhs', uds) ->
804 (uds', rhs'') = dumpUDs (map ValBinder args) uds rhs'
806 returnSM ((con, args, rhs''), uds')
808 spec_prim_alt (lit, rhs)
809 = specExpr rhs `thenSM` \ (rhs', uds) ->
810 returnSM ((lit, rhs'), uds)
812 spec_deflt NoDefault = (NoDefault, emptyUDs)
813 spec_deflt (BindDefault arg rhs)
814 = specExpr rhs `thenSM` \ (rhs', uds) ->
816 (uds', rhs'') = dumpManyUDs [ValBinder arg] uds rhs'
818 returnSM (BindDefault arg rhs'', uds')
820 ---------------- Finally, let is the interesting case --------------------
821 specExpr (Let (NonRec bndr rhs) body)
822 = -- Deal with the body
823 specExpr body `thenSM` \ (body', body_uds) ->
825 -- Deal with the RHS, specialising it according
826 -- to the calls found in the body
827 specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
830 all_uds = deleteCalls (rhs_uds `plusUDs` body_uds) bndr'
832 if bndr `elementOfIdSet` free_dicts body_uds then
833 -- This is a dictionary binding; we must pick it up
834 -- and float it outwards.
835 ASSERT( null spec_defns )
836 returnSM (body', addDictBind all_uds bndr' rhs')
838 else if isSpecPragmaId bndr then
839 -- SpecPragmaIds are there solely to generate specialisations
840 -- Just drop the whole binding
841 ASSERT( null spec_defns )
842 returnSM (body', all_uds)
845 -- An ordinary binding, so glue it all together
847 Let (NonRec bndr' rhs') (mkLets spec_defns body'),
851 specDefn :: CallDetails -- Info on how it is used in its scope
852 -> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
853 -> SpecM ((Id, CoreExpr), -- The thing and its processed RHS
854 -- the Id may now have specialisations attached
855 [(Id, CoreExpr)], -- Extra, specialised bindings
856 UsageDetails -- Stuff to fling upwards from the RHS and its
857 ) -- specialised versions
859 specDefn calls (fn, rhs)
860 -- The first case is the interesting one
861 | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
862 && n_dicts <= length rhs_bndrs -- and enough dict args
863 && not (null calls_for_me) -- And there are some calls to specialise
864 = -- Specialise the body of the function
865 specExpr body `thenSM` \ (body', body_uds) ->
867 -- Make a specialised version for each call in calls_for_me
868 mapSM (spec_call body_uds) calls_for_me `thenSM` \ stuff ->
870 (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
872 (rhs_uds, body'') = dumpUDs rhs_bndrs body_uds body'
873 rhs' = foldr Lam bndrs body''
875 fn' = addIdSpecialisations fn spec_env_stuff
877 returnSM ((fn',rhs'),
879 rhs_uds `plusUDs` plusUDList spec_uds)
881 | otherwise -- No calls or RHS doesn't fit our preconceptions
882 = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
883 returnSM ((fn, rhs'), [], rhs_uds)
886 (tyvars, theta, tau) = splitSigmaTy (idType fn)
887 n_tyvars = length tyvars
888 n_dicts = length theta
890 (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
891 rhs_dicts = take n_dicts rhs_ids
892 rhs_bndrs = map TyBinder rhs_tyvars ++ map ValBinder rhs_dicts
893 body = mkValLam (drop n_dicts rhs_ids) rhs_body
894 -- Glue back on the non-dict lambdas
896 calls_for_me = case lookupFM calls fn of
898 Just cs -> fmToList cs
901 -- Specialise to one particular call pattern
902 spec_call :: UsageDetails -- From the original body
903 -> ([Maybe Type], [DictVar]) -- Call instance
904 -> ((Id, CoreExpr), -- Specialised definition
905 UsageDetails, -- Usage details from specialised body
906 ([Type], CoreExpr)) -- Info for the Id's SpecEnv
907 spec_call body_uds (call_ts, call_ds)
908 = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
909 -- Calls are only recorded for properly-saturated applications
911 -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [d1, d2]
913 -- Construct the new binding
914 -- f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
915 -- and the type of this binder
917 spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_tys]
918 spec_tys = zipWith mk_spec_ty call_ts tyvars
919 spec_rhs = mkTyLam spec_tyvars $
920 mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
921 spec_id_ty = mkForAllTys spec_tyvars (applyTys (idType f) spec_tys)
923 mk_spec_ty (Just ty) _ = ty
924 mk_spec_ty Nothing tyvar = mkTyVarTy tyvar
926 newIdSM f spec_id_ty `thenSM` \ spec_f ->
929 -- Construct the stuff for f's spec env
930 -- [t1,b,t3,d] |-> \d1 d2 -> f1 b d
932 spec_env_rhs = mkValLam call_ds $
933 mkTyApp (Var spec_f) $
934 map mkTyVarTy spec_tyvars
935 spec_env_info = (spec_tys, spec_env_rhs)
938 -- Specialise the UDs from f's RHS
939 specUDs (zipEqual rhs_tyvars call_ts)
940 (zipEqual rhs_dicts call_ds)
941 body_uds `thenSM` \ spec_uds ->
943 returnSM ((spec_f, spec_rhs),
949 %************************************************************************
951 \subsubsection{UsageDetails and suchlike}
953 %************************************************************************
956 type FreeDicts = IdSet
960 free_dicts :: !FreeDicts, -- Dicts free in any of the calls or dict binds
962 dict_binds :: !Bag (DictVar, CoreExpr, FreeDicts),
963 -- Floated dictionary bindings
964 -- The order is important;
965 -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
966 -- (Remember, Bags preserve order in GHC.)
967 -- The FreeDicts is the free vars of the RHS
969 calls :: !CallDetails
972 type CallMap = FiniteMap Id CallInfo
973 type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
974 [DictVar] -- Dict args
975 -- The finite maps eliminate duplicates
976 -- The list of types and dictionaries is guaranteed to
977 -- match the type of f
980 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
981 plusUDs (MkUD {fvs = fvs1, dictBinds = db1, calls = calls1})
982 (MkUD {fvs = fvs2, dictBinds = db2, calls = calls2})
983 = MkUD {fvs, dictBinds, calls}
985 fvs = fvs1 `unionIdSets` fvs2
986 dictBinds = db1 `unionBags` db2
987 calls = calls1 `unionBags` calls2
990 tyVarsOfUDs (MkUD {fvs}) = tyVarsOfTypes (map idType (idSetToList fvs))
992 deleteCalls uds bndr = uds { calls = delFromFM (calls uds) bndr }
994 addDictBind uds dict rhs = uds { free_dicts = addToIdSet (free_dicts uds) dict,
995 dict_binds = (dict, rhs, f
997 dumpUDs :: [CoreBinder]
998 -> UsageDetails -> CoreExpr
999 -> (UsageDetails, CoreExpr)
1001 dumpUDs bndrs uds@(MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls}) body
1002 = ASSERT( isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs))
1003 -- The tyvars shouldn't be free in any of the usage details
1004 -- If it was, then we should have found a dictionary lambda first
1006 if isEmptyIdSet (id_set `intersectIdSets` fvs) then
1007 -- Common case: binder doesn't affect floats
1011 -- Binders bind some of the fvs of the floats
1012 (MkUDs {fvs = filtered_fvs,
1013 dictBinds = filtered_dbs,
1014 calls = filtered_calls},
1015 foldrBag mk_dict_bind body dump_dbs)
1018 tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs]
1019 id_list = [id | ValBinder id <- bndrs]
1020 id_set = mkIdSet id_list
1021 ftvs = tyVarsOfUDs uds
1022 filtered_fvs = orig_fvs `minusIdSet` id_set
1024 (filtered_dbs, dump_dbs, dump_idset)
1025 = foldlBag dump (emptyBag, emptyBag, id_set) orig_dbs
1026 -- Important that it's foldl not foldr;
1027 -- we're accumulating the set of dumped ids in dump_set
1029 -- Filter out any calls that mention things that are being dumped
1030 -- It's a bit tiresome because of the two-level finite map
1031 filtered_calls = mapFM del (foldr delFromFM orig_calls id_list)
1032 del _ dicts = filter (not (`elementOfIdSet` dump_id_set)) dicts
1034 dump (ok_dbs, dump_dbs, dump_idset) db@(dict, rhs, fvs)
1035 | isEmptyIdSet (dump_idset `intersectIdSets` fvs)
1036 = (ok_dbs `snocBag` db, dump_dbs, dump_idset)
1038 | otherwise -- Dump it
1039 = (ok_dbs, dump_dbs `snocBag` db, idEmptyIdSet (dump_idset `intersectIdSets` fvs)
1041 mk_dict_bind (dict, rhs, _) body = Let (NonRec dict rhs) body
1044 Given a type and value substitution, specUDs creates a specialised copy of
1048 specUDs tv_assoc id_assoc (MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls})
1049 = mapAccumLSM spec_bind
1051 (bagToList orig_dbs) `thenSM` \ ((tv_env', id_env'), new_dbs) ->
1053 subst_call call_info = listToFM [(map (instantiateTy ty_env') ts,
1054 map (lookupId id_env') call_ds)
1055 | (call_ts, call_ds) <- fmToList call_info
1058 MkUDs { fvs = substFVSet id_env orig_fvs,
1059 dictBinds = listToBag new_dbs,
1060 calls = mapFM orig_calls subst_call
1063 tv_env = mkTyVarEnv tv_assoc
1064 id_env = mkIdEnv id_assoc
1066 spec_bind (ty_env, id_env) (dict, rhs, fvs)
1067 = newIdSM dict spec_ty `thenSM` \ spec_dict ->
1068 returnSM ((ty_env, addOneToIdEnv id_env dict spec_dict), (spec_dict, spec_rhs))
1070 spec_ty = instantiateTy ty_env (idType dict)
1071 spec_rhs = instantiateDictRhs ty_env id_env rhs
1075 %************************************************************************
1077 \subsubsection{Boring helper functions}
1079 %************************************************************************
1082 substFVSet :: IdEnv Id -> IdSet -> IdSet
1083 substFVSet env s = mkIdSet [lookupId env id | id <- idSetToList s]
1085 lookupId:: IdEnv Id -> Id -> Id
1086 lookupId env id = case lookupIdEnv env id of
1090 instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
1091 -- Cheapo function for simple RHSs
1092 instantiateDictRhs ty_env id_env rhs
1095 go (App e1 (ValArg a)) = App (go e1) (ValArg (lookupId id_env a))
1096 go (App e1 (TyArg t)) = App (go e1) (TyArg (instantiateTy ty_env t))
1097 go (Var v) = Var (lookupId id_env v)
1100 dictRhsFVs :: CoreExpr -> IdSet
1101 -- Cheapo function for simple RHSs
1102 dictRhsFVs (App e1 (ValArg a)) = dictRhsFVs e1 `addOneToIdSet` a
1103 go (App e1 (TyArg t)) = dictRhsFVs e1
1104 go (Var v) = singletonIdSet v
1105 go (Lit l) = emptyIdSet
1107 mkLets [] body = body
1108 mkLets ((bndr,rhs):binds) body = Let (NonRec bndr rhs) (mkLets binds body)
1110 zipNothings [] [] = []
1111 zipNothings (Nothing : tys) (tyvar : tyvars) = mkTyVarTy tyvar : zipNothings tys tyvars
1112 zipNothings (Just ty : tys) tyvars = ty : zipNothings tys tyvars
1116 =========================== OLD STUFF =================================
1118 %************************************************************************
1120 \subsubsection[CallInstances]{@CallInstances@ data type}
1122 %************************************************************************
1125 type FreeVarsSet = IdSet
1126 type FreeTyVarsSet = TyVarSet
1130 Id -- This Id; *new* ie *cloned* id
1131 [Maybe Type] -- Specialised at these types (*new*, cloned)
1132 -- Nothing => no specialisation on this type arg
1133 -- is required (flag dependent).
1134 [CoreArg] -- And these dictionaries; all ValArgs
1135 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
1136 (Maybe SpecInfo) -- For specialisation with explicit SpecId
1140 pprCI :: CallInstance -> Doc
1141 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
1142 = hang (hsep [ptext SLIT("Call inst for"), ppr id])
1143 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]),
1144 case maybe_specinfo of
1145 Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts])
1146 Just (SpecInfo _ _ spec_id)
1147 -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id]
1150 -- ToDo: instance Outputable CoreArg?
1151 ppr_arg (TyArg t) = ppr sty t
1152 ppr_arg (LitArg i) = ppr sty i
1153 ppr_arg (VarArg v) = ppr sty v
1155 isUnboxedCI :: CallInstance -> Bool
1156 isUnboxedCI (CallInstance _ spec_tys _ _ _)
1157 = any isUnboxedType (catMaybes spec_tys)
1159 isExplicitCI :: CallInstance -> Bool
1160 isExplicitCI (CallInstance _ _ _ _ (Just _))
1162 isExplicitCI (CallInstance _ _ _ _ Nothing)
1166 Comparisons are based on the {\em types}, ignoring the dictionary args:
1170 cmpCI :: CallInstance -> CallInstance -> Ordering
1171 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
1172 = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
1174 cmpCI_tys :: CallInstance -> CallInstance -> Ordering
1175 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
1176 = cmpUniTypeMaybeList tys1 tys2
1178 eqCI_tys :: CallInstance -> CallInstance -> Bool
1180 = case cmpCI_tys c1 c2 of { EQ -> True; other -> False }
1182 isCIofTheseIds :: [Id] -> CallInstance -> Bool
1183 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
1184 = any ((==) ci_id) ids
1186 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
1187 singleCI id tys dicts
1188 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
1189 emptyBag [] emptyIdSet 0 0
1191 fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
1193 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
1194 explicitCI id tys specinfo
1195 = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
1197 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
1198 dicts = panic "Specialise:explicitCI:dicts"
1199 fv_set = unitIdSet id
1201 -- We do not process the CIs for top-level dfuns or defms
1202 -- Instead we require an explicit SPEC inst pragma for dfuns
1203 -- and an explict method within any instances for the defms
1205 getCIids :: Bool -> [Id] -> [Id]
1206 getCIids True ids = filter not_dict_or_defm ids
1207 getCIids _ ids = ids
1210 = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
1212 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
1213 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
1215 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
1216 cis_here_list = bagToList cis_here
1218 -- pprTrace "getCIs:"
1219 -- (hang (hcat [char '{',
1222 -- 4 (vcat (map pprCI cis_here_list)))
1223 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
1225 dumpCIs :: Bag CallInstance -- The call instances
1226 -> Bool -- True <=> top level bound Ids
1227 -> Bool -- True <=> dict bindings to be floated (specBind only)
1228 -> [CallInstance] -- Call insts for bound ids (instBind only)
1229 -> [Id] -- Bound ids *new*
1230 -> [Id] -- Full bound ids: includes dumped dicts
1231 -> Bag CallInstance -- Kept call instances
1233 -- CIs are dumped if:
1234 -- 1) they are a CI for one of the bound ids, or
1235 -- 2) they mention any of the dicts in a local unfloated binding
1237 -- For top-level bindings we allow the call instances to
1238 -- float past a dict bind and place all the top-level binds
1239 -- in a *global* Rec.
1240 -- We leave it to the simplifier will sort it all out ...
1242 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
1243 = (if not (isEmptyBag cis_of_bound_id) &&
1244 not (isEmptyBag cis_of_bound_id_without_inst_cis)
1246 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
1247 " (may be a non-HM recursive call)\n")
1248 (hang (hcat [char '{',
1249 interppSP bound_ids,
1251 4 (vcat [ptext SLIT("Dumping CIs:"),
1252 vcat (map pprCI (bagToList cis_of_bound_id)),
1253 ptext SLIT("Instantiating CIs:"),
1254 vcat (map pprCI inst_cis)]))
1256 if top_lev || floating then
1259 (if not (isEmptyBag cis_dump_unboxed)
1260 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
1261 (hang (hcat [char '{',
1264 4 (vcat (map pprCI (bagToList cis_dump))))
1266 cis_keep_not_bound_id
1269 (cis_of_bound_id, cis_not_bound_id)
1270 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
1272 (cis_dump, cis_keep_not_bound_id)
1273 = partitionBag ok_to_dump_ci cis_not_bound_id
1275 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
1276 = any (\ i -> i `elementOfIdSet` fv_set) full_ids
1278 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
1279 have_inst_ci ci = any (eqCI_tys ci) inst_cis
1281 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
1285 Any call instances of a bound_id can be safely dumped, because any
1286 recursive calls should be at the same instance as the parent instance.
1288 letrec f = /\a -> \x::a -> ...(f t x')...
1290 Here, the type, t, at which f is used in its own RHS should be
1291 just "a"; that is, the recursive call is at the same type as
1292 the original call. That means that when specialising f at some
1293 type, say Int#, we shouldn't find any *new* instances of f
1294 arising from specialising f's RHS. The only instance we'll find
1295 is another call of (f Int#).
1297 We check this in dumpCIs by passing in all the instantiated call
1298 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
1299 for which there is no such instance.
1301 We also report CIs dumped due to a bound dictionary arg if they
1302 contain unboxed types.
1304 %************************************************************************
1306 \subsubsection[TyConInstances]{@TyConInstances@ data type}
1308 %************************************************************************
1312 = TyConInstance TyCon -- Type Constructor
1313 [Maybe Type] -- Applied to these specialising types
1315 cmpTyConI :: TyConInstance -> TyConInstance -> Ordering
1316 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
1317 = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
1319 cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering
1320 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
1321 = cmpUniTypeMaybeList tys1 tys2
1323 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
1324 singleTyConI ty_con spec_tys
1325 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
1327 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
1328 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
1330 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
1331 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
1333 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
1334 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
1336 (tycon_cis_local, tycon_cis_global)
1337 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
1338 tycon_cis_local_list = bagToList tycon_cis_local
1340 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
1344 %************************************************************************
1346 \subsubsection[UsageDetails]{@UsageDetails@ data type}
1348 %************************************************************************
1353 (Bag CallInstance) -- The collection of call-instances
1354 (Bag TyConInstance) -- Constructor call-instances
1355 [DictBindDetails] -- Dictionary bindings in data-dependence order!
1356 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
1357 Int -- no. of spec calls
1358 Int -- no. of spec insts
1361 The DictBindDetails are fully processed; their call-instance
1362 information is incorporated in the call-instances of the UsageDetails
1363 which includes the DictBindDetails. The free vars in a usage details
1364 will *include* the binders of the DictBind details.
1366 A @DictBindDetails@ contains bindings for dictionaries *only*.
1369 data DictBindDetails
1371 [Id] -- Main binders, originally visible in scope of binding (cloned)
1372 CoreBinding -- Fully processed
1373 FreeVarsSet -- Free in binding group (cloned)
1374 FreeTyVarsSet -- Free in binding group
1378 emptyUDs :: UsageDetails
1379 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
1380 unionUDList :: [UsageDetails] -> UsageDetails
1382 -- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
1383 tickSpecInsts :: UsageDetails -> UsageDetails
1385 -- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
1386 -- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
1388 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
1389 = UsageDetails cis ty_cis dbs fvs c (i+1)
1391 emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
1393 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
1394 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
1395 (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
1396 -- The append here is really redundant, since the bindings don't
1397 -- scope over each other. ToDo.
1399 unionUDList = foldr unionUDs emptyUDs
1401 singleFvUDs (VarArg v) | not (isImportedId v)
1402 = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
1406 singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
1408 dumpDBs :: [DictBindDetails]
1409 -> Bool -- True <=> top level bound Ids
1410 -> [TyVar] -- TyVars being bound (cloned)
1411 -> [Id] -- Ids being bound (cloned)
1412 -> FreeVarsSet -- Fvs of body
1413 -> ([CoreBinding], -- These ones have to go here
1414 [DictBindDetails], -- These can float further
1415 [Id], -- Incoming list + names of dicts bound here
1416 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
1419 -- It is just to complex to try to float top-level
1420 -- dict bindings with constant methods, inst methods,
1421 -- auxillary derived instance defns and user instance
1422 -- defns all getting in the way.
1423 -- So we dump all dbinds as soon as we get to the top
1424 -- level and place them in a *global* Rec.
1425 -- We leave it to the simplifier will sort it all out ...
1427 dumpDBs [] top_lev bound_tyvars bound_ids fvs
1428 = ([], [], bound_ids, fvs)
1430 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
1431 top_lev bound_tyvars bound_ids fvs
1433 || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
1434 || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
1435 = let -- Ha! Dump it!
1436 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1437 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
1439 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1441 | otherwise -- This one can float out further
1443 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1444 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
1446 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
1450 dumpUDs :: UsageDetails
1451 -> Bool -- True <=> top level bound Ids
1452 -> Bool -- True <=> dict bindings to be floated (specBind only)
1453 -> [CallInstance] -- Call insts for bound Ids (instBind only)
1454 -> [Id] -- Ids which are just being bound; *new*
1455 -> [TyVar] -- TyVars which are just being bound
1456 -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
1457 UsageDetails) -- The above bindings removed, and
1458 -- any call-instances which mention the ids dumped too
1460 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
1462 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
1463 = dumpDBs dbs top_lev tvs bound_ids fvs
1464 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
1465 fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
1467 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
1471 addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
1472 -> UsageDetails -- The usage to augment
1474 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
1475 (UsageDetails cis tycon_cis dbs fvs c i)
1476 = UsageDetails (db_cis `unionBags` cis)
1477 (db_tycon_cis `unionBags` tycon_cis)
1478 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
1480 -- NB: We ignore counts from dictbinds since it is not user code
1482 -- The free tyvars of the dictionary bindings should really be
1483 -- gotten from the RHSs, but I'm pretty sure it's good enough just
1484 -- to look at the type of the dictionary itself.
1485 -- Doing the proper job would entail keeping track of free tyvars as
1486 -- well as free vars, which would be a bore.
1487 db_ftvs = tyVarsOfTypes (map idType dbinders)
1490 %************************************************************************
1492 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
1494 %************************************************************************
1496 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
1498 1) (NoLift LitArg l) : an Id which is bound to a literal
1500 2) (NoLift LitArg l) : an Id bound to a "new" Id
1501 The new Id is a possibly-type-specialised clone of the original
1503 3) Lifted lifted_id unlifted_id :
1505 This indicates that the original Id has been specialised to an
1506 unboxed value which must be lifted (see "Unboxed bindings" above)
1507 @unlifted_id@ is the unboxed clone of the original Id
1508 @lifted_id@ is a *lifted* version of the original Id
1510 When you lookup Ids which are Lifted, you have to insert a case
1511 expression to un-lift the value (done with @bindUnlift@)
1513 You also have to insert a case to lift the value in the binding
1514 (done with @liftExpr@)
1518 type SpecIdEnv = IdEnv CloneInfo
1521 = NoLift CoreArg -- refers to cloned id or literal
1523 | Lifted Id -- lifted, cloned id
1524 Id -- unlifted, cloned id
1528 %************************************************************************
1530 \subsection[specialise-data]{Data returned by specialiser}
1532 %************************************************************************
1539 -- True <=> Specialisation performed
1541 -- False <=> Specialisation completed with errors
1544 -- Local tycons declared in this module
1547 -- Those in-scope data types for which we want to
1548 -- generate code for their constructors.
1549 -- Namely: data types declared in this module +
1550 -- any big tuples used in this module
1551 -- The initial (and default) value is the local tycons
1553 (FiniteMap TyCon [(Bool, [Maybe Type])])
1554 -- TyCon specialisations to be generated
1555 -- We generate specialialised code (Bool=True) for data types
1556 -- defined in this module and any tuples used in this module
1557 -- The initial (and default) value is the specialisations
1558 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1559 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1561 (Bag (Id,[Maybe Type]))
1562 -- Imported specialisation errors
1563 (Bag (Id,[Maybe Type]))
1564 -- Imported specialisation warnings
1565 (Bag (TyCon,[Maybe Type]))
1566 -- Imported TyCon specialisation errors
1568 initSpecData local_tycons tycon_specs
1569 = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1574 ToDo[sansom]: Transformation data to process specialisation requests.
1576 %************************************************************************
1578 \subsection[specProgram]{Specialising a core program}
1580 %************************************************************************
1583 specProgram :: UniqSupply
1584 -> [CoreBinding] -- input ...
1586 -> ([CoreBinding], -- main result
1587 SpecialiseData) -- result specialise data
1589 specProgram uniqs binds
1590 (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1591 = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
1592 (final_binds, tycon_specs_list,
1593 UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1595 used_conids = filter isDataCon (uniqSetToList fvs)
1596 used_tycons = map dataConTyCon used_conids
1597 used_gen = filter isLocalGenTyCon used_tycons
1598 gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
1600 result_specs = addListToFM_C (++) init_specs tycon_specs_list
1602 uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
1603 cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1604 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1605 cis_warn = init_warn `unionBags` listToBag cis_other
1606 cis_errs = init_errs `unionBags` listToBag cis_unboxed
1608 uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
1609 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1610 tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
1612 no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
1613 && (not opt_SpecialiseImports || isEmptyBag cis_warn)
1615 (if opt_D_simplifier_stats then
1616 pprTrace "\nSpecialiser Stats:\n" (vcat [
1617 hcat [ptext SLIT("SpecCalls "), int spec_calls],
1618 hcat [ptext SLIT("SpecInsts "), int spec_insts],
1623 SpecData True no_errs local_tycons gen_tycons result_specs
1624 cis_errs cis_warn tycis_errs)
1626 specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
1627 = panic "Specialise:specProgram: specialiser called more than once"
1629 -- It may be possible safely to call the specialiser more than once,
1630 -- but I am not sure there is any benefit in doing so (Patrick)
1632 -- ToDo: What about unfoldings performed after specialisation ???
1635 %************************************************************************
1637 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1639 %************************************************************************
1641 In the specialiser we just collect up the specialisations which will
1642 be required. We don't create the specialised constructors in
1643 Core. These are only introduced when we convert to StgSyn.
1645 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1648 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1649 -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1651 specTyConsAndScope scopeM
1652 = scopeM `thenSM` \ (binds, scope_uds) ->
1654 (tycons_cis, gotci_scope_uds)
1655 = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds
1657 tycon_specs_list = collectTyConSpecs tycons_cis
1659 (if opt_SpecialiseTrace && not (null tycon_specs_list) then
1660 pprTrace "Specialising TyCons:\n"
1661 (vcat [ if not (null specs) then
1662 hang (hsep [(ppr tycon), ptext SLIT("at types")])
1663 4 (vcat (map pp_specs specs))
1665 | (tycon, specs) <- tycon_specs_list])
1667 returnSM (binds, tycon_specs_list, gotci_scope_uds)
1670 collectTyConSpecs []
1672 collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1673 = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1675 (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1676 uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1677 tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1679 pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys]
1683 %************************************************************************
1685 \subsection[specTopBinds]{Specialising top-level bindings}
1687 %************************************************************************
1690 specTopBinds :: [CoreBinding]
1691 -> SpecM ([CoreBinding], UsageDetails)
1694 = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1696 -- Add bindings for floated dbinds and collect fvs
1697 -- In actual fact many of these bindings are dead code since dict
1698 -- arguments are dropped when a specialised call is created
1699 -- The simplifier should be able to cope ...
1701 (dbinders_s, dbinds, dfvs_s)
1702 = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1704 full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
1705 fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
1707 -- It is just to complex to try to sort out top-level dependencies
1708 -- So we just place all the top-level binds in a *global* Rec and
1709 -- leave it to the simplifier to sort it all out ...
1712 returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1715 spec_top_binds (first_bind:rest_binds)
1716 = specBindAndScope True first_bind (
1717 spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1718 returnSM (ItsABinds rest_binds, rest_uds)
1719 ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1720 returnSM (first_binds ++ rest_binds, all_uds)
1723 = returnSM ([], emptyUDs)
1726 %************************************************************************
1728 \subsection[specExpr]{Specialising expressions}
1730 %************************************************************************
1733 specExpr :: CoreExpr
1734 -> [CoreArg] -- The arguments:
1735 -- TypeArgs are speced
1736 -- ValArgs are unprocessed
1737 -> SpecM (CoreExpr, -- Result expression with specialised versions installed
1738 UsageDetails)-- Details of usage of enclosing binders in the result
1741 specExpr (Var v) args
1742 = specId v $ \ v_arg ->
1744 LitArg lit -> ASSERT( null args )
1745 returnSM (Lit lit, emptyUDs)
1747 VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds ->
1748 returnSM (mkGenApp (Var new_v) args, uds)
1750 specExpr expr@(Lit _) null_args
1751 = ASSERT (null null_args)
1752 returnSM (expr, emptyUDs)
1754 specExpr (Con con args) null_args
1755 = ASSERT (null null_args)
1756 specArgs args $ \ args' ->
1757 mkTyConInstance con args' `thenSM` \ con_uds ->
1758 returnSM (Con con args', con_uds)
1760 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
1761 = ASSERT (null null_args)
1762 specArgs args $ \ args' ->
1763 mapSM specTy arg_tys `thenSM` \ arg_tys' ->
1764 specTy res_ty `thenSM` \ res_ty' ->
1765 returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs)
1767 specExpr (Prim prim args) null_args
1768 = ASSERT (null null_args)
1769 specArgs args $ \ args' ->
1770 -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
1771 returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
1775 specPrimOp :: PrimOp
1781 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1782 -- and/or chooses PrimOp specialised to any unboxed tys
1783 -- Errors are dealt with by returning a PrimOp call instance
1784 -- which will result in a cis_errs message
1786 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1790 specExpr (App fun arg) args
1791 = specArg arg `thenSM` \ new_arg ->
1792 specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
1793 returnSM (expr, uds)
1795 specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
1796 = lookup_arg arg `thenSM` \ arg ->
1797 bindId binder arg (specExpr body args)
1799 lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1800 lookup_arg (VarArg v) = lookupId v
1802 specExpr (Lam (ValBinder binder) body) []
1803 = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1804 returnSM (Lam (ValBinder binder) body, uds)
1806 specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
1807 = -- Type lambda with argument; argument already spec'd
1808 bindTyVar tyvar ty ( specExpr body args )
1810 specExpr (Lam (TyBinder tyvar) body) []
1812 cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
1813 bindTyVar tyvar (mkTyVarTy new_tyvar) (
1814 specExpr body [] `thenSM` \ (body, body_uds) ->
1816 (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1818 returnSM (Lam (TyBinder new_tyvar)
1819 (mkCoLetsNoUnboxed binds_here body),
1823 specExpr (Case scrutinee alts) args
1824 = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
1825 specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
1826 returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
1828 scrutinee_type = coreExprType scrutinee
1830 specExpr (Let bind body) args
1831 = specBindAndScope False bind (
1832 specExpr body args `thenSM` \ (body, body_uds) ->
1833 returnSM (ItsAnExpr body, body_uds)
1834 ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1835 returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1837 specExpr (SCC cc expr) args
1838 = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
1839 mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1842 = if squashableDictishCcExpr cc expr -- can toss the _scc_
1846 returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1847 unionUDList args_uds_s `unionUDs` expr_uds)
1849 specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
1851 -- ToDo: This may leave some unspec'd dictionaries!!
1854 %************************************************************************
1856 \subsubsection{Specialising a lambda}
1858 %************************************************************************
1861 specLambdaOrCaseBody :: [Id] -- The binders
1862 -> CoreExpr -- The body
1863 -> [CoreArg] -- Its args
1864 -> SpecM ([Id], -- New binders
1865 CoreExpr, -- New body
1868 specLambdaOrCaseBody bound_ids body args
1869 = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
1870 bindIds bound_ids clone_infos (
1872 specExpr body args `thenSM` \ (body, body_uds) ->
1875 -- Dump any dictionary bindings (and call instances)
1876 -- from the scope which mention things bound here
1877 (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1879 returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1882 -- ToDo: Opportunity here to common-up dictionaries with same type,
1883 -- thus avoiding recomputation.
1886 A variable bound in a lambda or case is normally monomorphic so no
1887 specialised versions will be required. This is just as well since we
1888 do not know what code to specialise!
1890 Unfortunately this is not always the case. For example a class Foo
1891 with polymorphic methods gives rise to a dictionary with polymorphic
1892 components as follows:
1899 instance Foo Int where
1907 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1908 d.Foo.Int = (op1_Int, op2_Int)
1910 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1912 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1915 N.B. The type of the dictionary is not Hindley Milner!
1917 Now we must specialise op1 at {* Int#} which requires a version of
1918 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1919 not have access to its code to create the specialised version.
1921 If we specialise on overloaded types as well we specialise op1 at
1922 {Int Int#} d.Foo.Int:
1924 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1926 Though this is still invalid, after further simplification we get:
1928 op1_Int_Int# = opInt1 {Int#}
1930 Another round of specialisation will result in the specialised
1931 version of op1Int being called directly.
1933 For now we PANIC if a polymorphic lambda/case bound variable is found
1934 in a call instance with an unboxed type. Other call instances, arising
1935 from overloaded type arguments, are discarded since the unspecialised
1936 version extracted from the method can be called as normal.
1938 ToDo: Implement and test second round of specialisation.
1941 %************************************************************************
1943 \subsubsection{Specialising case alternatives}
1945 %************************************************************************
1949 specAlts (AlgAlts alts deflt) scrutinee_ty args
1950 = mapSM specTy ty_args `thenSM` \ ty_args ->
1951 mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
1952 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1953 returnSM (AlgAlts alts deflt,
1954 unionUDList alts_uds_s `unionUDs` deflt_uds)
1956 -- We use ty_args of scrutinee type to identify specialisation of
1959 (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
1960 splitAlgTyConApp scrutinee_ty
1962 specAlgAlt ty_args (con,binders,rhs)
1963 = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
1964 mkTyConInstance con ty_args `thenSM` \ con_uds ->
1965 returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1967 specAlts (PrimAlts alts deflt) scrutinee_ty args
1968 = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
1969 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1970 returnSM (PrimAlts alts deflt,
1971 unionUDList alts_uds_s `unionUDs` deflt_uds)
1973 specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
1974 returnSM ((lit,rhs), uds)
1977 specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
1978 specDeflt (BindDefault binder rhs) args
1979 = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
1980 returnSM (BindDefault binder rhs, uds)
1984 %************************************************************************
1986 \subsubsection{Specialising an atom}
1988 %************************************************************************
1991 partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
1993 = span is_ty_arg args
1995 is_ty_arg (TyArg _) = True
2000 -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
2001 -> SpecM (CoreExpr, UsageDetails)
2003 = lookupId v `thenSM` \ vlookup ->
2007 -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) ->
2008 returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
2011 -> thing_inside vatom `thenSM` \ (expr, uds) ->
2012 returnSM (expr, singleFvUDs vatom `unionUDs` uds)
2015 -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
2016 -> SpecM (CoreExpr, UsageDetails))
2018 specArg (TyArg ty) thing_inside
2019 = specTy ty `thenSM` \ new_ty ->
2020 thing_inside (TyArg new_ty)
2022 specArg (LitArg lit)
2023 = thing_inside (LitArg lit)
2028 specArgs [] thing_inside
2031 specArgs (arg:args) thing_inside
2032 = specArg arg $ \ arg' ->
2033 specArgs args $ \ args' ->
2034 thing_inside (arg' : args')
2038 %************************************************************************
2040 \subsubsection{Specialising bindings}
2042 %************************************************************************
2044 A classic case of when having a polymorphic recursive function would help!
2047 data BindsOrExpr = ItsABinds [CoreBinding]
2048 | ItsAnExpr CoreExpr
2053 :: Bool -- True <=> a top level group
2054 -> CoreBinding -- As yet unprocessed
2055 -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
2056 -> SpecM ([CoreBinding], -- Processed
2057 BindsOrExpr, -- Combined result
2058 UsageDetails) -- Usage details of the whole lot
2060 specBindAndScope top_lev bind scopeM
2061 = cloneLetBinders top_lev (is_rec bind) binders
2062 `thenSM` \ (new_binders, clone_infos) ->
2064 -- Two cases now: either this is a bunch of local dictionaries,
2065 -- in which case we float them; or its a bunch of other values,
2066 -- in which case we see if they correspond to any call-instances
2067 -- we have from processing the scope
2069 if not top_lev && all (isDictTy . idType) binders
2071 -- Ha! A group of local dictionary bindings
2073 bindIds binders clone_infos (
2075 -- Process the dictionary bindings themselves
2076 specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
2078 -- Process their scope
2079 scopeM `thenSM` \ (thing, scope_uds) ->
2081 -- Add the bindings to the current stuff
2082 final_uds = addDictBinds new_binders bind rhs_uds scope_uds
2084 returnSM ([], thing, final_uds)
2087 -- Ho! A group of bindings
2089 fixSM (\ ~(_, _, _, rec_spec_infos) ->
2091 bindSpecIds binders clone_infos rec_spec_infos (
2092 -- It's ok to have new binders in scope in
2093 -- non-recursive decls too, cos name shadowing is gone by now
2095 -- Do the scope of the bindings
2096 scopeM `thenSM` \ (thing, scope_uds) ->
2098 (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
2100 equiv_ciss = equivClasses cmpCI_tys call_insts
2101 inst_cis = map head equiv_ciss
2104 -- Do the bindings themselves
2105 specBind top_lev False new_binders inst_cis bind
2106 `thenSM` \ (spec_bind, spec_uds) ->
2108 -- Create any necessary instances
2109 instBind top_lev new_binders bind equiv_ciss inst_cis
2110 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
2113 -- NB: dumpUDs only worries about new_binders since the free var
2114 -- stuff only records free new_binders
2115 -- The spec_ids only appear in SpecInfos and final speced calls
2117 -- Build final binding group and usage details
2118 (final_binds, final_uds)
2120 -- For a top-level binding we have to dumpUDs from
2121 -- spec_uds and inst_uds and scope_uds creating
2122 -- *global* dict bindings
2124 (scope_dict_binds, final_scope_uds)
2125 = dumpUDs gotci_scope_uds True False [] new_binders []
2126 (spec_dict_binds, final_spec_uds)
2127 = dumpUDs spec_uds True False inst_cis new_binders []
2128 (inst_dict_binds, final_inst_uds)
2129 = dumpUDs inst_uds True False inst_cis new_binders []
2131 ([spec_bind] ++ inst_binds ++ scope_dict_binds
2132 ++ spec_dict_binds ++ inst_dict_binds,
2133 final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
2135 -- For a local binding we only have to dumpUDs from
2136 -- scope_uds since the UDs from spec_uds and inst_uds
2137 -- have already been dumped by specBind and instBind
2139 (scope_dict_binds, final_scope_uds)
2140 = dumpUDs gotci_scope_uds False False [] new_binders []
2142 ([spec_bind] ++ inst_binds ++ scope_dict_binds,
2143 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
2145 -- inst_uds comes last, because there may be dict bindings
2146 -- floating outward in scope_uds which are mentioned
2147 -- in the call-instances, and hence in spec_uds.
2148 -- This ordering makes sure that the precedence order
2149 -- among the dict bindings finally floated out is maintained.
2151 returnSM (final_binds, thing, final_uds, spec_infos)
2153 ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
2154 returnSM (binds, thing, final_uds)
2156 binders = bindersOf bind
2158 is_rec (NonRec _ _) = False
2163 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
2165 -> SpecM (CoreBinding, UsageDetails)
2166 -- The UsageDetails returned has already had stuff to do with this group
2167 -- of binders deleted; that's why new_binders is passed in.
2168 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
2169 = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
2170 `thenSM` \ ((binder,rhs), rhs_uds) ->
2171 returnSM (NonRec binder rhs, rhs_uds)
2173 specBind top_lev floating new_binders inst_cis (Rec pairs)
2174 = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
2175 `thenSM` \ (pairs, rhs_uds_s) ->
2176 returnSM (Rec pairs, unionUDList rhs_uds_s)
2179 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
2181 -> SpecM ((Id,CoreExpr), UsageDetails)
2183 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
2184 = lookupId binder `thenSM` \ blookup ->
2185 specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
2187 specid_maybe_maybe = isSpecPragmaId_maybe binder
2188 is_specid = maybeToBool specid_maybe_maybe
2189 Just specinfo_maybe = specid_maybe_maybe
2190 specid_with_info = maybeToBool specinfo_maybe
2191 Just spec_info = specinfo_maybe
2193 -- If we have a SpecInfo stored in a SpecPragmaId binder
2194 -- it will contain a SpecInfo with an explicit SpecId
2195 -- We add the explicit ci to the usage details
2196 -- Any ordinary cis for orig_id (there should only be one)
2197 -- will be ignored later
2200 = if is_specid && specid_with_info then
2202 (SpecInfo spec_tys _ spec_id) = spec_info
2203 Just (orig_id, _) = isSpecId_maybe spec_id
2205 ASSERT(toplevelishId orig_id) -- must not be cloned!
2206 explicitCI orig_id spec_tys spec_info
2210 -- For a local binding we dump the usage details, creating
2211 -- any local dict bindings required
2212 -- At the top-level the uds will be dumped in specBindAndScope
2213 -- and the dict bindings made *global*
2215 (local_dict_binds, final_uds)
2216 = if not top_lev then
2217 dumpUDs rhs_uds False floating inst_cis new_binders []
2222 Lifted lift_binder unlift_binder
2223 -> -- We may need to record an unboxed instance of
2224 -- the _Lift data type in the usage details
2225 mkTyConInstance liftDataCon [idType unlift_binder]
2226 `thenSM` \ lift_uds ->
2227 returnSM ((lift_binder,
2228 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
2229 final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
2231 NoLift (VarArg binder)
2232 -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
2233 final_uds `unionUDs` pragma_uds)
2237 %************************************************************************
2239 \subsection{@instBind@}
2241 %************************************************************************
2244 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
2246 = returnSM ([], emptyUDs, [])
2248 | all same_overloading other_binders
2249 = -- For each call_inst, build an instance
2250 mapAndUnzip3SM do_this_class equiv_ciss
2251 `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
2253 -- Add in the remaining UDs
2254 returnSM (catMaybes inst_binds,
2255 unionUDList inst_uds_s,
2259 | otherwise -- Incompatible overloadings; see below by same_overloading
2260 = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
2261 then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
2263 then pprTrace "dumpCIs: not same overloading ... top level \n"
2265 ) (hang (hcat [ptext SLIT("{"),
2268 4 (vcat [vcat (map (pprGenType . idType) new_ids),
2269 vcat (map pprCI (concat equiv_ciss))]))
2270 (returnSM ([], emptyUDs, []))
2273 (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
2274 tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
2276 no_of_tyvars = length tyvar_tmpls
2277 no_of_dicts = length class_tyvar_pairs
2279 do_this_class equiv_cis
2280 = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
2282 (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
2283 do_cis = head (normal_cis ++ explicit_cis)
2284 -- must choose a normal_cis in preference since dict_args will
2285 -- not be defined for an explicit_cis
2287 -- same_overloading tests whether the types of all the binders
2288 -- are "compatible"; ie have the same type and dictionary abstractions
2289 -- Almost always this is the case, because a recursive group is abstracted
2290 -- all together. But, it can happen that it ain't the case, because of
2291 -- code generated from instance decls:
2294 -- dfun.Foo.Int :: (forall a. a -> Int, Int)
2295 -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
2297 -- const.op1.Int :: forall a. a -> Int
2298 -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
2300 -- const.op2.Int :: Int
2301 -- const.op2.Int = 3
2303 -- Note that the first two defns have different polymorphism, but they are
2304 -- mutually recursive!
2306 same_overloading :: Id -> Bool
2308 = no_of_tyvars == length this_id_tyvars
2309 -- Same no of tyvars
2310 && no_of_dicts == length this_id_class_tyvar_pairs
2311 -- Same no of vdicts
2312 && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
2313 && length class_tyvar_pairs == length this_id_class_tyvar_pairs
2316 (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
2317 tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
2319 same_ov (clas1,tyvar1) (clas2,tyvar2)
2321 tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
2325 - a call instance eg f [t1,t2,t3] [d1,d2]
2326 - the rhs of the function eg orig_rhs
2327 - a constraint vector, saying which of eg [T,F,T]
2328 the functions type args are constrained
2331 We return a new definition
2333 $f1 = /\a -> orig_rhs t1 a t3 d1 d2
2335 The SpecInfo for f will be:
2337 SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
2339 Based on this SpecInfo, a call instance of f
2343 should get replaced by
2345 ...(\d1 d2 -> $f1 t2)...
2347 (But that is the business of the simplifier.)
2350 mkOneInst :: CallInstance
2351 -> [CallInstance] -- Any explicit cis for this inst
2352 -> Int -- No of dicts to specialise
2353 -> Bool -- Top level binders?
2354 -> [CallInstance] -- Instantiated call insts for binders
2355 -> [Id] -- New binders
2356 -> CoreBinding -- Unprocessed
2357 -> SpecM (Maybe CoreBinding, -- Instantiated version of input
2359 [Maybe SpecInfo] -- One for each id in the original binding
2362 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
2363 no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
2364 = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
2365 `thenSM` \ spec_ids ->
2366 newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
2368 -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
2369 -- which correspond to unspecialised args
2371 (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
2374 args = map TyArg arg_tys ++ dict_args
2376 (new_id:_) = new_ids
2377 (spec_id:_) = spec_ids
2379 do_bind (NonRec orig_id rhs)
2380 = do_one_rhs (spec_id, new_id, (orig_id,rhs))
2381 `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
2383 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
2384 Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
2387 = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
2388 `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
2389 returnSM (Just (Rec (catMaybes maybe_pairs)),
2390 unionUDList rhss_uds_s, spec_infos)
2392 do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
2394 -- Avoid duplicating a spec which has already been created ...
2395 -- This can arise in a Rec involving a dfun for which a
2396 -- a specialised instance has been created but specialisation
2397 -- "required" by one of the other Ids in the Rec
2398 | top_lev && maybeToBool lookup_orig_spec
2399 = (if opt_SpecialiseTrace
2400 then trace_nospec " Exists: " orig_id
2403 returnSM (Nothing, emptyUDs, Nothing)
2406 -- Check for a (single) explicit call instance for this id
2407 | not (null explicit_cis_for_this_id)
2408 = ASSERT (length explicit_cis_for_this_id == 1)
2409 (if opt_SpecialiseTrace
2410 then trace_nospec " Explicit: " explicit_id
2413 returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
2416 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
2418 = ASSERT (no_of_dicts_to_specialise == length dict_args)
2419 specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
2421 -- For a local binding we dump the usage details, creating
2422 -- any local dict bindings required
2423 -- At the top-level the uds will be dumped in specBindAndScope
2424 -- and the dict bindings made *global*
2426 (local_dict_binds, final_uds)
2427 = if not top_lev then
2428 dumpUDs inst_uds False False inst_cis new_ids []
2432 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
2434 if isUnboxedType (idType spec_id) then
2435 ASSERT (null poly_tyvars)
2436 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2437 mkTyConInstance liftDataCon [idType unlift_spec_id]
2438 `thenSM` \ lift_uds ->
2439 returnSM (Just (lift_spec_id,
2440 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
2441 tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
2443 returnSM (Just (spec_id,
2444 mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
2445 tickSpecInsts final_uds, spec_info)
2447 lookup_orig_spec = matchSpecEnv (getIdSpecialisation orig_id) arg_tys
2449 explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
2450 [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
2451 SpecInfo _ _ explicit_id = explicit_spec_info
2453 trace_nospec :: String -> Id -> a -> a
2454 trace_nospec str spec_id
2456 (hsep [ppr new_id, hsep (map pp_ty arg_tys),
2457 ptext SLIT("==>"), ppr spec_id])
2459 (if opt_SpecialiseTrace then
2460 pprTrace "Specialising:"
2461 (hang (hcat [char '{',
2465 hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)],
2466 if isExplicitCI do_cis then empty else
2467 hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)],
2468 hcat [ptext SLIT("specs: "), ppr spec_ids]]))
2471 do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
2473 returnSM (maybe_inst_bind, inst_uds, spec_infos)
2476 pp_dict d = ppr_arg d
2477 pp_ty t = pprParendGenType t
2479 do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
2480 do_the_wotsit tyvars (Just ty) = (tyvars, ty)
2484 %************************************************************************
2486 \subsection[Misc]{Miscellaneous junk}
2488 %************************************************************************
2491 mkCallInstance :: Id
2494 -> SpecM UsageDetails
2496 mkCallInstance id new_id args
2497 | null args || -- No args at all
2498 idWantsToBeINLINEd id || -- It's going to be inlined anyway
2499 not enough_args || -- Not enough type and dict args
2500 not interesting_overloading -- Overloaded types are just tyvars
2504 = returnSM (singleCI new_id spec_tys dicts)
2507 (tyvars, theta, _) = splitSigmaTy (idType id)
2508 constrained_tyvars = tyvarsOfTypes (map snd class_tyvar_pairs)
2510 arg_res = take_type_args tyvars class_tyvar_pairs args
2511 enough_args = maybeToBool arg_res
2512 (Just (tys, dicts, rest_args)) = arg_res
2514 interesting_overloading = not (null (catMaybes spec_tys))
2515 spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys
2517 ---------------------------------------------------------------
2518 -- Should we specialise on this type argument?
2519 spec_ty tyvar ty | isTyVarTy ty = Nothing
2521 spec_ty tyvar ty | opt_SpecialiseAll
2522 || (opt_SpecialiseUnboxed
2524 && isBoxedTypeKind (tyVarKind tyvar))
2525 || (opt_SpecialiseOverloaded
2526 && tyvar `elemTyVarSet` constrained_tyvars)
2529 | otherwise = Nothing
2531 ----------------- Rather a gruesome help-function ---------------
2532 take_type_args (_:tyvars) (TyArg ty : args)
2533 = case (take_type_args tyvars args) of
2535 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2537 take_type_args (_:tyvars) [] = Nothing
2539 take_type_args [] args
2540 = case (take_dict_args class_tyvar_pairs args) of
2542 Just (dicts, others) -> Just ([], dicts, others)
2544 take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
2545 = case (take_dict_args class_tyvar_pairs args) of
2547 Just (dicts, others) -> Just (dict:dicts, others)
2549 take_dict_args (_:class_tyvar_pairs) args = Nothing
2551 take_dict_args [] args = Just ([], args)
2556 mkTyConInstance :: Id
2558 -> SpecM UsageDetails
2559 mkTyConInstance con tys
2560 = recordTyConInst con tys `thenSM` \ record_inst ->
2562 Nothing -- No TyCon instance
2563 -> -- pprTrace "NoTyConInst:"
2564 -- (hsep [ppr tycon, ptext SLIT("at"),
2565 -- ppr con, hsep (map (ppr) tys)])
2566 (returnSM (singleConUDs con))
2568 Just spec_tys -- Record TyCon instance
2569 -> -- pprTrace "TyConInst:"
2570 -- (hsep [ppr tycon, ptext SLIT("at"),
2571 -- ppr con, hsep (map (ppr) tys),
2573 -- hsep [pprMaybeTy ty | ty <- spec_tys],
2575 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2577 tycon = dataConTyCon con
2581 recordTyConInst :: Id
2583 -> SpecM (Maybe [Maybe Type])
2585 recordTyConInst con tys
2587 spec_tys = specialiseConstrTys tys
2589 do_tycon_spec = maybeToBool (firstJust spec_tys)
2591 spec_exists = maybeToBool (lookupSpecEnv
2592 (getIdSpecialisation con)
2595 -- pprTrace "ConSpecExists?: "
2596 -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")),
2597 -- ppr PprShowAll con, hsep (map ppr tys)])
2598 (if (not spec_exists && do_tycon_spec)
2599 then returnSM (Just spec_tys)
2600 else returnSM Nothing)
2603 %************************************************************************
2605 \subsection[monad-Specialise]{Monad used in specialisation}
2607 %************************************************************************
2611 inherited: control flags and
2612 recordInst functions with flags cached
2614 environment mapping tyvars to types
2615 environment mapping Ids to Atoms
2617 threaded in and out: unique supply
2620 type TypeEnv = TyVarEnv Type
2628 initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs
2630 returnSM :: a -> SpecM a
2631 thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
2632 fixSM :: (a -> SpecM a) -> SpecM a
2634 thenSM m k tvenv idenv us
2635 = case splitUniqSupply us of { (s1, s2) ->
2636 case (m tvenv idenv s1) of { r ->
2637 k r tvenv idenv s2 }}
2639 returnSM r tvenv idenv us = r
2641 fixSM k tvenv idenv us
2644 r = k r tvenv idenv us -- Recursive in r!
2647 The only interesting bit is figuring out the type of the SpecId!
2650 newSpecIds :: [Id] -- The id of which to make a specialised version
2651 -> [Maybe Type] -- Specialise to these types
2652 -> Int -- No of dicts to specialise
2655 newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
2656 = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2657 | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
2659 uniqs = getUniques (length new_ids) us
2660 spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2662 newTyVars :: Int -> SpecM [TyVar]
2663 newTyVars n tvenv idenv us
2664 = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
2667 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2668 binders, and build ``clones'' for them. The clones differ from the
2669 originals in three ways:
2671 (a) they have a fresh unique
2672 (b) they have the current type environment applied to their type
2673 (c) for Let binders which have been specialised to unboxed values
2674 the clone will have a lifted type
2676 As well as returning the list of cloned @Id@s they also return a list of
2677 @CloneInfo@s which the original binders should be bound to.
2680 cloneLambdaOrCaseBinders :: [Id] -- Old binders
2681 -> SpecM ([Id], [CloneInfo]) -- New ones
2683 cloneLambdaOrCaseBinders old_ids tvenv idenv us
2685 uniqs = getUniques (length old_ids) us
2687 unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
2689 clone_it old_id uniq
2690 = (new_id, NoLift (VarArg new_id))
2692 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2694 cloneLetBinders :: Bool -- Top level ?
2695 -> Bool -- Recursice
2696 -> [Id] -- Old binders
2697 -> SpecM ([Id], [CloneInfo]) -- New ones
2699 cloneLetBinders top_lev is_rec old_ids tvenv idenv us
2701 uniqs = getUniques (2 * length old_ids) us
2703 unzip (clone_them old_ids uniqs)
2705 clone_them [] [] = []
2707 clone_them (old_id:olds) (u1:u2:uniqs)
2710 NoLift (VarArg old_id)) : clone_rest
2712 -- Don't clone if it is a top-level thing. Why not?
2713 -- (a) we don't want to change the uniques
2715 -- (b) we don't have to be paranoid about name capture
2716 -- (c) the thing is polymorphic so no need to subst
2719 = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
2721 Lifted lifted_id unlifted_id) : clone_rest
2723 NoLift (VarArg new_id)) : clone_rest
2726 clone_rest = clone_them olds uniqs
2728 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2729 new_ty = idType new_id
2730 old_ty = idType old_id
2732 (lifted_id, unlifted_id) = mkLiftedId new_id u2
2735 cloneTyVarSM :: TyVar -> SpecM TyVar
2737 cloneTyVarSM old_tyvar tvenv idenv us
2741 cloneTyVar old_tyvar uniq -- new_tyvar
2743 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2745 bindId id val specm tvenv idenv us
2746 = specm tvenv (addOneToIdEnv idenv id val) us
2748 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2750 bindIds olds news specm tvenv idenv us
2751 = specm tvenv (growIdEnvList idenv (zip olds news)) us
2753 bindSpecIds :: [Id] -- Old
2754 -> [(CloneInfo)] -- New
2755 -> [[Maybe SpecInfo]] -- Corresponding specialisations
2756 -- Each sub-list corresponds to a different type,
2757 -- and contains one Maybe spec_info for each id
2761 bindSpecIds olds clones spec_infos specm tvenv idenv us
2762 = specm tvenv (growIdEnvList idenv old_to_clone) us
2764 old_to_clone = mk_old_to_clone olds clones spec_infos
2766 -- The important thing here is that we are *lazy* in spec_infos
2767 mk_old_to_clone [] [] _ = []
2768 mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2769 = (old, add_spec_info clone) :
2770 mk_old_to_clone rest_olds rest_clones spec_infos_rest
2772 add_spec_info (NoLift (VarArg new))
2773 = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)))
2774 add_spec_info lifted
2775 = lifted -- no specialised instances for unboxed lifted values
2777 spec_infos_this_id = catMaybes (map head spec_infos)
2778 spec_infos_rest = map tail spec_infos
2781 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2783 bindTyVar tyvar ty specm tvenv idenv us
2784 = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2788 lookupId :: Id -> SpecM CloneInfo
2790 lookupId id tvenv idenv us
2791 = case lookupIdEnv idenv id of
2792 Nothing -> NoLift (VarArg id)
2797 specTy :: Type -> SpecM Type -- Apply the current type envt to the type
2799 specTy ty tvenv idenv us
2800 = instantiateTy tvenv ty
2804 liftId :: Id -> SpecM (Id, Id)
2805 liftId id tvenv idenv us
2812 In other monads these @mapSM@ things are usually called @listM@.
2813 I think @mapSM@ is a much better name. The `2' and `3' variants are
2814 when you want to return two or three results, and get at them
2815 separately. It saves you having to do an (unzip stuff) right after.
2818 mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
2819 mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
2820 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2821 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2823 mapSM f [] = returnSM []
2824 mapSM f (x:xs) = f x `thenSM` \ r ->
2825 mapSM f xs `thenSM` \ rs ->
2828 mapAndUnzipSM f [] = returnSM ([],[])
2829 mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
2830 mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
2831 returnSM ((r1:rs1),(r2:rs2))
2833 mapAndUnzip3SM f [] = returnSM ([],[],[])
2834 mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
2835 mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
2836 returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2838 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2839 mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
2840 mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
2841 returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
2847 ===================== OLD CODE, scheduled for deletion =================
2852 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2855 mkCall new_id arg_infos = returnSM (
2857 | maybeToBool (isSuperDictSelId_maybe new_id)
2858 && any isUnboxedType ty_args
2859 -- No specialisations for super-dict selectors
2860 -- Specialise unboxed calls to SuperDictSelIds by extracting
2861 -- the super class dictionary directly form the super class
2862 -- NB: This should be dead code since all uses of this dictionary should
2863 -- have been specialised. We only do this to keep core-lint happy.
2865 Just (_, super_class) = isSuperDictSelId_maybe new_id
2866 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2867 Nothing -> panic "Specialise:mkCall:SuperDictId"
2870 returnSM (False, Var super_dict_id)
2873 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2874 Nothing -> checkUnspecOK new_id ty_args (
2875 returnSM (False, unspec_call)
2878 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2880 -- It may be necessary to specialsie a constant method spec_id again
2881 (spec_id, tys_left, dicts_to_toss) =
2882 case (maybeToBool (isConstMethodId_maybe spec_id_1),
2883 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2884 (False, _ ) -> spec_1_details
2885 (True, Nothing) -> spec_1_details
2886 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2887 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2889 args_left = toss_dicts dicts_to_toss val_args
2891 checkSpecOK new_id ty_args spec_id tys_left (
2893 -- The resulting spec_id may be a top-level unboxed value
2894 -- This can arise for:
2895 -- 1) constant method values
2896 -- eq: class Num a where pi :: a
2897 -- instance Num Double# where pi = 3.141#
2898 -- 2) specilised overloaded values
2899 -- eq: i1 :: Num a => a
2900 -- i1 Int# d.Num.Int# ==> i1.Int#
2901 -- These top level defns should have been lifted.
2902 -- We must add code to unlift such a spec_id.
2904 if isUnboxedType (idType spec_id) then
2905 ASSERT (null tys_left && null args_left)
2906 if toplevelishId spec_id then
2907 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2908 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2909 (Var unlift_spec_id))
2911 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2913 hsep (map (pprParendGenType) ty_args),
2918 (vals_left, _, unlifts_left) = unzip3 args_left
2919 applied_tys = mkTyApp (Var spec_id) tys_left
2920 applied_vals = mkGenApp applied_tys vals_left
2922 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2925 (tys_and_vals, _, unlifts) = unzip3 args
2926 unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2929 -- ty_args is the types at the front of the arg list
2930 -- val_args is the rest of the arg-list
2932 (ty_args, val_args) = get args
2934 get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2935 get args = ([], args)
2938 -- toss_dicts chucks away dict args, checking that they ain't types!
2939 toss_dicts 0 args = args
2940 toss_dicts n ((a,_,_) : args)
2941 | isValArg a = toss_dicts (n-1) args
2946 checkUnspecOK :: Id -> [Type] -> a -> a
2947 checkUnspecOK check_id tys
2948 = if isLocallyDefined check_id && any isUnboxedType tys
2949 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2950 (hsep [ppr check_id,
2951 hsep (map (pprParendGenType) tys)])
2954 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2955 checkSpecOK check_id tys spec_id tys_left
2956 = if any isUnboxedType tys_left
2957 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2958 (vcat [hsep [ppr check_id,
2959 hsep (map (pprParendGenType) tys)],
2961 hsep (map (pprParendGenType) tys_left)]])