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 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 = specExpr body `thenSM` \ (body', body_uds) ->
823 specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
826 all_uds = rhs_uds `plusUDs` body_uds
828 if bndr `elementOfIdSet` free_dicts body_uds then
829 -- This is a dictionary binding; we must pick it up
830 -- and float it outwards.
831 ASSERT( null spec_defns )
832 returnSM (body', addDictBind all_uds bndr' rhs')
834 else if isSpecPragmaId bnd then
835 -- SpecPragmaIds are there solely to generate specialisations
836 -- Just drop the whole binding
837 ASSERT( null spec_defns )
838 returnSM (body', all_uds)
841 -- An ordinary binding, so glue it all together
843 Let (NonRec bndr' rhs') (mkLets spec_defns body'),
844 deleteCalls all_uds bndr'
847 specDefn :: CallDetails -- Info on how it is used in its scope
848 -> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
849 -> SpecM ((Id, CoreExpr), -- The thing and its processed RHS
850 -- the Id may now have specialisations attached
851 [(Id, CoreExpr)], -- Extra, specialised bindings
852 UsageDetails -- Stuff to fling upwards from the RHS and its
853 ) -- specialised versions
855 specDefn calls (fn, rhs)
856 -- The first case is the interesting one
857 | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
858 && n_dicts <= length rhs_bndrs -- and enough dict args
859 && not (null calls_for_me) -- And there are some calls to specialise
860 = specExpr body `thenSM` \ (body', body_uds) ->
861 mapSM (specCall body_uds) calls_for_me `thenSM` \ stuff ->
863 (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
865 (rhs_uds, body'') = dumpUDs rhs_bndrs body_uds body'
866 rhs' = foldr Lam bndrs body''
868 fn' = addIdSpecialisations fn spec_env_stuff
870 returnSM ((fn',rhs'), spec_defns, rhs_uds `plusUDs` plusUDList spec_uds)
872 | otherwise -- No calls or RHS doesn't fit our preconceptions
873 = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
874 returnSM ((fn, rhs'), [], rhs_uds)
877 (tyvars, theta, tau) = splitSigmaTy (idType fn)
878 n_tyvars = length tyvars
879 n_dicts = length theta
881 (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
882 rhs_dicts = take n_dicts rhs_ids
883 rhs_bndrs = map TyBinder rhs_tyvars ++ map ValBinder rhs_dicts
884 body = mkValLam (drop n_dicts rhs_ids) rhs_body
885 -- Glue back on the non-dict lambdas
887 calls_for_me = case lookupFM calls fn of
889 Just cs -> fmToList cs
892 -- Specialise to one particular call pattern
893 spec_call body_uds (call_ts, call_ds)
894 = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
895 -- The calls are only recorded for properly-saturated applications
897 -- Construct the new binding
898 -- f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
899 -- and the type of this binder
901 spec_tys = zipNothings call_ts tyvars
902 spec_rhs = mkTyLam tyvars (mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds))
903 spec_ty = mkForAllTys tyvars (applyTys (idType f) spec_tys)
905 newIdSM f spec_ty `thenSM` \ spec_f ->
908 -- Construct the stuff for f's spec env
909 -- [t1,b,t3,d] |-> \d1 d2 -> f1 b d
911 spec_env_rhs = mkValLam call_ds $
912 mkTyApp (Var spec_f) $
916 -- Specialise the UDs from f's RHS
917 specUDs (zipEqual defn_tvs call_ts)
918 (zipEqual rhs_dicts call_ds)
919 body_uds `thenSM` \ spec_uds ->
921 returnSM ((spec_f, spec_rhs),
923 (spec_tys, spec_env_rhs)
927 %************************************************************************
929 \subsubsection{UsageDetails and suchlike}
931 %************************************************************************
934 type FreeDicts = IdSet
938 free_dicts :: !FreeDicts, -- Dicts free in any of the calls or dict binds
940 dict_binds :: !Bag (DictVar, CoreExpr, FreeDicts),
941 -- Floated dictionary bindings
942 -- The order is important;
943 -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
944 -- (Remember, Bags preserve order in GHC.)
945 -- The FreeDicts is the free vars of the RHS
947 calls :: !CallDetails
950 type CallMap = FiniteMap Id CallInfo
951 type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
952 [DictVar] -- Dict args
953 -- The finite maps eliminate duplicates
954 -- The list of types and dictionaries is guaranteed to
955 -- match the type of f
958 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
959 plusUDs (MkUD {fvs = fvs1, dictBinds = db1, calls = calls1})
960 (MkUD {fvs = fvs2, dictBinds = db2, calls = calls2})
961 = MkUD {fvs, dictBinds, calls}
963 fvs = fvs1 `unionIdSets` fvs2
964 dictBinds = db1 `unionBags` db2
965 calls = calls1 `unionBags` calls2
968 tyVarsOfUDs (MkUD {fvs}) = tyVarsOfTypes (map idType (idSetToList fvs))
970 deleteCalls uds bndr = uds { calls = delFromFM (calls uds) bndr }
972 addDictBind uds dict rhs = uds { free_dicts = addToIdSet (free_dicts uds) dict,
973 dict_binds = (dict, rhs, f
975 dumpUDs :: [CoreBinder]
976 -> UsageDetails -> CoreExpr
977 -> (UsageDetails, CoreExpr)
979 dumpUDs bndrs uds@(MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls}) body
980 = ASSERT( isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs)
981 -- The tyvars shouldn't be free in any of the usage details
982 -- If it was, then we should have found a dictionary lambda first
984 if isEmptyIdSet (id_set `intersectIdSets` fvs) then
985 -- Common case: binder doesn't affect floats
989 -- Binders bind some of the fvs of the floats
990 (MkUDs {fvs = filtered_fvs,
991 dictBinds = filtered_dbs,
992 calls = filtered_calls},
993 foldrBag mk_dict_bind body dump_dbs)
996 tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs]
997 id_list = [id | ValBinder id <- bndrs]
998 id_set = mkIdSet id_list
999 ftvs = tyVarsOfUDs uds
1000 filtered_fvs = orig_fvs `minusIdSet` id_set
1002 (filtered_dbs, dump_dbs, dump_idset)
1003 = foldlBag dump (emptyBag, emptyBag, id_set) orig_dbs
1004 -- Important that it's foldl not foldr;
1005 -- we're accumulating the set of dumped ids in dump_set
1007 -- Filter out any calls that mention things that are being dumped
1008 -- It's a bit tiresome because of the two-level finite map
1009 filtered_calls = mapFM del (foldr delFromFM orig_calls id_list)
1010 del _ dicts = filter (not (`elementOfIdSet` dump_id_set)) dicts
1012 dump (ok_dbs, dump_dbs, dump_idset) db@(dict, rhs, fvs)
1013 | isEmptyIdSet (dump_idset `intersectIdSets` fvs)
1014 = (ok_dbs `snocBag` db, dump_dbs, dump_idset)
1016 | otherwise -- Dump it
1017 = (ok_dbs, dump_dbs `snocBag` db, idEmptyIdSet (dump_idset `intersectIdSets` fvs)
1019 mk_dict_bind (dict, rhs, _) body = Let (NonRec dict rhs) body
1022 Given a type and value substitution, specUDs creates a specialised copy of
1026 specUDs tv_assoc id_assoc (MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls})
1027 = mapAccumLSM spec_bind
1029 (bagToList orig_dbs) `thenSM` \ ((tv_env', id_env'), new_dbs) ->
1031 subst_call call_info = listToFM [(map (instantiateTy ty_env') ts,
1032 map (lookupId id_env') call_ds)
1033 | (call_ts, call_ds) <- fmToList call_info
1036 MkUDs { fvs = substFVSet id_env orig_fvs,
1037 dictBinds = listToBag new_dbs,
1038 calls = mapFM orig_calls subst_call
1041 tv_env = mkTyVarEnv tv_assoc
1042 id_env = mkIdEnv id_assoc
1044 spec_bind (ty_env, id_env) (dict, rhs, fvs)
1045 = newIdSM dict spec_ty `thenSM` \ spec_dict ->
1046 returnSM ((ty_env, addOneToIdEnv id_env dict spec_dict), (spec_dict, spec_rhs))
1048 spec_ty = instantiateTy ty_env (idType dict)
1049 spec_rhs = instantiateDictRhs ty_env id_env rhs
1053 %************************************************************************
1055 \subsubsection{Boring helper functions}
1057 %************************************************************************
1060 substFVSet :: IdEnv Id -> IdSet -> IdSet
1061 substFVSet env s = mkIdSet [lookupId env id | id <- idSetToList s]
1063 lookupId:: IdEnv Id -> Id -> Id
1064 lookupId env id = case lookupIdEnv env id of
1068 instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
1069 -- Cheapo function for simple RHSs
1070 instantiateDictRhs ty_env id_env rhs
1073 go (App e1 (ValArg a)) = App (go e1) (ValArg (lookupId id_env a))
1074 go (App e1 (TyArg t)) = App (go e1) (TyArg (instantiateTy ty_env t))
1075 go (Var v) = Var (lookupId id_env v)
1078 dictRhsFVs :: CoreExpr -> IdSet
1079 -- Cheapo function for simple RHSs
1080 dictRhsFVs (App e1 (ValArg a)) = dictRhsFVs e1 `addOneToIdSet` a
1081 go (App e1 (TyArg t)) = dictRhsFVs e1
1082 go (Var v) = singletonIdSet v
1083 go (Lit l) = emptyIdSet
1085 mkLets [] body = body
1086 mkLets ((bndr,rhs):binds) body = Let (NonRec bndr rhs) (mkLets binds body)
1088 zipNothings [] [] = []
1089 zipNothings (Nothing : tys) (tyvar : tyvars) = mkTyVarTy tyvar : zipNothings tys tyvars
1090 zipNothings (Just ty : tys) tyvars = ty : zipNothings tys tyvars
1094 =========================== OLD STUFF =================================
1096 %************************************************************************
1098 \subsubsection[CallInstances]{@CallInstances@ data type}
1100 %************************************************************************
1103 type FreeVarsSet = IdSet
1104 type FreeTyVarsSet = TyVarSet
1108 Id -- This Id; *new* ie *cloned* id
1109 [Maybe Type] -- Specialised at these types (*new*, cloned)
1110 -- Nothing => no specialisation on this type arg
1111 -- is required (flag dependent).
1112 [CoreArg] -- And these dictionaries; all ValArgs
1113 FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
1114 (Maybe SpecInfo) -- For specialisation with explicit SpecId
1118 pprCI :: CallInstance -> Doc
1119 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
1120 = hang (hsep [ptext SLIT("Call inst for"), ppr id])
1121 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]),
1122 case maybe_specinfo of
1123 Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts])
1124 Just (SpecInfo _ _ spec_id)
1125 -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id]
1128 -- ToDo: instance Outputable CoreArg?
1129 ppr_arg (TyArg t) = ppr sty t
1130 ppr_arg (LitArg i) = ppr sty i
1131 ppr_arg (VarArg v) = ppr sty v
1133 isUnboxedCI :: CallInstance -> Bool
1134 isUnboxedCI (CallInstance _ spec_tys _ _ _)
1135 = any isUnboxedType (catMaybes spec_tys)
1137 isExplicitCI :: CallInstance -> Bool
1138 isExplicitCI (CallInstance _ _ _ _ (Just _))
1140 isExplicitCI (CallInstance _ _ _ _ Nothing)
1144 Comparisons are based on the {\em types}, ignoring the dictionary args:
1148 cmpCI :: CallInstance -> CallInstance -> Ordering
1149 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
1150 = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
1152 cmpCI_tys :: CallInstance -> CallInstance -> Ordering
1153 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
1154 = cmpUniTypeMaybeList tys1 tys2
1156 eqCI_tys :: CallInstance -> CallInstance -> Bool
1158 = case cmpCI_tys c1 c2 of { EQ -> True; other -> False }
1160 isCIofTheseIds :: [Id] -> CallInstance -> Bool
1161 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
1162 = any ((==) ci_id) ids
1164 singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
1165 singleCI id tys dicts
1166 = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
1167 emptyBag [] emptyIdSet 0 0
1169 fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
1171 explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
1172 explicitCI id tys specinfo
1173 = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
1175 call_inst = CallInstance id tys dicts fv_set (Just specinfo)
1176 dicts = panic "Specialise:explicitCI:dicts"
1177 fv_set = unitIdSet id
1179 -- We do not process the CIs for top-level dfuns or defms
1180 -- Instead we require an explicit SPEC inst pragma for dfuns
1181 -- and an explict method within any instances for the defms
1183 getCIids :: Bool -> [Id] -> [Id]
1184 getCIids True ids = filter not_dict_or_defm ids
1185 getCIids _ ids = ids
1188 = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
1190 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
1191 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
1193 (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
1194 cis_here_list = bagToList cis_here
1196 -- pprTrace "getCIs:"
1197 -- (hang (hcat [char '{',
1200 -- 4 (vcat (map pprCI cis_here_list)))
1201 (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
1203 dumpCIs :: Bag CallInstance -- The call instances
1204 -> Bool -- True <=> top level bound Ids
1205 -> Bool -- True <=> dict bindings to be floated (specBind only)
1206 -> [CallInstance] -- Call insts for bound ids (instBind only)
1207 -> [Id] -- Bound ids *new*
1208 -> [Id] -- Full bound ids: includes dumped dicts
1209 -> Bag CallInstance -- Kept call instances
1211 -- CIs are dumped if:
1212 -- 1) they are a CI for one of the bound ids, or
1213 -- 2) they mention any of the dicts in a local unfloated binding
1215 -- For top-level bindings we allow the call instances to
1216 -- float past a dict bind and place all the top-level binds
1217 -- in a *global* Rec.
1218 -- We leave it to the simplifier will sort it all out ...
1220 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
1221 = (if not (isEmptyBag cis_of_bound_id) &&
1222 not (isEmptyBag cis_of_bound_id_without_inst_cis)
1224 pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
1225 " (may be a non-HM recursive call)\n")
1226 (hang (hcat [char '{',
1227 interppSP bound_ids,
1229 4 (vcat [ptext SLIT("Dumping CIs:"),
1230 vcat (map pprCI (bagToList cis_of_bound_id)),
1231 ptext SLIT("Instantiating CIs:"),
1232 vcat (map pprCI inst_cis)]))
1234 if top_lev || floating then
1237 (if not (isEmptyBag cis_dump_unboxed)
1238 then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
1239 (hang (hcat [char '{',
1242 4 (vcat (map pprCI (bagToList cis_dump))))
1244 cis_keep_not_bound_id
1247 (cis_of_bound_id, cis_not_bound_id)
1248 = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
1250 (cis_dump, cis_keep_not_bound_id)
1251 = partitionBag ok_to_dump_ci cis_not_bound_id
1253 ok_to_dump_ci (CallInstance _ _ _ fv_set _)
1254 = any (\ i -> i `elementOfIdSet` fv_set) full_ids
1256 (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
1257 have_inst_ci ci = any (eqCI_tys ci) inst_cis
1259 (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
1263 Any call instances of a bound_id can be safely dumped, because any
1264 recursive calls should be at the same instance as the parent instance.
1266 letrec f = /\a -> \x::a -> ...(f t x')...
1268 Here, the type, t, at which f is used in its own RHS should be
1269 just "a"; that is, the recursive call is at the same type as
1270 the original call. That means that when specialising f at some
1271 type, say Int#, we shouldn't find any *new* instances of f
1272 arising from specialising f's RHS. The only instance we'll find
1273 is another call of (f Int#).
1275 We check this in dumpCIs by passing in all the instantiated call
1276 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
1277 for which there is no such instance.
1279 We also report CIs dumped due to a bound dictionary arg if they
1280 contain unboxed types.
1282 %************************************************************************
1284 \subsubsection[TyConInstances]{@TyConInstances@ data type}
1286 %************************************************************************
1290 = TyConInstance TyCon -- Type Constructor
1291 [Maybe Type] -- Applied to these specialising types
1293 cmpTyConI :: TyConInstance -> TyConInstance -> Ordering
1294 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
1295 = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
1297 cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering
1298 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
1299 = cmpUniTypeMaybeList tys1 tys2
1301 singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
1302 singleTyConI ty_con spec_tys
1303 = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
1305 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
1306 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = ty_con == inst_ty_con
1308 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
1309 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
1311 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
1312 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
1314 (tycon_cis_local, tycon_cis_global)
1315 = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
1316 tycon_cis_local_list = bagToList tycon_cis_local
1318 (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
1322 %************************************************************************
1324 \subsubsection[UsageDetails]{@UsageDetails@ data type}
1326 %************************************************************************
1331 (Bag CallInstance) -- The collection of call-instances
1332 (Bag TyConInstance) -- Constructor call-instances
1333 [DictBindDetails] -- Dictionary bindings in data-dependence order!
1334 FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
1335 Int -- no. of spec calls
1336 Int -- no. of spec insts
1339 The DictBindDetails are fully processed; their call-instance
1340 information is incorporated in the call-instances of the UsageDetails
1341 which includes the DictBindDetails. The free vars in a usage details
1342 will *include* the binders of the DictBind details.
1344 A @DictBindDetails@ contains bindings for dictionaries *only*.
1347 data DictBindDetails
1349 [Id] -- Main binders, originally visible in scope of binding (cloned)
1350 CoreBinding -- Fully processed
1351 FreeVarsSet -- Free in binding group (cloned)
1352 FreeTyVarsSet -- Free in binding group
1356 emptyUDs :: UsageDetails
1357 unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
1358 unionUDList :: [UsageDetails] -> UsageDetails
1360 -- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
1361 tickSpecInsts :: UsageDetails -> UsageDetails
1363 -- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
1364 -- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
1366 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
1367 = UsageDetails cis ty_cis dbs fvs c (i+1)
1369 emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
1371 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
1372 = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
1373 (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
1374 -- The append here is really redundant, since the bindings don't
1375 -- scope over each other. ToDo.
1377 unionUDList = foldr unionUDs emptyUDs
1379 singleFvUDs (VarArg v) | not (isImportedId v)
1380 = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
1384 singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
1386 dumpDBs :: [DictBindDetails]
1387 -> Bool -- True <=> top level bound Ids
1388 -> [TyVar] -- TyVars being bound (cloned)
1389 -> [Id] -- Ids being bound (cloned)
1390 -> FreeVarsSet -- Fvs of body
1391 -> ([CoreBinding], -- These ones have to go here
1392 [DictBindDetails], -- These can float further
1393 [Id], -- Incoming list + names of dicts bound here
1394 FreeVarsSet -- Incoming fvs + fvs of dicts bound here
1397 -- It is just to complex to try to float top-level
1398 -- dict bindings with constant methods, inst methods,
1399 -- auxillary derived instance defns and user instance
1400 -- defns all getting in the way.
1401 -- So we dump all dbinds as soon as we get to the top
1402 -- level and place them in a *global* Rec.
1403 -- We leave it to the simplifier will sort it all out ...
1405 dumpDBs [] top_lev bound_tyvars bound_ids fvs
1406 = ([], [], bound_ids, fvs)
1408 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
1409 top_lev bound_tyvars bound_ids fvs
1411 || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
1412 || any (\ t -> t `elementOfTyVarSet` db_ftv) bound_tyvars
1413 = let -- Ha! Dump it!
1414 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1415 = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
1417 (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1419 | otherwise -- This one can float out further
1421 (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
1422 = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
1424 (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
1428 dumpUDs :: UsageDetails
1429 -> Bool -- True <=> top level bound Ids
1430 -> Bool -- True <=> dict bindings to be floated (specBind only)
1431 -> [CallInstance] -- Call insts for bound Ids (instBind only)
1432 -> [Id] -- Ids which are just being bound; *new*
1433 -> [TyVar] -- TyVars which are just being bound
1434 -> ([CoreBinding], -- Bindings from UsageDetails which mention the ids
1435 UsageDetails) -- The above bindings removed, and
1436 -- any call-instances which mention the ids dumped too
1438 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
1440 (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
1441 = dumpDBs dbs top_lev tvs bound_ids fvs
1442 cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
1443 fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
1445 (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
1449 addDictBinds :: [Id] -> CoreBinding -> UsageDetails -- Dict binding and RHS usage
1450 -> UsageDetails -- The usage to augment
1452 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
1453 (UsageDetails cis tycon_cis dbs fvs c i)
1454 = UsageDetails (db_cis `unionBags` cis)
1455 (db_tycon_cis `unionBags` tycon_cis)
1456 (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
1458 -- NB: We ignore counts from dictbinds since it is not user code
1460 -- The free tyvars of the dictionary bindings should really be
1461 -- gotten from the RHSs, but I'm pretty sure it's good enough just
1462 -- to look at the type of the dictionary itself.
1463 -- Doing the proper job would entail keeping track of free tyvars as
1464 -- well as free vars, which would be a bore.
1465 db_ftvs = tyVarsOfTypes (map idType dbinders)
1468 %************************************************************************
1470 \subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
1472 %************************************************************************
1474 @SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
1476 1) (NoLift LitArg l) : an Id which is bound to a literal
1478 2) (NoLift LitArg l) : an Id bound to a "new" Id
1479 The new Id is a possibly-type-specialised clone of the original
1481 3) Lifted lifted_id unlifted_id :
1483 This indicates that the original Id has been specialised to an
1484 unboxed value which must be lifted (see "Unboxed bindings" above)
1485 @unlifted_id@ is the unboxed clone of the original Id
1486 @lifted_id@ is a *lifted* version of the original Id
1488 When you lookup Ids which are Lifted, you have to insert a case
1489 expression to un-lift the value (done with @bindUnlift@)
1491 You also have to insert a case to lift the value in the binding
1492 (done with @liftExpr@)
1496 type SpecIdEnv = IdEnv CloneInfo
1499 = NoLift CoreArg -- refers to cloned id or literal
1501 | Lifted Id -- lifted, cloned id
1502 Id -- unlifted, cloned id
1506 %************************************************************************
1508 \subsection[specialise-data]{Data returned by specialiser}
1510 %************************************************************************
1517 -- True <=> Specialisation performed
1519 -- False <=> Specialisation completed with errors
1522 -- Local tycons declared in this module
1525 -- Those in-scope data types for which we want to
1526 -- generate code for their constructors.
1527 -- Namely: data types declared in this module +
1528 -- any big tuples used in this module
1529 -- The initial (and default) value is the local tycons
1531 (FiniteMap TyCon [(Bool, [Maybe Type])])
1532 -- TyCon specialisations to be generated
1533 -- We generate specialialised code (Bool=True) for data types
1534 -- defined in this module and any tuples used in this module
1535 -- The initial (and default) value is the specialisations
1536 -- requested by source-level SPECIALIZE data pragmas (Bool=True)
1537 -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
1539 (Bag (Id,[Maybe Type]))
1540 -- Imported specialisation errors
1541 (Bag (Id,[Maybe Type]))
1542 -- Imported specialisation warnings
1543 (Bag (TyCon,[Maybe Type]))
1544 -- Imported TyCon specialisation errors
1546 initSpecData local_tycons tycon_specs
1547 = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
1552 ToDo[sansom]: Transformation data to process specialisation requests.
1554 %************************************************************************
1556 \subsection[specProgram]{Specialising a core program}
1558 %************************************************************************
1561 specProgram :: UniqSupply
1562 -> [CoreBinding] -- input ...
1564 -> ([CoreBinding], -- main result
1565 SpecialiseData) -- result specialise data
1567 specProgram uniqs binds
1568 (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
1569 = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
1570 (final_binds, tycon_specs_list,
1571 UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
1573 used_conids = filter isDataCon (uniqSetToList fvs)
1574 used_tycons = map dataConTyCon used_conids
1575 used_gen = filter isLocalGenTyCon used_tycons
1576 gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet used_gen)
1578 result_specs = addListToFM_C (++) init_specs tycon_specs_list
1580 uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
1581 cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
1582 (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
1583 cis_warn = init_warn `unionBags` listToBag cis_other
1584 cis_errs = init_errs `unionBags` listToBag cis_unboxed
1586 uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
1587 tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
1588 tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
1590 no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
1591 && (not opt_SpecialiseImports || isEmptyBag cis_warn)
1593 (if opt_D_simplifier_stats then
1594 pprTrace "\nSpecialiser Stats:\n" (vcat [
1595 hcat [ptext SLIT("SpecCalls "), int spec_calls],
1596 hcat [ptext SLIT("SpecInsts "), int spec_insts],
1601 SpecData True no_errs local_tycons gen_tycons result_specs
1602 cis_errs cis_warn tycis_errs)
1604 specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
1605 = panic "Specialise:specProgram: specialiser called more than once"
1607 -- It may be possible safely to call the specialiser more than once,
1608 -- but I am not sure there is any benefit in doing so (Patrick)
1610 -- ToDo: What about unfoldings performed after specialisation ???
1613 %************************************************************************
1615 \subsection[specTyConsAndScope]{Specialising data constructors within tycons}
1617 %************************************************************************
1619 In the specialiser we just collect up the specialisations which will
1620 be required. We don't create the specialised constructors in
1621 Core. These are only introduced when we convert to StgSyn.
1623 ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
1626 specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
1627 -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
1629 specTyConsAndScope scopeM
1630 = scopeM `thenSM` \ (binds, scope_uds) ->
1632 (tycons_cis, gotci_scope_uds)
1633 = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds
1635 tycon_specs_list = collectTyConSpecs tycons_cis
1637 (if opt_SpecialiseTrace && not (null tycon_specs_list) then
1638 pprTrace "Specialising TyCons:\n"
1639 (vcat [ if not (null specs) then
1640 hang (hsep [(ppr tycon), ptext SLIT("at types")])
1641 4 (vcat (map pp_specs specs))
1643 | (tycon, specs) <- tycon_specs_list])
1645 returnSM (binds, tycon_specs_list, gotci_scope_uds)
1648 collectTyConSpecs []
1650 collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
1651 = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
1653 (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
1654 uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
1655 tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
1657 pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys]
1661 %************************************************************************
1663 \subsection[specTopBinds]{Specialising top-level bindings}
1665 %************************************************************************
1668 specTopBinds :: [CoreBinding]
1669 -> SpecM ([CoreBinding], UsageDetails)
1672 = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
1674 -- Add bindings for floated dbinds and collect fvs
1675 -- In actual fact many of these bindings are dead code since dict
1676 -- arguments are dropped when a specialised call is created
1677 -- The simplifier should be able to cope ...
1679 (dbinders_s, dbinds, dfvs_s)
1680 = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
1682 full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
1683 fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
1685 -- It is just to complex to try to sort out top-level dependencies
1686 -- So we just place all the top-level binds in a *global* Rec and
1687 -- leave it to the simplifier to sort it all out ...
1690 returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
1693 spec_top_binds (first_bind:rest_binds)
1694 = specBindAndScope True first_bind (
1695 spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
1696 returnSM (ItsABinds rest_binds, rest_uds)
1697 ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
1698 returnSM (first_binds ++ rest_binds, all_uds)
1701 = returnSM ([], emptyUDs)
1704 %************************************************************************
1706 \subsection[specExpr]{Specialising expressions}
1708 %************************************************************************
1711 specExpr :: CoreExpr
1712 -> [CoreArg] -- The arguments:
1713 -- TypeArgs are speced
1714 -- ValArgs are unprocessed
1715 -> SpecM (CoreExpr, -- Result expression with specialised versions installed
1716 UsageDetails)-- Details of usage of enclosing binders in the result
1719 specExpr (Var v) args
1720 = specId v $ \ v_arg ->
1722 LitArg lit -> ASSERT( null args )
1723 returnSM (Lit lit, emptyUDs)
1725 VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds ->
1726 returnSM (mkGenApp (Var new_v) args, uds)
1728 specExpr expr@(Lit _) null_args
1729 = ASSERT (null null_args)
1730 returnSM (expr, emptyUDs)
1732 specExpr (Con con args) null_args
1733 = ASSERT (null null_args)
1734 specArgs args $ \ args' ->
1735 mkTyConInstance con args' `thenSM` \ con_uds ->
1736 returnSM (Con con args', con_uds)
1738 specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
1739 = ASSERT (null null_args)
1740 specArgs args $ \ args' ->
1741 mapSM specTy arg_tys `thenSM` \ arg_tys' ->
1742 specTy res_ty `thenSM` \ res_ty' ->
1743 returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs)
1745 specExpr (Prim prim args) null_args
1746 = ASSERT (null null_args)
1747 specArgs args $ \ args' ->
1748 -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
1749 returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
1753 specPrimOp :: PrimOp
1759 -- Checks that PrimOp can handle (possibly unboxed) tys passed
1760 -- and/or chooses PrimOp specialised to any unboxed tys
1761 -- Errors are dealt with by returning a PrimOp call instance
1762 -- which will result in a cis_errs message
1764 -- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
1768 specExpr (App fun arg) args
1769 = specArg arg `thenSM` \ new_arg ->
1770 specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
1771 returnSM (expr, uds)
1773 specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
1774 = lookup_arg arg `thenSM` \ arg ->
1775 bindId binder arg (specExpr body args)
1777 lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
1778 lookup_arg (VarArg v) = lookupId v
1780 specExpr (Lam (ValBinder binder) body) []
1781 = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
1782 returnSM (Lam (ValBinder binder) body, uds)
1784 specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
1785 = -- Type lambda with argument; argument already spec'd
1786 bindTyVar tyvar ty ( specExpr body args )
1788 specExpr (Lam (TyBinder tyvar) body) []
1790 cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
1791 bindTyVar tyvar (mkTyVarTy new_tyvar) (
1792 specExpr body [] `thenSM` \ (body, body_uds) ->
1794 (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
1796 returnSM (Lam (TyBinder new_tyvar)
1797 (mkCoLetsNoUnboxed binds_here body),
1801 specExpr (Case scrutinee alts) args
1802 = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
1803 specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
1804 returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
1806 scrutinee_type = coreExprType scrutinee
1808 specExpr (Let bind body) args
1809 = specBindAndScope False bind (
1810 specExpr body args `thenSM` \ (body, body_uds) ->
1811 returnSM (ItsAnExpr body, body_uds)
1812 ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
1813 returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
1815 specExpr (SCC cc expr) args
1816 = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
1817 mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
1820 = if squashableDictishCcExpr cc expr -- can toss the _scc_
1824 returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
1825 unionUDList args_uds_s `unionUDs` expr_uds)
1827 specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
1829 -- ToDo: This may leave some unspec'd dictionaries!!
1832 %************************************************************************
1834 \subsubsection{Specialising a lambda}
1836 %************************************************************************
1839 specLambdaOrCaseBody :: [Id] -- The binders
1840 -> CoreExpr -- The body
1841 -> [CoreArg] -- Its args
1842 -> SpecM ([Id], -- New binders
1843 CoreExpr, -- New body
1846 specLambdaOrCaseBody bound_ids body args
1847 = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
1848 bindIds bound_ids clone_infos (
1850 specExpr body args `thenSM` \ (body, body_uds) ->
1853 -- Dump any dictionary bindings (and call instances)
1854 -- from the scope which mention things bound here
1855 (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
1857 returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
1860 -- ToDo: Opportunity here to common-up dictionaries with same type,
1861 -- thus avoiding recomputation.
1864 A variable bound in a lambda or case is normally monomorphic so no
1865 specialised versions will be required. This is just as well since we
1866 do not know what code to specialise!
1868 Unfortunately this is not always the case. For example a class Foo
1869 with polymorphic methods gives rise to a dictionary with polymorphic
1870 components as follows:
1877 instance Foo Int where
1885 d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
1886 d.Foo.Int = (op1_Int, op2_Int)
1888 op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
1890 ... op1 {Int Int#} d.Foo.Int 1 3# ...
1893 N.B. The type of the dictionary is not Hindley Milner!
1895 Now we must specialise op1 at {* Int#} which requires a version of
1896 meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
1897 not have access to its code to create the specialised version.
1899 If we specialise on overloaded types as well we specialise op1 at
1900 {Int Int#} d.Foo.Int:
1902 op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
1904 Though this is still invalid, after further simplification we get:
1906 op1_Int_Int# = opInt1 {Int#}
1908 Another round of specialisation will result in the specialised
1909 version of op1Int being called directly.
1911 For now we PANIC if a polymorphic lambda/case bound variable is found
1912 in a call instance with an unboxed type. Other call instances, arising
1913 from overloaded type arguments, are discarded since the unspecialised
1914 version extracted from the method can be called as normal.
1916 ToDo: Implement and test second round of specialisation.
1919 %************************************************************************
1921 \subsubsection{Specialising case alternatives}
1923 %************************************************************************
1927 specAlts (AlgAlts alts deflt) scrutinee_ty args
1928 = mapSM specTy ty_args `thenSM` \ ty_args ->
1929 mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
1930 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1931 returnSM (AlgAlts alts deflt,
1932 unionUDList alts_uds_s `unionUDs` deflt_uds)
1934 -- We use ty_args of scrutinee type to identify specialisation of
1937 (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
1938 splitAlgTyConApp scrutinee_ty
1940 specAlgAlt ty_args (con,binders,rhs)
1941 = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
1942 mkTyConInstance con ty_args `thenSM` \ con_uds ->
1943 returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
1945 specAlts (PrimAlts alts deflt) scrutinee_ty args
1946 = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
1947 specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
1948 returnSM (PrimAlts alts deflt,
1949 unionUDList alts_uds_s `unionUDs` deflt_uds)
1951 specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
1952 returnSM ((lit,rhs), uds)
1955 specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
1956 specDeflt (BindDefault binder rhs) args
1957 = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
1958 returnSM (BindDefault binder rhs, uds)
1962 %************************************************************************
1964 \subsubsection{Specialising an atom}
1966 %************************************************************************
1969 partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
1971 = span is_ty_arg args
1973 is_ty_arg (TyArg _) = True
1978 -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
1979 -> SpecM (CoreExpr, UsageDetails)
1981 = lookupId v `thenSM` \ vlookup ->
1985 -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) ->
1986 returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
1989 -> thing_inside vatom `thenSM` \ (expr, uds) ->
1990 returnSM (expr, singleFvUDs vatom `unionUDs` uds)
1993 -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
1994 -> SpecM (CoreExpr, UsageDetails))
1996 specArg (TyArg ty) thing_inside
1997 = specTy ty `thenSM` \ new_ty ->
1998 thing_inside (TyArg new_ty)
2000 specArg (LitArg lit)
2001 = thing_inside (LitArg lit)
2006 specArgs [] thing_inside
2009 specArgs (arg:args) thing_inside
2010 = specArg arg $ \ arg' ->
2011 specArgs args $ \ args' ->
2012 thing_inside (arg' : args')
2016 %************************************************************************
2018 \subsubsection{Specialising bindings}
2020 %************************************************************************
2022 A classic case of when having a polymorphic recursive function would help!
2025 data BindsOrExpr = ItsABinds [CoreBinding]
2026 | ItsAnExpr CoreExpr
2031 :: Bool -- True <=> a top level group
2032 -> CoreBinding -- As yet unprocessed
2033 -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
2034 -> SpecM ([CoreBinding], -- Processed
2035 BindsOrExpr, -- Combined result
2036 UsageDetails) -- Usage details of the whole lot
2038 specBindAndScope top_lev bind scopeM
2039 = cloneLetBinders top_lev (is_rec bind) binders
2040 `thenSM` \ (new_binders, clone_infos) ->
2042 -- Two cases now: either this is a bunch of local dictionaries,
2043 -- in which case we float them; or its a bunch of other values,
2044 -- in which case we see if they correspond to any call-instances
2045 -- we have from processing the scope
2047 if not top_lev && all (isDictTy . idType) binders
2049 -- Ha! A group of local dictionary bindings
2051 bindIds binders clone_infos (
2053 -- Process the dictionary bindings themselves
2054 specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
2056 -- Process their scope
2057 scopeM `thenSM` \ (thing, scope_uds) ->
2059 -- Add the bindings to the current stuff
2060 final_uds = addDictBinds new_binders bind rhs_uds scope_uds
2062 returnSM ([], thing, final_uds)
2065 -- Ho! A group of bindings
2067 fixSM (\ ~(_, _, _, rec_spec_infos) ->
2069 bindSpecIds binders clone_infos rec_spec_infos (
2070 -- It's ok to have new binders in scope in
2071 -- non-recursive decls too, cos name shadowing is gone by now
2073 -- Do the scope of the bindings
2074 scopeM `thenSM` \ (thing, scope_uds) ->
2076 (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
2078 equiv_ciss = equivClasses cmpCI_tys call_insts
2079 inst_cis = map head equiv_ciss
2082 -- Do the bindings themselves
2083 specBind top_lev False new_binders inst_cis bind
2084 `thenSM` \ (spec_bind, spec_uds) ->
2086 -- Create any necessary instances
2087 instBind top_lev new_binders bind equiv_ciss inst_cis
2088 `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
2091 -- NB: dumpUDs only worries about new_binders since the free var
2092 -- stuff only records free new_binders
2093 -- The spec_ids only appear in SpecInfos and final speced calls
2095 -- Build final binding group and usage details
2096 (final_binds, final_uds)
2098 -- For a top-level binding we have to dumpUDs from
2099 -- spec_uds and inst_uds and scope_uds creating
2100 -- *global* dict bindings
2102 (scope_dict_binds, final_scope_uds)
2103 = dumpUDs gotci_scope_uds True False [] new_binders []
2104 (spec_dict_binds, final_spec_uds)
2105 = dumpUDs spec_uds True False inst_cis new_binders []
2106 (inst_dict_binds, final_inst_uds)
2107 = dumpUDs inst_uds True False inst_cis new_binders []
2109 ([spec_bind] ++ inst_binds ++ scope_dict_binds
2110 ++ spec_dict_binds ++ inst_dict_binds,
2111 final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
2113 -- For a local binding we only have to dumpUDs from
2114 -- scope_uds since the UDs from spec_uds and inst_uds
2115 -- have already been dumped by specBind and instBind
2117 (scope_dict_binds, final_scope_uds)
2118 = dumpUDs gotci_scope_uds False False [] new_binders []
2120 ([spec_bind] ++ inst_binds ++ scope_dict_binds,
2121 spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
2123 -- inst_uds comes last, because there may be dict bindings
2124 -- floating outward in scope_uds which are mentioned
2125 -- in the call-instances, and hence in spec_uds.
2126 -- This ordering makes sure that the precedence order
2127 -- among the dict bindings finally floated out is maintained.
2129 returnSM (final_binds, thing, final_uds, spec_infos)
2131 ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
2132 returnSM (binds, thing, final_uds)
2134 binders = bindersOf bind
2136 is_rec (NonRec _ _) = False
2141 specBind :: Bool -> Bool -> [Id] -> [CallInstance]
2143 -> SpecM (CoreBinding, UsageDetails)
2144 -- The UsageDetails returned has already had stuff to do with this group
2145 -- of binders deleted; that's why new_binders is passed in.
2146 specBind top_lev floating new_binders inst_cis (NonRec binder rhs)
2147 = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
2148 `thenSM` \ ((binder,rhs), rhs_uds) ->
2149 returnSM (NonRec binder rhs, rhs_uds)
2151 specBind top_lev floating new_binders inst_cis (Rec pairs)
2152 = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
2153 `thenSM` \ (pairs, rhs_uds_s) ->
2154 returnSM (Rec pairs, unionUDList rhs_uds_s)
2157 specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
2159 -> SpecM ((Id,CoreExpr), UsageDetails)
2161 specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
2162 = lookupId binder `thenSM` \ blookup ->
2163 specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
2165 specid_maybe_maybe = isSpecPragmaId_maybe binder
2166 is_specid = maybeToBool specid_maybe_maybe
2167 Just specinfo_maybe = specid_maybe_maybe
2168 specid_with_info = maybeToBool specinfo_maybe
2169 Just spec_info = specinfo_maybe
2171 -- If we have a SpecInfo stored in a SpecPragmaId binder
2172 -- it will contain a SpecInfo with an explicit SpecId
2173 -- We add the explicit ci to the usage details
2174 -- Any ordinary cis for orig_id (there should only be one)
2175 -- will be ignored later
2178 = if is_specid && specid_with_info then
2180 (SpecInfo spec_tys _ spec_id) = spec_info
2181 Just (orig_id, _) = isSpecId_maybe spec_id
2183 ASSERT(toplevelishId orig_id) -- must not be cloned!
2184 explicitCI orig_id spec_tys spec_info
2188 -- For a local binding we dump the usage details, creating
2189 -- any local dict bindings required
2190 -- At the top-level the uds will be dumped in specBindAndScope
2191 -- and the dict bindings made *global*
2193 (local_dict_binds, final_uds)
2194 = if not top_lev then
2195 dumpUDs rhs_uds False floating inst_cis new_binders []
2200 Lifted lift_binder unlift_binder
2201 -> -- We may need to record an unboxed instance of
2202 -- the _Lift data type in the usage details
2203 mkTyConInstance liftDataCon [idType unlift_binder]
2204 `thenSM` \ lift_uds ->
2205 returnSM ((lift_binder,
2206 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
2207 final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
2209 NoLift (VarArg binder)
2210 -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
2211 final_uds `unionUDs` pragma_uds)
2215 %************************************************************************
2217 \subsection{@instBind@}
2219 %************************************************************************
2222 instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
2224 = returnSM ([], emptyUDs, [])
2226 | all same_overloading other_binders
2227 = -- For each call_inst, build an instance
2228 mapAndUnzip3SM do_this_class equiv_ciss
2229 `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
2231 -- Add in the remaining UDs
2232 returnSM (catMaybes inst_binds,
2233 unionUDList inst_uds_s,
2237 | otherwise -- Incompatible overloadings; see below by same_overloading
2238 = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
2239 then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
2241 then pprTrace "dumpCIs: not same overloading ... top level \n"
2243 ) (hang (hcat [ptext SLIT("{"),
2246 4 (vcat [vcat (map (pprGenType . idType) new_ids),
2247 vcat (map pprCI (concat equiv_ciss))]))
2248 (returnSM ([], emptyUDs, []))
2251 (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
2252 tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
2254 no_of_tyvars = length tyvar_tmpls
2255 no_of_dicts = length class_tyvar_pairs
2257 do_this_class equiv_cis
2258 = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
2260 (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
2261 do_cis = head (normal_cis ++ explicit_cis)
2262 -- must choose a normal_cis in preference since dict_args will
2263 -- not be defined for an explicit_cis
2265 -- same_overloading tests whether the types of all the binders
2266 -- are "compatible"; ie have the same type and dictionary abstractions
2267 -- Almost always this is the case, because a recursive group is abstracted
2268 -- all together. But, it can happen that it ain't the case, because of
2269 -- code generated from instance decls:
2272 -- dfun.Foo.Int :: (forall a. a -> Int, Int)
2273 -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
2275 -- const.op1.Int :: forall a. a -> Int
2276 -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
2278 -- const.op2.Int :: Int
2279 -- const.op2.Int = 3
2281 -- Note that the first two defns have different polymorphism, but they are
2282 -- mutually recursive!
2284 same_overloading :: Id -> Bool
2286 = no_of_tyvars == length this_id_tyvars
2287 -- Same no of tyvars
2288 && no_of_dicts == length this_id_class_tyvar_pairs
2289 -- Same no of vdicts
2290 && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
2291 && length class_tyvar_pairs == length this_id_class_tyvar_pairs
2294 (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
2295 tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
2297 same_ov (clas1,tyvar1) (clas2,tyvar2)
2299 tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
2303 - a call instance eg f [t1,t2,t3] [d1,d2]
2304 - the rhs of the function eg orig_rhs
2305 - a constraint vector, saying which of eg [T,F,T]
2306 the functions type args are constrained
2309 We return a new definition
2311 $f1 = /\a -> orig_rhs t1 a t3 d1 d2
2313 The SpecInfo for f will be:
2315 SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
2317 Based on this SpecInfo, a call instance of f
2321 should get replaced by
2323 ...(\d1 d2 -> $f1 t2)...
2325 (But that is the business of the simplifier.)
2328 mkOneInst :: CallInstance
2329 -> [CallInstance] -- Any explicit cis for this inst
2330 -> Int -- No of dicts to specialise
2331 -> Bool -- Top level binders?
2332 -> [CallInstance] -- Instantiated call insts for binders
2333 -> [Id] -- New binders
2334 -> CoreBinding -- Unprocessed
2335 -> SpecM (Maybe CoreBinding, -- Instantiated version of input
2337 [Maybe SpecInfo] -- One for each id in the original binding
2340 mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
2341 no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
2342 = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
2343 `thenSM` \ spec_ids ->
2344 newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
2346 -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
2347 -- which correspond to unspecialised args
2349 (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
2352 args = map TyArg arg_tys ++ dict_args
2354 (new_id:_) = new_ids
2355 (spec_id:_) = spec_ids
2357 do_bind (NonRec orig_id rhs)
2358 = do_one_rhs (spec_id, new_id, (orig_id,rhs))
2359 `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
2361 Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
2362 Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
2365 = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
2366 `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
2367 returnSM (Just (Rec (catMaybes maybe_pairs)),
2368 unionUDList rhss_uds_s, spec_infos)
2370 do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
2372 -- Avoid duplicating a spec which has already been created ...
2373 -- This can arise in a Rec involving a dfun for which a
2374 -- a specialised instance has been created but specialisation
2375 -- "required" by one of the other Ids in the Rec
2376 | top_lev && maybeToBool lookup_orig_spec
2377 = (if opt_SpecialiseTrace
2378 then trace_nospec " Exists: " orig_id
2381 returnSM (Nothing, emptyUDs, Nothing)
2384 -- Check for a (single) explicit call instance for this id
2385 | not (null explicit_cis_for_this_id)
2386 = ASSERT (length explicit_cis_for_this_id == 1)
2387 (if opt_SpecialiseTrace
2388 then trace_nospec " Explicit: " explicit_id
2391 returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
2394 -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
2396 = ASSERT (no_of_dicts_to_specialise == length dict_args)
2397 specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
2399 -- For a local binding we dump the usage details, creating
2400 -- any local dict bindings required
2401 -- At the top-level the uds will be dumped in specBindAndScope
2402 -- and the dict bindings made *global*
2404 (local_dict_binds, final_uds)
2405 = if not top_lev then
2406 dumpUDs inst_uds False False inst_cis new_ids []
2410 spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
2412 if isUnboxedType (idType spec_id) then
2413 ASSERT (null poly_tyvars)
2414 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2415 mkTyConInstance liftDataCon [idType unlift_spec_id]
2416 `thenSM` \ lift_uds ->
2417 returnSM (Just (lift_spec_id,
2418 mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
2419 tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
2421 returnSM (Just (spec_id,
2422 mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
2423 tickSpecInsts final_uds, spec_info)
2425 lookup_orig_spec = matchSpecEnv (getIdSpecialisation orig_id) arg_tys
2427 explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
2428 [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
2429 SpecInfo _ _ explicit_id = explicit_spec_info
2431 trace_nospec :: String -> Id -> a -> a
2432 trace_nospec str spec_id
2434 (hsep [ppr new_id, hsep (map pp_ty arg_tys),
2435 ptext SLIT("==>"), ppr spec_id])
2437 (if opt_SpecialiseTrace then
2438 pprTrace "Specialising:"
2439 (hang (hcat [char '{',
2443 hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)],
2444 if isExplicitCI do_cis then empty else
2445 hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)],
2446 hcat [ptext SLIT("specs: "), ppr spec_ids]]))
2449 do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
2451 returnSM (maybe_inst_bind, inst_uds, spec_infos)
2454 pp_dict d = ppr_arg d
2455 pp_ty t = pprParendGenType t
2457 do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
2458 do_the_wotsit tyvars (Just ty) = (tyvars, ty)
2462 %************************************************************************
2464 \subsection[Misc]{Miscellaneous junk}
2466 %************************************************************************
2469 mkCallInstance :: Id
2472 -> SpecM UsageDetails
2474 mkCallInstance id new_id args
2475 | null args || -- No args at all
2476 idWantsToBeINLINEd id || -- It's going to be inlined anyway
2477 not enough_args || -- Not enough type and dict args
2478 not interesting_overloading -- Overloaded types are just tyvars
2482 = returnSM (singleCI new_id spec_tys dicts)
2485 (tyvars, theta, _) = splitSigmaTy (idType id)
2486 constrained_tyvars = tyvarsOfTypes (map snd class_tyvar_pairs)
2488 arg_res = take_type_args tyvars class_tyvar_pairs args
2489 enough_args = maybeToBool arg_res
2490 (Just (tys, dicts, rest_args)) = arg_res
2492 interesting_overloading = not (null (catMaybes spec_tys))
2493 spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys
2495 ---------------------------------------------------------------
2496 -- Should we specialise on this type argument?
2497 spec_ty tyvar ty | isTyVarTy ty = Nothing
2499 spec_ty tyvar ty | opt_SpecialiseAll
2500 || (opt_SpecialiseUnboxed
2502 && isBoxedTypeKind (tyVarKind tyvar))
2503 || (opt_SpecialiseOverloaded
2504 && tyvar `elemTyVarSet` constrained_tyvars)
2507 | otherwise = Nothing
2509 ----------------- Rather a gruesome help-function ---------------
2510 take_type_args (_:tyvars) (TyArg ty : args)
2511 = case (take_type_args tyvars args) of
2513 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
2515 take_type_args (_:tyvars) [] = Nothing
2517 take_type_args [] args
2518 = case (take_dict_args class_tyvar_pairs args) of
2520 Just (dicts, others) -> Just ([], dicts, others)
2522 take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict
2523 = case (take_dict_args class_tyvar_pairs args) of
2525 Just (dicts, others) -> Just (dict:dicts, others)
2527 take_dict_args (_:class_tyvar_pairs) args = Nothing
2529 take_dict_args [] args = Just ([], args)
2534 mkTyConInstance :: Id
2536 -> SpecM UsageDetails
2537 mkTyConInstance con tys
2538 = recordTyConInst con tys `thenSM` \ record_inst ->
2540 Nothing -- No TyCon instance
2541 -> -- pprTrace "NoTyConInst:"
2542 -- (hsep [ppr tycon, ptext SLIT("at"),
2543 -- ppr con, hsep (map (ppr) tys)])
2544 (returnSM (singleConUDs con))
2546 Just spec_tys -- Record TyCon instance
2547 -> -- pprTrace "TyConInst:"
2548 -- (hsep [ppr tycon, ptext SLIT("at"),
2549 -- ppr con, hsep (map (ppr) tys),
2551 -- hsep [pprMaybeTy ty | ty <- spec_tys],
2553 (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
2555 tycon = dataConTyCon con
2559 recordTyConInst :: Id
2561 -> SpecM (Maybe [Maybe Type])
2563 recordTyConInst con tys
2565 spec_tys = specialiseConstrTys tys
2567 do_tycon_spec = maybeToBool (firstJust spec_tys)
2569 spec_exists = maybeToBool (lookupSpecEnv
2570 (getIdSpecialisation con)
2573 -- pprTrace "ConSpecExists?: "
2574 -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")),
2575 -- ppr PprShowAll con, hsep (map ppr tys)])
2576 (if (not spec_exists && do_tycon_spec)
2577 then returnSM (Just spec_tys)
2578 else returnSM Nothing)
2581 %************************************************************************
2583 \subsection[monad-Specialise]{Monad used in specialisation}
2585 %************************************************************************
2589 inherited: control flags and
2590 recordInst functions with flags cached
2592 environment mapping tyvars to types
2593 environment mapping Ids to Atoms
2595 threaded in and out: unique supply
2598 type TypeEnv = TyVarEnv Type
2606 initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs
2608 returnSM :: a -> SpecM a
2609 thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
2610 fixSM :: (a -> SpecM a) -> SpecM a
2612 thenSM m k tvenv idenv us
2613 = case splitUniqSupply us of { (s1, s2) ->
2614 case (m tvenv idenv s1) of { r ->
2615 k r tvenv idenv s2 }}
2617 returnSM r tvenv idenv us = r
2619 fixSM k tvenv idenv us
2622 r = k r tvenv idenv us -- Recursive in r!
2625 The only interesting bit is figuring out the type of the SpecId!
2628 newSpecIds :: [Id] -- The id of which to make a specialised version
2629 -> [Maybe Type] -- Specialise to these types
2630 -> Int -- No of dicts to specialise
2633 newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
2634 = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
2635 | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
2637 uniqs = getUniques (length new_ids) us
2638 spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
2640 newTyVars :: Int -> SpecM [TyVar]
2641 newTyVars n tvenv idenv us
2642 = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
2645 @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
2646 binders, and build ``clones'' for them. The clones differ from the
2647 originals in three ways:
2649 (a) they have a fresh unique
2650 (b) they have the current type environment applied to their type
2651 (c) for Let binders which have been specialised to unboxed values
2652 the clone will have a lifted type
2654 As well as returning the list of cloned @Id@s they also return a list of
2655 @CloneInfo@s which the original binders should be bound to.
2658 cloneLambdaOrCaseBinders :: [Id] -- Old binders
2659 -> SpecM ([Id], [CloneInfo]) -- New ones
2661 cloneLambdaOrCaseBinders old_ids tvenv idenv us
2663 uniqs = getUniques (length old_ids) us
2665 unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
2667 clone_it old_id uniq
2668 = (new_id, NoLift (VarArg new_id))
2670 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
2672 cloneLetBinders :: Bool -- Top level ?
2673 -> Bool -- Recursice
2674 -> [Id] -- Old binders
2675 -> SpecM ([Id], [CloneInfo]) -- New ones
2677 cloneLetBinders top_lev is_rec old_ids tvenv idenv us
2679 uniqs = getUniques (2 * length old_ids) us
2681 unzip (clone_them old_ids uniqs)
2683 clone_them [] [] = []
2685 clone_them (old_id:olds) (u1:u2:uniqs)
2688 NoLift (VarArg old_id)) : clone_rest
2690 -- Don't clone if it is a top-level thing. Why not?
2691 -- (a) we don't want to change the uniques
2693 -- (b) we don't have to be paranoid about name capture
2694 -- (c) the thing is polymorphic so no need to subst
2697 = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
2699 Lifted lifted_id unlifted_id) : clone_rest
2701 NoLift (VarArg new_id)) : clone_rest
2704 clone_rest = clone_them olds uniqs
2706 new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
2707 new_ty = idType new_id
2708 old_ty = idType old_id
2710 (lifted_id, unlifted_id) = mkLiftedId new_id u2
2713 cloneTyVarSM :: TyVar -> SpecM TyVar
2715 cloneTyVarSM old_tyvar tvenv idenv us
2719 cloneTyVar old_tyvar uniq -- new_tyvar
2721 bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
2723 bindId id val specm tvenv idenv us
2724 = specm tvenv (addOneToIdEnv idenv id val) us
2726 bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
2728 bindIds olds news specm tvenv idenv us
2729 = specm tvenv (growIdEnvList idenv (zip olds news)) us
2731 bindSpecIds :: [Id] -- Old
2732 -> [(CloneInfo)] -- New
2733 -> [[Maybe SpecInfo]] -- Corresponding specialisations
2734 -- Each sub-list corresponds to a different type,
2735 -- and contains one Maybe spec_info for each id
2739 bindSpecIds olds clones spec_infos specm tvenv idenv us
2740 = specm tvenv (growIdEnvList idenv old_to_clone) us
2742 old_to_clone = mk_old_to_clone olds clones spec_infos
2744 -- The important thing here is that we are *lazy* in spec_infos
2745 mk_old_to_clone [] [] _ = []
2746 mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
2747 = (old, add_spec_info clone) :
2748 mk_old_to_clone rest_olds rest_clones spec_infos_rest
2750 add_spec_info (NoLift (VarArg new))
2751 = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)))
2752 add_spec_info lifted
2753 = lifted -- no specialised instances for unboxed lifted values
2755 spec_infos_this_id = catMaybes (map head spec_infos)
2756 spec_infos_rest = map tail spec_infos
2759 bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
2761 bindTyVar tyvar ty specm tvenv idenv us
2762 = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
2766 lookupId :: Id -> SpecM CloneInfo
2768 lookupId id tvenv idenv us
2769 = case lookupIdEnv idenv id of
2770 Nothing -> NoLift (VarArg id)
2775 specTy :: Type -> SpecM Type -- Apply the current type envt to the type
2777 specTy ty tvenv idenv us
2778 = instantiateTy tvenv ty
2782 liftId :: Id -> SpecM (Id, Id)
2783 liftId id tvenv idenv us
2790 In other monads these @mapSM@ things are usually called @listM@.
2791 I think @mapSM@ is a much better name. The `2' and `3' variants are
2792 when you want to return two or three results, and get at them
2793 separately. It saves you having to do an (unzip stuff) right after.
2796 mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
2797 mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
2798 mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
2799 mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
2801 mapSM f [] = returnSM []
2802 mapSM f (x:xs) = f x `thenSM` \ r ->
2803 mapSM f xs `thenSM` \ rs ->
2806 mapAndUnzipSM f [] = returnSM ([],[])
2807 mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
2808 mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
2809 returnSM ((r1:rs1),(r2:rs2))
2811 mapAndUnzip3SM f [] = returnSM ([],[],[])
2812 mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
2813 mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
2814 returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
2816 mapAndUnzip4SM f [] = returnSM ([],[],[],[])
2817 mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
2818 mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
2819 returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
2825 ===================== OLD CODE, scheduled for deletion =================
2830 -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
2833 mkCall new_id arg_infos = returnSM (
2835 | maybeToBool (isSuperDictSelId_maybe new_id)
2836 && any isUnboxedType ty_args
2837 -- No specialisations for super-dict selectors
2838 -- Specialise unboxed calls to SuperDictSelIds by extracting
2839 -- the super class dictionary directly form the super class
2840 -- NB: This should be dead code since all uses of this dictionary should
2841 -- have been specialised. We only do this to keep core-lint happy.
2843 Just (_, super_class) = isSuperDictSelId_maybe new_id
2844 super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
2845 Nothing -> panic "Specialise:mkCall:SuperDictId"
2848 returnSM (False, Var super_dict_id)
2851 = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
2852 Nothing -> checkUnspecOK new_id ty_args (
2853 returnSM (False, unspec_call)
2856 Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
2858 -- It may be necessary to specialsie a constant method spec_id again
2859 (spec_id, tys_left, dicts_to_toss) =
2860 case (maybeToBool (isConstMethodId_maybe spec_id_1),
2861 lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
2862 (False, _ ) -> spec_1_details
2863 (True, Nothing) -> spec_1_details
2864 (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
2865 -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
2867 args_left = toss_dicts dicts_to_toss val_args
2869 checkSpecOK new_id ty_args spec_id tys_left (
2871 -- The resulting spec_id may be a top-level unboxed value
2872 -- This can arise for:
2873 -- 1) constant method values
2874 -- eq: class Num a where pi :: a
2875 -- instance Num Double# where pi = 3.141#
2876 -- 2) specilised overloaded values
2877 -- eq: i1 :: Num a => a
2878 -- i1 Int# d.Num.Int# ==> i1.Int#
2879 -- These top level defns should have been lifted.
2880 -- We must add code to unlift such a spec_id.
2882 if isUnboxedType (idType spec_id) then
2883 ASSERT (null tys_left && null args_left)
2884 if toplevelishId spec_id then
2885 liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
2886 returnSM (True, bindUnlift lift_spec_id unlift_spec_id
2887 (Var unlift_spec_id))
2889 pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
2891 hsep (map (pprParendGenType) ty_args),
2896 (vals_left, _, unlifts_left) = unzip3 args_left
2897 applied_tys = mkTyApp (Var spec_id) tys_left
2898 applied_vals = mkGenApp applied_tys vals_left
2900 returnSM (True, applyBindUnlifts unlifts_left applied_vals)
2903 (tys_and_vals, _, unlifts) = unzip3 args
2904 unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
2907 -- ty_args is the types at the front of the arg list
2908 -- val_args is the rest of the arg-list
2910 (ty_args, val_args) = get args
2912 get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
2913 get args = ([], args)
2916 -- toss_dicts chucks away dict args, checking that they ain't types!
2917 toss_dicts 0 args = args
2918 toss_dicts n ((a,_,_) : args)
2919 | isValArg a = toss_dicts (n-1) args
2924 checkUnspecOK :: Id -> [Type] -> a -> a
2925 checkUnspecOK check_id tys
2926 = if isLocallyDefined check_id && any isUnboxedType tys
2927 then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
2928 (hsep [ppr check_id,
2929 hsep (map (pprParendGenType) tys)])
2932 checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
2933 checkSpecOK check_id tys spec_id tys_left
2934 = if any isUnboxedType tys_left
2935 then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
2936 (vcat [hsep [ppr check_id,
2937 hsep (map (pprParendGenType) tys)],
2939 hsep (map (pprParendGenType) tys_left)]])