%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-#include "HsVersions.h"
-
-module Specialise (
- specProgram,
- initSpecData,
-
- SpecialiseData(..),
- FiniteMap, Bag
-
- ) where
+module Specialise ( specProgram ) where
-import PlainCore
-import SpecTyFuns
-
-IMPORT_Trace
-import Outputable -- ToDo: these may be removable...
-import Pretty
+#include "HsVersions.h"
-import AbsPrel ( liftDataCon, PrimOp(..), PrimKind -- for CCallOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import CmdLineOpts ( DynFlags, DynFlag(..) )
+import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
+import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
+ tyVarsOfTypes, tyVarsOfTheta,
+ mkForAllTys, tcCmpType
)
-import AbsUniType
-import Bag
-import CmdLineOpts ( GlobalSwitch(..) )
-import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
+import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
+ simplBndr, simplBndrs,
+ substAndCloneId, substAndCloneIds, substAndCloneRecIds,
+ lookupIdSubst, substInScope
+ )
+import Var ( zapSpecPragmaId )
+import VarSet
+import VarEnv
+import CoreSyn
+import CoreUtils ( applyTypeToArgs )
+import CoreFVs ( exprFreeVars, exprsFreeVars )
+import CoreTidy ( pprTidyIdRules )
+import CoreLint ( showPass, endPass )
+import Rules ( addIdSpecialisations, lookupRule )
+
+import UniqSupply ( UniqSupply,
+ UniqSM, initUs_, thenUs, returnUs, getUniqueUs,
+ getUs, mapUs
+ )
+import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Id
-import IdEnv
-import IdInfo -- All of it
-import InstEnv ( lookupClassInstAtSimpleType )
-import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) )
-import TyVarEnv -- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) )
-import UniqSet -- All of it
-import Util
-import SplitUniq
+import Maybes ( catMaybes, maybeToBool )
+import ErrUtils ( dumpIfSet_dyn )
+import BasicTypes ( Activation( AlwaysActive ) )
+import Bag
+import List ( partition )
+import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
+ equalLength, lengthAtLeast, notNull )
+import Outputable
+
infixr 9 `thenSM`
\end{code}
%************************************************************************
These notes describe how we implement specialisation to eliminate
-overloading, and optionally to eliminate unboxed polymorphism, and
-full polymorphism.
+overloading.
-The specialisation pass is a partial evaluator which works on Core
+The specialisation pass works on Core
syntax, complete with all the explicit dictionary application,
abstraction and construction as added by the type checker. The
existing type checker remains largely as it is.
let f = <f_rhs>
in <body>
-and suppose f is overloaded.
+and suppose f is overloaded.
STEP 1: CALL-INSTANCE COLLECTION
then I think it's unlikely. In any case, we simply don't accumulate such
partial applications.)
-There's a choice of whether to collect details of all *polymorphic* functions
-or simply all *overloaded* ones. How to sort this out?
- Pass in a predicate on the function to say if it is "interesting"?
- This is dependent on the user flags: SpecialiseOverloaded
- SpecialiseUnboxed
- SpecialiseAll
STEP 2: EQUIVALENCES
f@t1/t2 = <f_rhs> t1 t2 d1 d2
-(f_rhs presumably has some big lambdas and dictionary lambdas, so lots
-of simplification will now result.) Then we should recursively do
-everything again.
-
-The new id has its own unique, but its print-name (if exported) has
-an explicit representation of the instance types t1/t2.
+f_rhs presumably has some big lambdas and dictionary lambdas, so lots
+of simplification will now result. However we don't actually *do* that
+simplification. Rather, we leave it for the simplifier to do. If we
+*did* do it, though, we'd get more call instances from the specialised
+RHS. We can work out what they are by instantiating the call-instance
+set from f's RHS with the types t1, t2.
Add this new id to f's IdInfo, to record that f has a specialised version.
Recursion
~~~~~~~~~
-Wait a minute! What if f is recursive? Then we can't just plug in
+Wait a minute! What if f is recursive? Then we can't just plug in
its right-hand side, can we?
But it's ok. The type checker *always* creates non-recursive definitions
becomes
- f a (d::Num a) = let p = +.sel a d
+ f a (d::Num a) = let p = +.sel a d
in
letrec fl (y::a) = fl (p y y)
- in
+ in
fl
-We still have recusion for non-overloadd functions which we
-speciailise, but the recursive call should get speciailised to the
+We still have recusion for non-overloaded functions which we
+speciailise, but the recursive call should get specialised to the
same recursive version.
After typechecking we have
g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
- in +.sel a d (f a d y) (f a d y)
+ in +.sel a d (f a d y) (f a d y)
Notice that the call to f is at type type "a"; a non-constant type.
Both calls to f are at the same type, so we can specialise to give:
g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
- in +.sel a d (f@a y) (f@a y)
+ in +.sel a d (f@a y) (f@a y)
(b) The other case is when the type variables in the instance types
are *not* in scope at the definition point of f. The example we are
working with above is a good case. There are two instances of (+.sel a d),
-but "a" is not in scope at the definition of +.sel. Can we do anything?
+but "a" is not in scope at the definition of +.sel. Can we do anything?
Yes, we can "common them up", a sort of limited common sub-expression deal.
This would give:
g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
f@a (x::a) = +.sel@a x x
- in +.sel@a (f@a y) (f@a y)
+ in +.sel@a (f@a y) (f@a y)
This can save work, and can't be spotted by the type checker, because
the two instances of +.sel weren't originally at the same type.
* Don't bother unless the equivalence class has more than one item!
-Not clear whether this is all worth it. It is of course OK to
+Not clear whether this is all worth it. It is of course OK to
simply discard call-instances when passing a big lambda.
Polymorphism 2 -- Overloading
That suggests that we should identify which of g's type variables
are constrained (like "a") and which are unconstrained (like "b").
-Then when taking equivalence classes in STEP 2, we ignore the type args
+Then when taking equivalence classes in STEP 2, we ignore the type args
corresponding to unconstrained type variable. In STEP 3 we make
polymorphic versions. Thus:
f@t1/ = /\b -> <f_rhs> t1 b d1 d2
-This seems pretty simple, and a Good Thing.
+We do this.
-Polymorphism 3 -- Unboxed
-~~~~~~~~~~~~~~
-If we are speciailising at unboxed types we must speciailise
-regardless of the overloading constraint. In the exaple above it is
-worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
-etc.
+Dictionary floating
+~~~~~~~~~~~~~~~~~~~
+Consider this
-Note that specialising an overloaded type at an uboxed type requires
-an unboxed instance -- we cannot default to an unspecialised version!
+ f a (d::Num a) = let g = ...
+ in
+ ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
+Here, g is only called at one type, but the dictionary isn't in scope at the
+definition point for g. Usually the type checker would build a
+definition for d1 which enclosed g, but the transformation system
+might have moved d1's defn inward. Solution: float dictionary bindings
+outwards along with call instances.
-Dictionary floating
-~~~~~~~~~~~~~~~~~~~
Consider
f x = let g p q = p==q
f df x = let g :: Eq a => a -> a -> Bool
g dg p q = == dg p q
h :: Num a => a -> a -> (a, Bool)
- h dh r s = let deq = eqFromNum dh
+ h dh r s = let deq = eqFromNum dh
in (+ dh r s, g deq r s)
in
h df x x
After specialising h we get a specialised version of h, like this:
- h' r s = let deq = eqFromNum df
+ h' r s = let deq = eqFromNum df
in (+ df r s, g deq r s)
But we can't naively make an instance for g from this, because deq is not in scope
-at the defn of g. Instead, we have to float out the (new) defn of deq
+at the defn of g. Instead, we have to float out the (new) defn of deq
to widen its scope. Notice that this floating can't be done in advance -- it only
shows up when specialisation is done.
-DELICATE MATTER: the way we tell a dictionary binding is by looking to
-see if it has a Dict type. If the type has been "undictify'd", so that
-it looks like a tuple, then the dictionary binding won't be floated, and
-an opportunity to specialise might be lost.
-
User SPECIALIZE pragmas
~~~~~~~~~~~~~~~~~~~~~~~
Specialisation pragmas can be digested by the type checker, and implemented
Indeed the pragmas *have* to be dealt with by the type checker, because
only it knows how to build the dictionaries d1 and d2! For example
- g :: Ord a => [a] -> [a]
+ g :: Ord a => [a] -> [a]
{-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
Here, the specialised version of g is an application of g's rhs to the
We *insist* that all overloaded type variables are specialised to ground types,
(and hence there can be no context inside a SPECIALIZE pragma).
-We *permit* unconstrained type variables to be specialised to
+We *permit* unconstrained type variables to be specialised to
- a ground type
- or left as a polymorphic type variable
but nothing in between. So
{-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
-
+
is *illegal*. (It can be handled, but it adds complication, and gains the
programmer nothing.)
The information about what instance of the dfun exist gets added to
the dfun's IdInfo in the same way as a user-defined function too.
-In fact, matters are a little bit more complicated than this.
-When we make one of these specialised instances, we are defining
-a constant dictionary, and so we want immediate access to its constant
-methods and superclasses. Indeed, these constant methods and superclasses
-must be in the IdInfo for the class selectors! We need help from the
-typechecker to sort this out, perhaps by generating a separate IdInfo
-for each.
Automatic instance decl specialisation?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
new call-instances of the dfuns, and so on. This all arises because of
the unrestricted mutual recursion between instance decls and value decls.
+Still, there's no actual problem; it just means that we may not do all
+the specialisation we could theoretically do.
+
Furthermore, instance decls are usually exported and used non-locally,
so we'll want to compile enough to get those specialisations done.
Lastly, there's no such thing as a local instance decl, so we can
survive solely by spitting out *usage* information, and then reading that
-back in as a pragma when next compiling the file. So for now,
+back in as a pragma when next compiling the file. So for now,
we only specialise instance decls in response to pragmas.
-That means that even if an instance decl ain't otherwise exported it
-needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
-something to say which module defined the instance, so the usage info
-can be fed into the right reqts info file. Blegh.
-
-
-SPECIAILISING DATA DECLARATIONS
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-With unboxed specialisation (or full specialisation) we also require
-data types (and their constructors) to be speciailised on unboxed
-type arguments.
-
-In addition to normal call instances we gather TyCon call instances at
-unboxed types, determine equivalence classes for the locally defined
-TyCons and build speciailised data constructor Ids for each TyCon and
-substitute these in the CoCon calls.
-
-We need the list of local TyCons to partition the TyCon instance info.
-We pass out a FiniteMap from local TyCons to Specialised Instances to
-give to the interface and code genertors.
-
-N.B. The specialised data constructors reference the original data
-constructor and type constructor which do not have the updated
-specialisation info attached. Any specialisation info must be
-extracted from the TyCon map returned.
-
SPITTING OUT USAGE INFORMATION
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This is done at the top-level when all the call instances which escape
must be for imported functions and data types.
+*** Not currently done ***
+
Partial specialisation by pragmas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In short, dfun Ids need IdInfo with a specialisation for each
constant instance of their instance declaration.
+All this uses a single mechanism: the SpecEnv inside an Id
+
What does the specialisation IdInfo look like?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- SpecInfo
- [Maybe UniType] -- Instance types
- Int -- No of dicts to eat
- Id -- Specialised version
+The SpecEnv of an Id maps a list of types (the template) to an expression
+
+ [Type] |-> Expr
+
+For example, if f has this SpecInfo:
-For example, if f has this SpecInfo:
+ [Int, a] -> \d:Ord Int. f' a
- SpecInfo [Just t1, Nothing, Just t3] 2 f'
+it means that we can replace the call
-then
+ f Int t ===> (\d. f' t)
- f t1 t2 t3 d1 d2 ===> f t2
+This chucks one dictionary away and proceeds with the
+specialised version of f, namely f'.
-The "Nothings" identify type arguments in which the specialised
-version is polymorphic.
What can't be done this way?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
==.sel [t] d
-we can't transform to
+we can't transform to
eqList (==.sel t d')
-where
+where
eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
Of course, we currently have no way to automatically derive
overloading altogether anyway!
-Mutter mutter
-~~~~~~~~~~~~~
-What about types/classes mentioned in SPECIALIZE pragmas spat out,
-but not otherwise exported. Even if they are exported, what about
-their original names.
-
-Suggestion: use qualified names in pragmas, omitting module for
-prelude and "this module".
-
-
-Mutter mutter 2
-~~~~~~~~~~~~~~~
-Consider this
-
- f a (d::Num a) = let g = ...
- in
- ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
-
-Here, g is only called at one type, but the dictionary isn't in scope at the
-definition point for g. Usually the type checker would build a
-definition for d1 which enclosed g, but the transformation system
-might have moved d1's defn inward.
-
-
-Unboxed bindings
-~~~~~~~~~~~~~~~~
-
-What should we do when a value is specialised to a *strict* unboxed value?
-
- map_*_* f (x:xs) = let h = f x
- t = map f xs
- in h:t
-
-Could convert let to case:
-
- map_*_Int# f (x:xs) = case f x of h# ->
- let t = map f xs
- in h#:t
-
-This may be undesirable since it forces evaluation here, but the value
-may not be used in all branches of the body. In the general case this
-transformation is impossible since the mutual recursion in a letrec
-cannot be expressed as a case.
-
-There is also a problem with top-level unboxed values, since our
-implementation cannot handle unboxed values at the top level.
-
-Solution: Lift the binding of the unboxed value and extract it when it
-is used:
-
- map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
- t = map f xs
- in case h of
- _Lift h# -> h#:t
-Now give it to the simplifier and the _Lifting will be optimised away.
-
-The benfit is that we have given the specialised "unboxed" values a
-very simple lifted semantics and then leave it up to the simplifier to
-optimise it --- knowing that the overheads will be removed in nearly
-all cases.
-
-In particular, the value will only be evaluted in the branches of the
-program which use it, rather than being forced at the point where the
-value is bound. For example:
-
- filtermap_*_* p f (x:xs)
- = let h = f x
- t = ...
- in case p x of
- True -> h:t
- False -> t
- ==>
- filtermap_*_Int# p f (x:xs)
- = let h = case (f x) of h# -> _Lift h#
- t = ...
- in case p x of
- True -> case h of _Lift h#
- -> h#:t
- False -> t
-
-The binding for h can still be inlined in the one branch and the
-_Lifting eliminated.
+A note about non-tyvar dictionaries
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Ids have types like
+ forall a,b,c. Eq a -> Ord [a] -> tau
-Question: When won't the _Lifting be eliminated?
+This seems curious at first, because we usually only have dictionary
+args whose types are of the form (C a) where a is a type variable.
+But this doesn't hold for the functions arising from instance decls,
+which sometimes get arguements with types of form (C (T a)) for some
+type constructor T.
-Answer: When they at the top-level (where it is necessary) or when
-inlining would duplicate work (or possibly code depending on
-options). However, the _Lifting will still be eliminated if the
-strictness analyser deems the lifted binding strict.
+Should we specialise wrt this compound-type dictionary? We used to say
+"no", saying:
+ "This is a heuristic judgement, as indeed is the fact that we
+ specialise wrt only dictionaries. We choose *not* to specialise
+ wrt compound dictionaries because at the moment the only place
+ they show up is in instance decls, where they are simply plugged
+ into a returned dictionary. So nothing is gained by specialising
+ wrt them."
+But it is simpler and more uniform to specialise wrt these dicts too;
+and in future GHC is likely to support full fledged type signatures
+like
+ f ;: Eq [(a,b)] => ...
%************************************************************************
%* *
-\subsubsection[CallInstances]{@CallInstances@ data type}
+\subsubsection{The new specialiser}
%* *
%************************************************************************
-\begin{code}
-type FreeVarsSet = UniqSet Id
-type FreeTyVarsSet = UniqSet TyVar
-
-data CallInstance
- = CallInstance
- Id -- This Id; *new* ie *cloned* id
- [Maybe UniType] -- Specialised at these types (*new*, cloned)
- -- Nothing => no specialisation on this type arg
- -- is required (flag dependent).
- [PlainCoreArg] -- And these dictionaries; all ValArgs
- FreeVarsSet -- Free vars of the dict-args in terms of *new* ids
- (Maybe SpecInfo) -- For specialisation with explicit SpecId
-\end{code}
+Our basic game plan is this. For let(rec) bound function
+ f :: (C a, D c) => (a,b,c,d) -> Bool
-\begin{code}
-pprCI :: CallInstance -> Pretty
-pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
- = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
- 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
- case maybe_specinfo of
- Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts])
- Just (SpecInfo _ _ spec_id)
- -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
- ])
-
-isUnboxedCI :: CallInstance -> Bool
-isUnboxedCI (CallInstance _ spec_tys _ _ _)
- = any isUnboxedDataType (catMaybes spec_tys)
-
-isExplicitCI :: CallInstance -> Bool
-isExplicitCI (CallInstance _ _ _ _ (Just _))
- = True
-isExplicitCI (CallInstance _ _ _ _ Nothing)
- = False
-\end{code}
+* Find any specialised calls of f, (f ts ds), where
+ ts are the type arguments t1 .. t4, and
+ ds are the dictionary arguments d1 .. d2.
-Comparisons are based on the {\em types}, ignoring the dictionary args:
+* Add a new definition for f1 (say):
-\begin{code}
+ f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
-cmpCI :: CallInstance -> CallInstance -> TAG_
-cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
- = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+ Note that we abstract over the unconstrained type arguments.
-cmpCI_tys :: CallInstance -> CallInstance -> TAG_
-cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
- = cmpUniTypeMaybeList tys1 tys2
+* Add the mapping
-isCIofTheseIds :: [Id] -> CallInstance -> Bool
-isCIofTheseIds ids (CallInstance ci_id _ _ _ _) = any (eqId ci_id) ids
+ [t1,b,t3,d] |-> \d1 d2 -> f1 b d
-singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails
-singleCI id tys dicts
- = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
- emptyBag [] emptyUniqSet
- where
- fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts])
+ to the specialisations of f. This will be used by the
+ simplifier to replace calls
+ (f t1 t2 t3 t4) da db
+ by
+ (\d1 d1 -> f1 t2 t4) da db
-explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails
-explicitCI id tys specinfo
- = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet
- where
- call_inst = CallInstance id tys dicts fv_set (Just specinfo)
- dicts = panic "Specialise:explicitCI:dicts"
- fv_set = singletonUniqSet id
-
-getCIs :: [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
-getCIs ids (UsageDetails cis tycon_cis dbs fvs)
- = let
- (cis_here, cis_not_here) = partitionBag (isCIofTheseIds ids) cis
- cis_here_list = bagToList cis_here
- in
- -- pprTrace "getCIs:"
- -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"])
- -- 4 (ppAboves (map pprCI cis_here_list)))
- (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs)
-
-dumpCIs :: Bag CallInstance -- The call instances
- -> [Id] -- Bound ids *new*
- -> Bag CallInstance -- Kept call instances
-dumpCIs cis bound_ids
- = (if not (isEmptyBag cis_dict_bound_arg) then
- (if isEmptyBag unboxed_cis_dict_bound_arg
- then (\ x y -> y) -- pprTrace "dumpCIs: bound dictionary arg ... \n"
- else pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n")
- (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
- 4 (ppAboves (map pprCI (bagToList cis_dump))))
- else id)
- cis_keep
- where
- (cis_dump, cis_keep) = partitionBag mentions_bound_ids cis
-
- mentions_bound_ids (CallInstance _ _ _ fv_set _)
- = or [i `elementOfUniqSet` fv_set | i <- bound_ids]
-
- (cis_of_bound_id, cis_dict_bound_arg) = partitionBag (isCIofTheseIds bound_ids) cis_dump
- (unboxed_cis_dict_bound_arg, _) = partitionBag isUnboxedCI cis_dict_bound_arg
+ All the stuff about how many dictionaries to discard, and what types
+ to apply the specialised function to, are handled by the fact that the
+ SpecEnv contains a template for the result of the specialisation.
-\end{code}
+We don't build *partial* specialisations for f. For example:
-Any call instances of a bound_id can be safely dumped, because any
-recursive calls should be at the same instance as the parent instance.
+ f :: Eq a => a -> a -> Bool
+ {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
- letrec f = /\a -> \x::a -> ...(f t x')...
+Here, little is gained by making a specialised copy of f.
+There's a distinct danger that the specialised version would
+first build a dictionary for (Eq b, Eq c), and then select the (==)
+method from it! Even if it didn't, not a great deal is saved.
-Here, the type, t, at which f is used in its own RHS should be
-just "a"; that is, the recursive call is at the same type as
-the original call. That means that when specialising f at some
-type, say Int#, we shouldn't find any *new* instances of f
-arising from specialising f's RHS. The only instance we'll find
-is another call of (f Int#).
+We do, however, generate polymorphic, but not overloaded, specialisations:
-ToDo: We should check this rather than just dumping them.
+ f :: Eq a => [a] -> b -> b -> b
+ {#- SPECIALISE f :: [Int] -> b -> b -> b #-}
-However, we do report any call instances which are mysteriously dumped
-because they have a dictionary argument which is bound here ...
+Hence, the invariant is this:
-ToDo: Under what circumstances does this occur, if at all?
-
-%************************************************************************
-%* *
-\subsubsection[TyConInstances]{@TyConInstances@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-data TyConInstance
- = TyConInstance TyCon -- Type Constructor
- [Maybe UniType] -- Applied to these specialising types
-
-cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
-cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
- = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
-
-cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
-cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
- = cmpUniTypeMaybeList tys1 tys2
-
-singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails
-singleTyConI ty_con spec_tys
- = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet
-
-isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
-isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con
-
-isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
-isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
-
-getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
-getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs)
- = let
- (tycon_cis_local, tycon_cis_global)
- = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
- tycon_cis_local_list = bagToList tycon_cis_local
- in
- (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs)
-\end{code}
+ *** no specialised version is overloaded ***
%************************************************************************
%* *
-\subsubsection[UsageDetails]{@UsageDetails@ data type}
+\subsubsection{The exported function}
%* *
%************************************************************************
\begin{code}
-data UsageDetails
- = UsageDetails
- (Bag CallInstance) -- The collection of call-instances
- (Bag TyConInstance) -- Constructor call-instances
- [DictBindDetails] -- Dictionary bindings in data-dependence order!
- FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
-\end{code}
+specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
+specProgram dflags us binds
+ = do
+ showPass dflags "Specialise"
-The DictBindDetails are fully processed; their call-instance information is
-incorporated in the call-instances of the
-UsageDetails which includes the DictBindDetails. The free vars in a usage details
-will *include* the binders of the DictBind details.
-
-A @DictBindDetails@ contains bindings for dictionaries *only*.
-
-\begin{code}
-data DictBindDetails
- = DictBindDetails
- [Id] -- Main binders, originally visible in scope of binding (cloned)
- PlainCoreBinding -- Fully processed
- FreeVarsSet -- Free in binding group (cloned)
- FreeTyVarsSet -- Free in binding group
-\end{code}
+ let binds' = initSM us (go binds `thenSM` \ (binds', uds') ->
+ returnSM (dumpAllDictBinds uds' binds'))
-\begin{code}
-emptyUDs :: UsageDetails
-unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
-unionUDList :: [UsageDetails] -> UsageDetails
-
-emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet
-
-unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2)
- = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
- (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2)
- -- The append here is really redundant, since the bindings don't
- -- scope over each other. ToDo.
-
-unionUDList = foldr unionUDs emptyUDs
-
-singleFvUDs (CoVarAtom v) | not (isImportedId v)
- = UsageDetails emptyBag emptyBag [] (singletonUniqSet v)
-singleFvUDs other
- = emptyUDs
-
-singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con)
-
-dumpDBs :: [DictBindDetails]
- -> [TyVar] -- TyVars being bound (cloned)
- -> [Id] -- Ids being bound (cloned)
- -> FreeVarsSet -- Fvs of body
- -> ([PlainCoreBinding], -- These ones have to go here
- [DictBindDetails], -- These can float further
- [Id], -- Incoming list + names of dicts bound here
- FreeVarsSet -- Incominf fvs + fvs of dicts bound here
- )
-dumpDBs [] bound_tyvars bound_ids fvs = ([], [], bound_ids, fvs)
-
-dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
- bound_tyvars bound_ids fvs
- | or [i `elementOfUniqSet` db_fvs | i <- bound_ids]
- ||
- or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars]
- = let -- Ha! Dump it!
- (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
- = dumpDBs dbs bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs)
- in
- (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
+ endPass dflags "Specialise" Opt_D_dump_spec binds'
- | otherwise -- This one can float out further
- = let
- (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
- = dumpDBs dbs bound_tyvars bound_ids fvs
- in
- (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
-
-
-
-dumpUDs :: UsageDetails
- -> [Id] -- Ids which are just being bound; *new*
- -> [TyVar] -- TyVars which are just being bound
- -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids
- UsageDetails) -- The above bindings removed, and
- -- any call-instances which mention the ids dumped too
-
-dumpUDs (UsageDetails cis tycon_cis dbs fvs) bound_ids tvs
- = let
- (dict_binds_here, dbs_outer, full_bound_ids, full_fvs) = dumpDBs dbs tvs bound_ids fvs
- cis_outer = dumpCIs cis full_bound_ids
- fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids)
- in
- (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer)
-\end{code}
+ dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
+ (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
-\begin{code}
-addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails -- Dict binding and RHS usage
- -> UsageDetails -- The usage to augment
- -> UsageDetails
-addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs)
- (UsageDetails cis tycon_cis dbs fvs)
- = UsageDetails (db_cis `unionBags` cis)
- (db_tycon_cis `unionBags` tycon_cis)
- (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
- fvs
+ return binds'
where
- -- The free tyvars of the dictionary bindings should really be
- -- gotten from the RHSs, but I'm pretty sure it's good enough just
- -- to look at the type of the dictionary itself.
- -- Doing the proper job would entail keeping track of free tyvars as
- -- well as free vars, which would be a bore.
- db_ftvs = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders))
+ -- We need to start with a Subst that knows all the things
+ -- that are in scope, so that the substitution engine doesn't
+ -- accidentally re-use a unique that's already in use
+ -- Easiest thing is to do it all at once, as if all the top-level
+ -- decls were mutually recursive
+ top_subst = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv
+
+ go [] = returnSM ([], emptyUDs)
+ go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
+ specBind top_subst bind uds `thenSM` \ (bind', uds') ->
+ returnSM (bind' ++ binds', uds')
\end{code}
%************************************************************************
%* *
-\subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
+\subsubsection{@specExpr@: the main function}
%* *
%************************************************************************
-@SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
-
-1) (NoLift CoLitAtom l) : an Id which is bound to a literal
-
-2) (NoLift CoLitAtom l) : an Id bound to a "new" Id
- The new Id is a possibly-type-specialised clone of the original
-
-3) Lifted lifted_id unlifted_id :
-
- This indicates that the original Id has been specialised to an
- unboxed value which must be lifted (see "Unboxed bindings" above)
- @unlifted_id@ is the unboxed clone of the original Id
- @lifted_id@ is a *lifted* version of the original Id
-
- When you lookup Ids which are Lifted, you have to insert a case
- expression to un-lift the value (done with @bindUnlift@)
-
- You also have to insert a case to lift the value in the binding
- (done with @liftExpr@)
-
-
\begin{code}
-type SpecIdEnv = IdEnv CloneInfo
-
-data CloneInfo
- = NoLift PlainCoreAtom -- refers to cloned id or literal
-
- | Lifted Id -- lifted, cloned id
- Id -- unlifted, cloned id
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specialise-data]{Data returned by specialiser}
-%* *
-%************************************************************************
-
-\begin{code}
-data SpecialiseData
- = SpecData Bool
- -- True <=> Specialisation performed
- Bool
- -- False <=> Specialisation completed with errors
-
- [TyCon]
- -- Local tycons declared in this module
-
- [TyCon]
- -- Those in-scope data types for which we want to
- -- generate code for their constructors.
- -- Namely: data types declared in this module +
- -- any big tuples used in this module
- -- The initial (and default) value is the local tycons
-
- (FiniteMap TyCon [[Maybe UniType]])
- -- TyCon specialisations to be generated
- -- We generate specialisations for data types defined
- -- in this module and any tuples used in this module
- -- The initial (and default) value is the specialisations
- -- requested by source-level SPECIALIZE data pragmas
- -- and _SPECIALISE_ pragmas in the interface files
-
- (Bag (Id,[Maybe UniType]))
- -- Imported specialisation errors
- (Bag (Id,[Maybe UniType]))
- -- Imported specialisation warnings
- (Bag (TyCon,[Maybe UniType]))
- -- Imported TyCon specialisation errors
-
-initSpecData local_tycons tycon_specs
- = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
-\end{code}
-
-ToDo[sansom]: Transformation data to process specialisation requests.
-
-%************************************************************************
-%* *
-\subsection[specProgram]{Specialising a core program}
-%* *
-%************************************************************************
-
-\begin{code}
-specProgram :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> [PlainCoreBinding] -- input ...
- -> SpecialiseData
- -> ([PlainCoreBinding], -- main result
- SpecialiseData) -- result specialise data
-
-specProgram sw_chker uniqs binds
- (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
- = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of
- (final_binds, tycon_specs_list,
- UsageDetails import_cis import_tycis _ fvs)
- -> let
- used_conids = filter isDataCon (uniqSetToList fvs)
- used_tycons = map getDataConTyCon used_conids
- used_gen = filter isLocalGenTyCon used_tycons
- gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen)
-
- result_specs = addListToFM_C (++) init_specs tycon_specs_list
-
- uniq_cis = map head (equivClasses cmpCI (bagToList import_cis))
- cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis]
- (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
- cis_warn = init_warn `unionBags` listToBag cis_other
- cis_errs = init_errs `unionBags` listToBag cis_unboxed
-
- uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
- tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
- tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
-
- no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
- && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn)
- in
- (final_binds,
- SpecData True no_errs local_tycons gen_tycons result_specs
- cis_errs cis_warn tycis_errs)
-
-specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _)
- = panic "Specialise:specProgram: specialiser called more than once"
-
--- It may be possible safely to call the specialiser more than once,
--- but I am not sure there is any benefit in doing so (Patrick)
-
--- ToDo: What about unfoldings performed after specialisation ???
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specTyConsAndScope]{Specialising data constructors within tycons}
-%* *
-%************************************************************************
-
-In the specialiser we just collect up the specialisations which will
-be required. We don't create the specialised constructors in
-Core. These are only introduced when we convert to StgSyn.
-
-ToDo: Perhaps this should be done in CoreToStg to ensure no inconsistencies!
-
-\begin{code}
-specTyConsAndScope :: SpecM ([PlainCoreBinding], UsageDetails)
- -> SpecM ([PlainCoreBinding], [(TyCon,[[Maybe UniType]])], UsageDetails)
-
-specTyConsAndScope scopeM
- = scopeM `thenSM` \ (binds, scope_uds) ->
- getSwitchCheckerSM `thenSM` \ sw_chkr ->
+specVar :: Subst -> Id -> CoreExpr
+specVar subst v = case lookupIdSubst subst v of
+ DoneEx e -> e
+ DoneId v _ -> Var v
+
+specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
+-- We carry a substitution down:
+-- a) we must clone any binding that might flaot outwards,
+-- to avoid name clashes
+-- b) we carry a type substitution to use when analysing
+-- the RHS of specialised bindings (no type-let!)
+
+---------------- First the easy cases --------------------
+specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
+specExpr subst (Var v) = returnSM (specVar subst v, emptyUDs)
+specExpr subst (Lit lit) = returnSM (Lit lit, emptyUDs)
+
+specExpr subst (Note note body)
+ = specExpr subst body `thenSM` \ (body', uds) ->
+ returnSM (Note (specNote subst note) body', uds)
+
+
+---------------- Applications might generate a call instance --------------------
+specExpr subst expr@(App fun arg)
+ = go expr []
+ where
+ go (App fun arg) args = specExpr subst arg `thenSM` \ (arg', uds_arg) ->
+ go fun (arg':args) `thenSM` \ (fun', uds_app) ->
+ returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
+
+ go (Var f) args = case specVar subst f of
+ Var f' -> returnSM (Var f', mkCallUDs subst f' args)
+ e' -> returnSM (e', emptyUDs) -- I don't expect this!
+ go other args = specExpr subst other
+
+---------------- Lambda/case require dumping of usage details --------------------
+specExpr subst e@(Lam _ _)
+ = specExpr subst' body `thenSM` \ (body', uds) ->
let
- (tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
-
- tycon_specs_list = collectTyConSpecs tycons_cis
+ (filtered_uds, body'') = dumpUDs bndrs' uds body'
in
- (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then
- pprTrace "Specialising TyCons:\n"
- (ppAboves [ if not (null specs) then
- ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"])
- 4 (ppAboves (map pp_specs specs))
- else ppNil
- | (tycon, specs) <- tycon_specs_list])
- else id) (
- returnSM (binds, tycon_specs_list, gotci_scope_uds)
- )
+ returnSM (mkLams bndrs' body'', filtered_uds)
where
- collectTyConSpecs []
- = []
- collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
- = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
- where
- (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
- uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
- tycon_specs = [spec_tys | TyConInstance _ spec_tys <- uniq_cis]
-
- pp_specs specs = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- specs]
-
-
-{- UNUSED: create specialised constructors in Core
-
-NB: this code may have some bitrot (Andy & Will 95/06)
-
-specTyConsAndScope spec_tycons scopeM
- = fixSM (\ ~(_, _, _, rec_spec_infos) ->
- bindConIds cons_tospec rec_spec_infos (
- scopeM `thenSM` \ (binds, scope_uds) ->
- let
- (tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
- in
- mapAndUnzipSM (inst_tycon tycons_cis) spec_tycons
- `thenSM` \ (tycon_specs_list, spec_infoss) ->
- returnSM (binds, tycon_specs_list, gotci_scope_uds, concat spec_infoss)
- )
-
- ) `thenSM` \ (binds, tycon_specs_list, final_uds, spec_infos) ->
- returnSM (binds, tycon_specs_list, final_uds)
-
+ (bndrs, body) = collectBinders e
+ (subst', bndrs') = simplBndrs subst bndrs
+ -- More efficient to collect a group of binders together all at once
+ -- and we don't want to split a lambda group with dumped bindings
+
+specExpr subst (Case scrut case_bndr alts)
+ = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) ->
+ mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) ->
+ returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
where
- conss_tospec = map getTyConDataCons spec_tycons
- cons_tospec = concat conss_tospec
-
- inst_tycon tycons_cis tycon
- = mapSM mk_con_specs (getTyConDataCons tycon) `thenSM` \ spec_infos ->
- getSwitchCheckerSM `thenSM` \ sw_chkr ->
- (if sw_chkr SpecialiseTrace && not (null tycon_cis) then
- pprTrace "Specialising:"
- (ppHang (ppCat [ppr PprDebug tycon, ppStr "at types"])
- 4 (ppAboves (map pp_inst uniq_cis)))
- else id) (
- returnSM ((tycon, tycon_specs), spec_infos)
- )
- where
- tycon_cis = filter (isTyConIofThisTyCon tycon) tycons_cis
- uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
+ (subst_alt, case_bndr') = simplBndr subst case_bndr
+ -- No need to clone case binder; it can't float like a let(rec)
- tycon_specs = [spec_tys | TyConInstance _ spec_tys <- uniq_cis]
+ spec_alt (con, args, rhs)
+ = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) ->
+ let
+ (uds', rhs'') = dumpUDs args uds rhs'
+ in
+ returnSM ((con, args', rhs''), uds')
+ where
+ (subst_rhs, args') = simplBndrs subst_alt args
+
+---------------- Finally, let is the interesting case --------------------
+specExpr subst (Let bind body)
+ = -- Clone binders
+ cloneBindSM subst bind `thenSM` \ (rhs_subst, body_subst, bind') ->
+
+ -- Deal with the body
+ specExpr body_subst body `thenSM` \ (body', body_uds) ->
- mk_con_specs con_id
- = mapSM (mk_con_spec con_id) uniq_cis
- mk_con_spec con_id (TyConInstance _ spec_tys)
- = newSpecIds [con_id] spec_tys 0 copy_arity_info_and `thenSM` \ [spec_id] ->
- returnSM (SpecInfo spec_tys 0 spec_id)
+ -- Deal with the bindings
+ specBind rhs_subst bind' body_uds `thenSM` \ (binds', uds) ->
- copy_arity_info old new = addIdArity new (getDataConArity old)
+ -- All done
+ returnSM (foldr Let body' binds', uds)
- pp_inst (TyConInstance _ spec_tys)
- = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- spec_tys]
--}
+-- Must apply the type substitution to coerceions
+specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)
+specNote subst note = note
\end{code}
%************************************************************************
%* *
-\subsection[specTopBinds]{Specialising top-level bindings}
+\subsubsection{Dealing with a binding}
%* *
%************************************************************************
\begin{code}
-specTopBinds :: [PlainCoreBinding]
- -> SpecM ([PlainCoreBinding], UsageDetails)
-
-specTopBinds binds
- = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs) ->
+specBind :: Subst -- Use this for RHSs
+ -> CoreBind
+ -> UsageDetails -- Info on how the scope of the binding
+ -> SpecM ([CoreBind], -- New bindings
+ UsageDetails) -- And info to pass upstream
+
+specBind rhs_subst bind body_uds
+ = specBindItself rhs_subst bind (calls body_uds) `thenSM` \ (bind', bind_uds) ->
let
- -- Add bindings for floated dbinds and collect fvs
- -- In actual fact many of these bindings are dead code since dict
- -- arguments are dropped when a specialised call is created
- -- The simplifier should be able to cope ...
-
- (dbinders_s, dbinds, dfvs_s)
- = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
-
- full_fvs = fvs `unionUniqSets` unionManyUniqSets dfvs_s
- fvs_outer = full_fvs `minusUniqSet` (mkUniqSet (concat dbinders_s))
+ bndrs = bindersOf bind
+ all_uds = zapCalls bndrs (body_uds `plusUDs` bind_uds)
+ -- It's important that the `plusUDs` is this way round,
+ -- because body_uds may bind dictionaries that are
+ -- used in the calls passed to specDefn. So the
+ -- dictionary bindings in bind_uds may mention
+ -- dictionaries bound in body_uds.
in
- returnSM (dbinds ++ binds, UsageDetails cis tycis [] fvs_outer)
-
- where
- spec_top_binds (first_bind:rest_binds)
- = specBindAndScope True {- top level -} first_bind (
- spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) ->
- returnSM (ItsABinds rest_binds, rest_uds)
- ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
- returnSM (first_binds ++ rest_binds, all_uds)
-
- spec_top_binds []
- = returnSM ([], emptyUDs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specExpr]{Specialising expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-specExpr :: PlainCoreExpr
- -> [PlainCoreArg] -- The arguments:
- -- TypeArgs are speced
- -- ValArgs are unprocessed
- -> SpecM (PlainCoreExpr, -- Result expression with specialised versions installed
- UsageDetails) -- Details of usage of enclosing binders in the result
- -- expression.
-
-specExpr (CoVar v) args
- = lookupId v `thenSM` \ vlookup ->
- case vlookup of
- Lifted vl vu
- -> -- Binding has been lifted, need to extract un-lifted value
- -- NB: a function binding will never be lifted => args always null
- -- i.e. no call instance required or call to be constructed
- ASSERT (null args)
- returnSM (bindUnlift vl vu (CoVar vu), singleFvUDs (CoVarAtom vl))
-
- NoLift vatom@(CoVarAtom new_v)
- -> mapSM specArg args `thenSM` \ arg_info ->
- mkCallInstance v new_v arg_info `thenSM` \ uds ->
- mkCall new_v arg_info `thenSM` \ call ->
- returnSM (call, uds)
-
-specExpr expr@(CoLit _) null_args
- = ASSERT (null null_args)
- returnSM (expr, emptyUDs)
-
-specExpr (CoCon con tys args) null_args
- = ASSERT (null null_args)
- mapSM specTy tys `thenSM` \ tys ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
- mkTyConInstance con tys `thenSM` \ con_uds ->
- returnSM (applyBindUnlifts unlifts (CoCon con tys args),
- unionUDList args_uds_s `unionUDs` con_uds)
-
-{- UNUSED: create specialised constructors in CoCon
-specExpr (CoCon con tys args) null_args
- = ASSERT (null null_args)
- mapSM specTy tys `thenSM` \ tys ->
- mapAndUnzipSM specAtom args `thenSM` \ (args, args_uds_s) ->
- mkTyConInstance con tys `thenSM` \ con_con ->
- lookupId con `thenSM` \ con ->
- mkConstrCall con tys `thenSM` \ ~(spec_con, spec_tys) ->
- returnSM (CoCon spec_con spec_tys args,
- unionUDList args_uds_s `unionUDs` con_uds)
--}
-
-specExpr (CoPrim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
- = ASSERT (null null_args)
- ASSERT (null tys)
- mapSM specTy arg_tys `thenSM` \ arg_tys ->
- specTy res_ty `thenSM` \ res_ty ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
- returnSM (applyBindUnlifts unlifts (CoPrim (CCallOp str is_asm may_gc arg_tys res_ty) tys args),
- unionUDList args_uds_s)
-
-specExpr (CoPrim prim tys args) null_args
- = ASSERT (null null_args)
- mapSM specTy tys `thenSM` \ tys ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
- -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (applyBindUnlifts unlifts (CoPrim prim tys args),
- unionUDList args_uds_s {-`unionUDs` prim_uds-} )
-
-{- ToDo: specPrimOp
-
-specPrimOp :: PrimOp
- -> [UniType]
- -> SpecM (PrimOp,
- [UniType],
- UsageDetails)
-
--- Checks that PrimOp can handle (possibly unboxed) tys passed
--- and/or chooses PrimOp specialised to any unboxed tys
--- Errors are dealt with by returning a PrimOp call instance
--- which will result in a cis_errs message
-
--- ToDo: Deal with checkSpecTyApp for CoPrim in CoreLint
--}
-
-
-specExpr (CoApp fun arg) args
- = -- Arg is passed on unprocessed
- specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) ->
- returnSM (expr, uds)
-
-specExpr (CoTyApp fun ty) args
- = -- Spec the tyarg and pass it on
- specTy ty `thenSM` \ ty ->
- specExpr fun (TypeArg ty : args)
-
-specExpr (CoLam bound_ids body) args
- = specLam bound_ids body args
-
-specExpr (CoTyLam tyvar body) (TypeArg ty : args)
- = -- Type lambda with argument; argument already spec'd
- bindTyVar tyvar ty (
- specExpr body args
- )
-
-specExpr (CoTyLam tyvar body) []
- = -- No arguments
- cloneTyVarSM tyvar `thenSM` \ new_tyvar ->
- bindTyVar tyvar (mkTyVarTy new_tyvar) (
- specExpr body [] `thenSM` \ (body, body_uds) ->
- let
- (binds_here, final_uds) = dumpUDs body_uds [] [new_tyvar]
- in
- returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds)
- )
-
-specExpr (CoCase scrutinee alts) args
- = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
- specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
- returnSM (CoCase scrutinee alts, scrut_uds `unionUDs` alts_uds)
+ case splitUDs bndrs all_uds of
+
+ (_, ([],[])) -- This binding doesn't bind anything needed
+ -- in the UDs, so put the binding here
+ -- This is the case for most non-dict bindings, except
+ -- for the few that are mentioned in a dict binding
+ -- that is floating upwards in body_uds
+ -> returnSM ([bind'], all_uds)
+
+ (float_uds, (dict_binds, calls)) -- This binding is needed in the UDs, so float it out
+ -> returnSM ([], float_uds `plusUDs` mkBigUD bind' dict_binds calls)
+
+
+-- A truly gruesome function
+mkBigUD bind@(NonRec _ _) dbs calls
+ = -- Common case: non-recursive and no specialisations
+ -- (if there were any specialistions it would have been made recursive)
+ MkUD { dict_binds = listToBag (mkDB bind : dbs),
+ calls = listToCallDetails calls }
+
+mkBigUD bind dbs calls
+ = -- General case
+ MkUD { dict_binds = unitBag (mkDB (Rec (bind_prs bind ++ dbsToPairs dbs))),
+ -- Make a huge Rec
+ calls = listToCallDetails calls }
where
- scrutinee_type = typeOfCoreExpr scrutinee
-
+ bind_prs (NonRec b r) = [(b,r)]
+ bind_prs (Rec prs) = prs
-specExpr (CoLet bind body) args
- = specBindAndScope False {- not top level -} bind (
- specExpr body args `thenSM` \ (body, body_uds) ->
- returnSM (ItsAnExpr body, body_uds)
- ) `thenSM` \ (binds, ItsAnExpr body, all_uds) ->
- returnSM (mkCoLetsNoUnboxed binds body, all_uds)
+ dbsToPairs [] = []
+ dbsToPairs ((bind,_):dbs) = bind_prs bind ++ dbsToPairs dbs
-specExpr (CoSCC cc expr) args
- = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
- mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) ->
+-- specBindItself deals with the RHS, specialising it according
+-- to the calls found in the body (if any)
+specBindItself rhs_subst (NonRec bndr rhs) call_info
+ = specDefn rhs_subst call_info (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
let
- scc_expr
- = if squashableDictishCcExpr cc expr -- can toss the _scc_
- then expr
- else CoSCC cc expr
+ new_bind | null spec_defns = NonRec bndr' rhs'
+ | otherwise = Rec ((bndr',rhs'):spec_defns)
+ -- bndr' mentions the spec_defns in its SpecEnv
+ -- Not sure why we couln't just put the spec_defns first
in
- returnSM (applyBindUnlifts unlifts (applyToArgs scc_expr args),
- unionUDList args_uds_s `unionUDs` expr_uds)
-
--- ToDo:DPH: add stuff here!
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Specialising a lambda}
-%* *
-%************************************************************************
+ returnSM (new_bind, spec_uds)
-\begin{code}
-specLam :: [Id] -> PlainCoreExpr -> [PlainCoreArg]
- -> SpecM (PlainCoreExpr, UsageDetails)
-
-specLam [] body args
- = -- All lambdas saturated
- specExpr body args
-
-specLam (binder:binders) body (ValArg arg : args)
- = -- Lambda with an unprocessed argument
- lookup_arg arg `thenSM` \ arg ->
- bindId binder arg (
- specLam binders body args
- )
- where
- lookup_arg (CoLitAtom l) = returnSM (NoLift (CoLitAtom l))
- lookup_arg (CoVarAtom v) = lookupId v
-
-specLam bound_ids body []
- = -- Lambda with no arguments
- specLambdaOrCaseBody bound_ids body [] `thenSM` \ (bound_ids, body, uds) ->
- returnSM (CoLam bound_ids body, uds)
-\end{code}
-
-\begin{code}
-specLambdaOrCaseBody :: [Id] -- The binders
- -> PlainCoreExpr -- The body
- -> [PlainCoreArg] -- Its args
- -> SpecM ([Id], -- New binders
- PlainCoreExpr, -- New body
- UsageDetails)
-
-specLambdaOrCaseBody bound_ids body args
- = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
- bindIds bound_ids clone_infos (
-
- specExpr body args `thenSM` \ (body, body_uds) ->
-
- let
- -- Dump any dictionary bindings (and call instances)
- -- from the scope which mention things bound here
- (binds_here, final_uds) = dumpUDs body_uds new_ids []
- in
- returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
- )
-
--- ToDo: Opportunity here to common-up dictionaries with same type,
--- thus avoiding recomputation.
-\end{code}
-
-A variable bound in a lambda or case is normally monomorphic so no
-specialised versions will be required. This is just as well since we
-do not know what code to specialise!
-
-Unfortunately this is not always the case. For example a class Foo
-with polymorphic methods gives rise to a dictionary with polymorphic
-components as follows:
-
-\begin{verbatim}
-class Foo a where
- op1 :: a -> b -> a
- op2 :: a -> c -> a
-
-instance Foo Int where
- op1 = op1Int
- op2 = op2Int
-
-... op1 1 3# ...
-
-==>
-
-d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
-d.Foo.Int = (op1_Int, op2_Int)
-
-op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
-
-... op1 {Int Int#} d.Foo.Int 1 3# ...
-\end{verbatim}
-
-N.B. The type of the dictionary is not Hindley Milner!
-
-Now we must specialise op1 at {* Int#} which requires a version of
-meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
-not have access to its code to create the specialised version.
-
-
-If we specialise on overloaded types as well we specialise op1 at
-{Int Int#} d.Foo.Int:
+specBindItself rhs_subst (Rec pairs) call_info
+ = mapSM (specDefn rhs_subst call_info) pairs `thenSM` \ stuff ->
+ let
+ (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
+ spec_defns = concat spec_defns_s
+ spec_uds = plusUDList spec_uds_s
+ new_bind = Rec (spec_defns ++ pairs')
+ in
+ returnSM (new_bind, spec_uds)
+
-op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#}
+specDefn :: Subst -- Subst to use for RHS
+ -> CallDetails -- Info on how it is used in its scope
+ -> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
+ -> SpecM ((Id, CoreExpr), -- The thing and its processed RHS
+ -- the Id may now have specialisations attached
+ [(Id,CoreExpr)], -- Extra, specialised bindings
+ UsageDetails -- Stuff to fling upwards from the RHS and its
+ ) -- specialised versions
+
+specDefn subst calls (fn, rhs)
+ -- The first case is the interesting one
+ | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas
+ && rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args
+ && notNull calls_for_me -- And there are some calls to specialise
+ && not (isDataConWrapId fn) -- And it's not a data con wrapper, which have
+ -- stupid overloading that simply discard the dictionary
+
+-- At one time I tried not specialising small functions
+-- but sometimes there are big functions marked INLINE
+-- that we'd like to specialise. In particular, dictionary
+-- functions, which Marcin is keen to inline
+-- && not (certainlyWillInline fn) -- And it's not small
+ -- If it's small, it's better just to inline
+ -- it than to construct lots of specialisations
+ = -- Specialise the body of the function
+ specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
+
+ -- Make a specialised version for each call in calls_for_me
+ mapSM spec_call calls_for_me `thenSM` \ stuff ->
+ let
+ (spec_defns, spec_uds, spec_rules) = unzip3 stuff
-Though this is still invalid, after further simplification we get:
+ fn' = addIdSpecialisations zapped_fn spec_rules
+ in
+ returnSM ((fn',rhs'),
+ spec_defns,
+ rhs_uds `plusUDs` plusUDList spec_uds)
-op1_Int_Int# = opInt1 {Int#}
+ | otherwise -- No calls or RHS doesn't fit our preconceptions
+ = specExpr subst rhs `thenSM` \ (rhs', rhs_uds) ->
+ returnSM ((zapped_fn, rhs'), [], rhs_uds)
-Another round of specialisation will result in the specialised
-version of op1Int being called directly.
-
-For now we PANIC if a polymorphic lambda/case bound variable is found
-in a call instance with an unboxed type. Other call instances, arising
-from overloaded type arguments, are discarded since the unspecialised
-version extracted from the method can be called as normal.
-
-ToDo: Implement and test second round of specialisation.
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising case alternatives}
-%* *
-%************************************************************************
-
-
-\begin{code}
-specAlts (CoAlgAlts alts deflt) scrutinee_ty args
- = mapSM specTy ty_args `thenSM` \ ty_args ->
- mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) ->
- specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (CoAlgAlts alts deflt,
- unionUDList alts_uds_s `unionUDs` deflt_uds)
-
- where
- -- We use ty_args of scrutinee type to identify specialisation of alternatives
- (_, ty_args, _) = getUniDataTyCon scrutinee_ty
-
- specAlgAlt ty_args (con,binders,rhs)
- = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
- mkTyConInstance con ty_args `thenSM` \ con_uds ->
- returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
-
-{- UNUSED: creating specialised constructors in case alts
- specAlgAlt ty_args (con,binders,rhs)
- = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
- mkTyConInstance con ty_args `thenSM` \ con_uds ->
- lookupId con `thenSM` \ con ->
- mkConstrCall con ty_args `thenSM` \ ~(spec_con, _) ->
- returnSM ((spec_con,binders,rhs), rhs_uds `unionUDs` con_uds)
--}
-
-specAlts (CoPrimAlts alts deflt) scrutinee_ty args
- = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
- specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (CoPrimAlts alts deflt,
- unionUDList alts_uds_s `unionUDs` deflt_uds)
where
- specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) ->
- returnSM ((lit,rhs), uds)
-
-
-specDeflt CoNoDefault args = returnSM (CoNoDefault, emptyUDs)
-specDeflt (CoBindDefault binder rhs) args
- = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
- returnSM (CoBindDefault binder rhs, uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising an atom}
-%* *
-%************************************************************************
-
-\begin{code}
-specAtom :: PlainCoreAtom -> SpecM (PlainCoreAtom, UsageDetails,
- PlainCoreExpr -> PlainCoreExpr)
-
-specAtom (CoLitAtom lit)
- = returnSM (CoLitAtom lit, emptyUDs, id)
-
-specAtom (CoVarAtom v)
- = lookupId v `thenSM` \ vlookup ->
- case vlookup of
- Lifted vl vu
- -> returnSM (CoVarAtom vu, singleFvUDs (CoVarAtom vl), bindUnlift vl vu)
-
- NoLift vatom
- -> returnSM (vatom, singleFvUDs vatom, id)
-
-
-specArg :: PlainCoreArg -> SpecM (PlainCoreArg, UsageDetails,
- PlainCoreExpr -> PlainCoreExpr)
-
-specArg (ValArg arg) -- unprocessed; spec the atom
- = specAtom arg `thenSM` \ (arg, uds, unlift) ->
- returnSM (ValArg arg, uds, unlift)
-
-specArg (TypeArg ty) -- already speced; no action
- = returnSM (TypeArg ty, emptyUDs, id)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising bindings}
-%* *
-%************************************************************************
-
-A classic case of when having a polymorphic recursive function would help!
-
-\begin{code}
-data BindsOrExpr = ItsABinds [PlainCoreBinding]
- | ItsAnExpr PlainCoreExpr
-\end{code}
-
-\begin{code}
-specBindAndScope
- :: Bool -- True <=> a top level group
- -> PlainCoreBinding -- As yet unprocessed
- -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
- -> SpecM ([PlainCoreBinding], -- Processed
- BindsOrExpr, -- Combined result
- UsageDetails) -- Usage details of the whole lot
-
-specBindAndScope is_top_level_group bind scopeM
- = cloneLetrecBinders binders `thenSM` \ (new_binders, clone_infos) ->
-
- -- Two cases now: either this is a bunch of dictionaries, in
- -- which case we float them; or its a bunch of other values,
- -- in which case we see if they correspond to any
- -- call-instances we have in hand.
-
- if all (\id -> isDictTy (getIdUniType id) || isConstMethodId id) binders then
- -- Ha! A group of dictionary bindings, or constant methods.
- -- The reason for the latter is interesting. Consider
- --
- -- dfun.Eq.Foo = /\a \ d -> ...
- --
- -- constmeth1 = ...
- -- constmeth2 = ...
- -- dict = (constmeth1,constmeth2)
- --
- -- ...(dfun.Eq.Foo dict)...
- --
- -- Now, the defn of dict can't float above the constant-method
- -- decls, so the call-instance for dfun.Eq.Foo will be dropped.
+ zapped_fn = zapSpecPragmaId fn
+ -- If the fn is a SpecPragmaId, make it discardable
+ -- It's role as a holder for a call instance is o'er
+ -- But it might be alive for some other reason by now.
+
+ fn_type = idType fn
+ (tyvars, theta, _) = tcSplitSigmaTy fn_type
+ n_tyvars = length tyvars
+ n_dicts = length theta
+
+ -- It's important that we "see past" any INLINE pragma
+ -- else we'll fail to specialise an INLINE thing
+ (inline_me, rhs') = dropInline rhs
+ (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs'
+
+ rhs_dicts = take n_dicts rhs_ids
+ rhs_bndrs = rhs_tyvars ++ rhs_dicts
+ body = mkLams (drop n_dicts rhs_ids) rhs_body
+ -- Glue back on the non-dict lambdas
+
+ calls_for_me = case lookupFM calls fn of
+ Nothing -> []
+ Just cs -> fmToList cs
+
+ ----------------------------------------------------------
+ -- Specialise to one particular call pattern
+ spec_call :: (CallKey, ([DictExpr], VarSet)) -- Call instance
+ -> SpecM ((Id,CoreExpr), -- Specialised definition
+ UsageDetails, -- Usage details from specialised body
+ CoreRule) -- Info for the Id's SpecEnv
+ spec_call (CallKey call_ts, (call_ds, call_fvs))
+ = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts )
+ -- Calls are only recorded for properly-saturated applications
+
+ -- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs
+ -- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [dx1, dx2]
+
+ -- Construct the new binding
+ -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b d -> rhs)
+ -- PLUS the usage-details
+ -- { d1' = dx1; d2' = dx2 }
+ -- where d1', d2' are cloned versions of d1,d2, with the type substitution applied.
--
- -- Solution: float the constant methods in the same way as dictionaries
+ -- Note that the substitution is applied to the whole thing.
+ -- This is convenient, but just slightly fragile. Notably:
+ -- * There had better be no name clashes in a/b/c/d
--
- -- The other interesting bit is the test for dictionary-hood.
- -- Constant dictionaries, like dict above, are sometimes built
- -- as zero-arity dfuns, so isDictId alone won't work.
-
- bindIds binders clone_infos (
-
- -- Process the dictionary bindings themselves
- specBind new_binders bind `thenSM` \ (bind, rhs_uds) ->
-
- -- Process their scope
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
- -- Add the bindings to the current stuff
- final_uds = addDictBinds new_binders bind rhs_uds scope_uds
+ let
+ -- poly_tyvars = [b,d] in the example above
+ -- spec_tyvars = [a,c]
+ -- ty_args = [t1,b,t3,d]
+ poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
+ spec_tyvars = [tv | (tv, Just _) <- rhs_tyvars `zip` call_ts]
+ ty_args = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts
+ where
+ mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar)
+ mk_ty_arg rhs_tyvar (Just ty) = Type ty
+ rhs_subst = extendSubstList subst spec_tyvars [DoneTy ty | Just ty <- call_ts]
in
- returnSM ([], thing, final_uds)
- )
- else
- -- Ho! A group of ordinary (non-dict) bindings
- fixSM (\ ~(_, _, _, rec_spec_infos) ->
-
- bindSpecIds binders clone_infos rec_spec_infos (
- -- It's ok to have new binders in scope in
- -- non-recursive decls too, cos name shadowing is gone by now
-
- -- Do the scope of the bindings
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
- (call_insts_these_binders, gotci_scope_uds) = getCIs new_binders scope_uds
- in
-
- -- Do the bindings themselves
- specBind new_binders bind `thenSM` \ (spec_bind, spec_uds) ->
-
- -- Create any necessary instances
- instBind new_binders bind call_insts_these_binders
- `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
-
- let
- -- Dump any dictionary bindings from the scope
- -- which mention things bound here
- (dict_binds, final_scope_uds) = dumpUDs gotci_scope_uds new_binders []
- -- The spec_ids can't appear anywhere in uds, because they only
- -- appear in SpecInfos.
-
- -- Build final binding group
- -- see note below about dependecies
- final_binds = [spec_bind,
- CoRec (pairsFromCoreBinds (inst_binds ++ dict_binds))
- ]
-
- in
- -- Combine the results together
- returnSM (final_binds,
- thing,
- spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds,
- -- inst_uds comes last, because there may be dict bindings
- -- floating outward in final_scope_uds which are mentioned
- -- in the call-instances, and hence in spec_uds.
- -- This ordering makes sure that the precedence order
- -- among the dict bindings finally floated out is maintained.
- spec_infos)
- )
- ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
- returnSM (binds, thing, final_uds)
- where
- binders = bindersOf bind
-\end{code}
-
-We place the spec_binds and dict_binds in a CoRec as there may be some
-nasty dependencies. These don't actually require a CoRec, but its the
-simplest solution. (The alternative would require some tricky dependency
-analysis.) We leave it to the real dependency analyser to sort it all
-out during a subsequent simplification pass.
-
-Where do these dependencies arise? Consider this case:
-
- data Foo a = ...
-
- {- instance Eq a => Eq (Foo a) where ... -}
- dfun.Eq.(Foo *) d.eq.a = <wurble>
-
- d2 = dfun.Eq.(Foo *) Char# d.Eq.Char#
- d1 = dfun.Eq.(Foo *) (Foo Char#) d2
-
-Now, when specialising we must write the Char# instance of dfun.Eq.(Foo *) before
-that for the (Foo Char#) instance:
-
- dfun.Eq.(Foo *) d.eq.a = <wurble>
-
- dfun.Eq.(Foo *)@Char# = <wurble>[d.Eq.Char#/d.eq.a]
- d2 = dfun.Eq.(Foo *)@Char#
-
- dfun.Eq.(Foo *)@(Foo Char#) = <wurble>[d2/d.eq.a]
- d1 = dfun.Eq.(Foo *)@(Foo Char#)
-
-The definition of dfun.Eq.(Foo *)@(Foo Char#) uses d2!!! So it must
-come after the definition of dfun.Eq.(Foo *)@Char#.
-AAARGH!
-
-
-
-\begin{code}
-specBind :: [Id] -> PlainCoreBinding -> SpecM (PlainCoreBinding, UsageDetails)
- -- The UsageDetails returned has already had stuff to do with this group
- -- of binders deleted; that's why new_binders is passed in.
-specBind new_binders (CoNonRec binder rhs)
- = specOneBinding new_binders (binder,rhs) `thenSM` \ ((binder,rhs), rhs_uds) ->
- returnSM (CoNonRec binder rhs, rhs_uds)
-
-specBind new_binders (CoRec pairs)
- = mapAndUnzipSM (specOneBinding new_binders) pairs `thenSM` \ (pairs, rhs_uds_s) ->
- returnSM (CoRec pairs, unionUDList rhs_uds_s)
-
-
-specOneBinding :: [Id] -> (Id,PlainCoreExpr) -> SpecM ((Id,PlainCoreExpr), UsageDetails)
-
-specOneBinding new_binders (binder, rhs)
- = lookupId binder `thenSM` \ blookup ->
- specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
- let
- specid_maybe_maybe = isSpecPragmaId_maybe binder
- is_specid = maybeToBool specid_maybe_maybe
- Just specinfo_maybe = specid_maybe_maybe
- specid_with_info = maybeToBool specinfo_maybe
- Just spec_info = specinfo_maybe
-
- pragma_uds
- = if is_specid && specid_with_info then
- -- Have a SpecInfo stored in a SpecPragmaId binder
- -- This contains the SpecInfo for a specialisation pragma
- -- with an explicit SpecId specified
- -- We remove any cis for orig_id (there should only be one)
- -- and add the explicit ci to the usage details
- let
- (SpecInfo spec_tys _ spec_id) = spec_info
- Just (orig_id, _) = isSpecId_maybe spec_id
- in
- ASSERT(toplevelishId orig_id) -- must not be cloned!
- explicitCI orig_id spec_tys spec_info
- else
- emptyUDs
-
- (binds_here, final_uds) = dumpUDs rhs_uds new_binders []
- in
- case blookup of
- Lifted lift_binder unlift_binder
- -> -- We may need to record an unboxed instance of
- -- the _Lift data type in the usage details
- mkTyConInstance liftDataCon [getIdUniType unlift_binder]
- `thenSM` \ lift_uds ->
- returnSM ((lift_binder,
- mkCoLetsNoUnboxed binds_here (liftExpr unlift_binder rhs)),
- final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
-
- NoLift (CoVarAtom binder)
- -> returnSM ((binder, mkCoLetsNoUnboxed binds_here rhs),
- final_uds `unionUDs` pragma_uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{@instBind@}
-%* *
-%************************************************************************
+ cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') ->
+ let
+ inst_args = ty_args ++ map Var rhs_dicts'
-\begin{code}
-instBind main_ids@(first_binder:other_binders) bind call_insts_for_main_ids
- | all same_overloading other_binders
- = let
- -- Collect up identical call instances
- equiv_classes = equivClasses cmpCI_tys call_insts_for_main_ids
- in
- -- For each equivalence class, build an instance
- mapAndUnzip3SM do_this_class equiv_classes `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
-
- -- Add in the remaining UDs
- returnSM (catMaybes inst_binds,
- unionUDList inst_uds_s,
- spec_infos
- )
-
- | otherwise -- Incompatible overloadings; see below by same_overloading
- = (if null (filter isUnboxedCI call_insts_for_main_ids)
- then (\ x y -> y) -- pprTrace "dumpCIs: not same overloading ... \n"
- else pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n")
- (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"])
- 4 (ppAboves (map pprCI call_insts_for_main_ids)))
- (returnSM ([], emptyUDs, []))
-
- where
- (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
- tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls
-
- no_of_tyvars = length tyvar_tmpls
- no_of_dicts = length class_tyvar_pairs
-
- do_this_class equiv_cis
- | not (null explicit_cis)
- = if (length main_ids > 1 || length explicit_cis > 1) then
- -- ToDo: If this situation arose we would need to go through
- -- checking cis for each main_id and only creating an
- -- instantiation if we had no explicit_cis for that main_id
- pprPanic "Specialise:instBind:explicit call instances\n"
- (ppAboves [ppCat [ppStr "{", ppr PprDebug main_ids, ppStr "}"],
- ppAboves (map pprCI equiv_cis)])
- else
- getSwitchCheckerSM `thenSM` \ sw_chkr ->
- (if sw_chkr SpecialiseTrace then
- let
- SpecInfo spec_tys _ spec_id = explicit_spec_info
- in
- pprTrace "Specialising:"
- (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"])
- 4 (ppAboves [
- ppCat (ppStr "at types:" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
- ppCat [ppStr "spec ids:", ppr PprDebug [spec_id], ppStr "(explicit)"]]))
- else id) (
-
- returnSM (Nothing, emptyUDs, [explicit_spec_info])
- )
- | otherwise
- = mkOneInst (head equiv_cis) no_of_dicts main_ids bind
- where
- explicit_cis = filter isExplicitCI equiv_cis
- [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis
+ -- Figure out the type of the specialised function
+ spec_id_ty = mkForAllTys poly_tyvars (applyTypeToArgs rhs fn_type inst_args)
+ in
+ newIdSM fn spec_id_ty `thenSM` \ spec_f ->
+ specExpr rhs_subst' (mkLams poly_tyvars body) `thenSM` \ (spec_rhs, rhs_uds) ->
+ let
+ -- The rule to put in the function's specialisation is:
+ -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d
+ spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+ AlwaysActive
+ (poly_tyvars ++ rhs_dicts')
+ inst_args
+ (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+
+ -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+ final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
+
+ -- NOTE: we don't add back in any INLINE pragma on the RHS, so even if
+ -- the original function said INLINE, the specialised copies won't.
+ -- The idea is that the point of inlining was precisely to specialise
+ -- the function at its call site, and that's not so important for the
+ -- specialised copies. But it still smells like an ad hoc decision.
+ in
+ returnSM ((spec_f, spec_rhs),
+ final_uds,
+ spec_env_rule)
- -- same_overloading tests whether the types of all the binders
- -- are "compatible"; ie have the same type and dictionary abstractions
- -- Almost always this is the case, because a recursive group is abstracted
- -- all together. But, it can happen that it ain't the case, because of
- -- code generated from instance decls:
- --
- -- rec
- -- dfun.Foo.Int :: (forall a. a -> Int, Int)
- -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
- --
- -- const.op1.Int :: forall a. a -> Int
- -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
- --
- -- const.op2.Int :: Int
- -- const.op2.Int = 3
- --
- -- Note that the first two defns have different polymorphism, but they are
- -- mutually recursive!
-
- same_overloading :: Id -> Bool
- same_overloading id
- = no_of_tyvars == length this_id_tyvars -- Same no of tyvars
- &&
- no_of_dicts == length this_id_class_tyvar_pairs -- Same no of vdicts
- &&
- and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs) -- Same overloading
where
- (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id
- tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls
-
- same_ov (clas1,tyvar1) (clas2,tyvar2)
- = clas1 == clas2 &&
- tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
-\end{code}
-
-OK, so we have:
- - a call instance eg f [t1,t2,t3] [d1,d2]
- - the rhs of the function eg orig_rhs
- - a constraint vector, saying which of eg [T,F,T]
- the functions type args are constrained
- (ie overloaded)
-
-We return a new definition
-
- f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2
-
-The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
+ my_zipEqual doc xs ys
+ | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+ | otherwise = zipEqual doc xs ys
- SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
-
-Based on this SpecInfo, a call instance of f
-
- ...(f t1 t2 t3 d1 d2)...
-
-should get replaced by
-
- ...(f@t1//t3 t2)...
-
-(But that is the business of @mkCall@.)
-
-\begin{code}
-mkOneInst :: CallInstance
- -> Int -- No of dicts to specialise
- -> [Id] -- New binders
- -> PlainCoreBinding -- Unprocessed
- -> SpecM (Maybe PlainCoreBinding, -- Instantiated version of input
- UsageDetails,
- [SpecInfo] -- One for each id in the original binding
- )
-
-mkOneInst (CallInstance _ spec_tys dict_args _ _) no_of_dicts_to_specialise main_ids orig_bind
- = ASSERT (no_of_dicts_to_specialise == length dict_args)
- newSpecIds main_ids spec_tys no_of_dicts_to_specialise copy_inline_info
- `thenSM` \ spec_ids ->
- newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars ->
- let
- -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys
- -- which correspond to unspeciailsed args
- arg_tys :: [UniType]
- (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
-
- args :: [PlainCoreArg]
- args = map TypeArg arg_tys ++ dict_args
-
- (one_spec_id:_) = spec_ids
-
- do_bind (CoNonRec binder rhs)
- = do_one_rhs rhs `thenSM` \ (rhs, rhs_uds) ->
- returnSM (CoNonRec one_spec_id rhs, rhs_uds)
-
- do_bind (CoRec pairs)
- = mapAndUnzipSM do_one_rhs [rhs | (_,rhs) <- pairs] `thenSM` \ (rhss, rhss_uds_s) ->
- returnSM (CoRec (spec_ids `zip` rhss), unionUDList rhss_uds_s)
-
- -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
- do_one_rhs orig_rhs = specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
- let
- (binds_here, final_uds) = dumpUDs inst_uds main_ids []
- -- NB: main_ids!! not spec_ids!! Why? Because the free-var
- -- stuff knows nowt about spec_ids; it'll just have the
- -- original polymorphic main_ids as free. Belgh
- in
- returnSM (mkCoLetsNoUnboxed binds_here (mkCoTyLam poly_tyvars inst_rhs),
- final_uds)
- in
- getSwitchCheckerSM `thenSM` \ sw_chkr ->
- (if sw_chkr SpecialiseTrace then
- pprTrace "Specialising:"
- (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"])
- 4 (ppAboves [
- ppBesides [ppStr "with args: ", ppInterleave ppNil (map pp_arg args)],
- ppBesides [ppStr "spec ids: ", ppr PprDebug spec_ids]]))
- else id) (
-
- do_bind orig_bind `thenSM` \ (inst_bind, inst_uds) ->
-
- returnSM (Just inst_bind,
- inst_uds,
- [SpecInfo spec_tys no_of_dicts_to_specialise spec_id | spec_id <- spec_ids]
- )
- )
- where
- -- debugging
- pp_arg (ValArg a) = ppBesides [ppLparen, ppStr "ValArg ", ppr PprDebug a, ppRparen]
- pp_arg (TypeArg t) = ppBesides [ppLparen, ppStr "TypeArg ", ppr PprDebug t, ppRparen]
-
- do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
- do_the_wotsit tyvars (Just ty) = (tyvars, ty)
-
- copy_inline_info new_id old_uf_info = addIdUnfolding new_id old_uf_info
+dropInline :: CoreExpr -> (Bool, CoreExpr)
+dropInline (Note InlineMe rhs) = (True, rhs)
+dropInline rhs = (False, rhs)
\end{code}
%************************************************************************
%* *
-\subsection[Misc]{Miscellaneous junk}
+\subsubsection{UsageDetails and suchlike}
%* *
%************************************************************************
-@getIdOverloading@ grabs the type of an Id, and returns a
-list of its polymorphic variables, and the initial segment of
-its ThetaType, in which the classes constrain only type variables.
-For example, if the Id's type is
-
- forall a,b,c. Eq a -> Ord [a] -> tau
-
-we'll return
-
- ([a,b,c], [(Eq,a)])
-
-This seems curious at first. For a start, the type above looks odd,
-because we usually only have dictionary args whose types are of
-the form (C a) where a is a type variable. But this doesn't hold for
-the functions arising from instance decls, which sometimes get
-arguements with types of form (C (T a)) for some type constructor T.
-
-Should we specialise wrt this compound-type dictionary? This is
-a heuristic judgement, as indeed is the fact that we specialise wrt
-only dictionaries. We choose *not* to specialise wrt compound dictionaries
-because at the moment the only place they show up is in instance decls,
-where they are simply plugged into a returned dictionary. So nothing is
-gained by specialising wrt them.
-
\begin{code}
-getIdOverloading :: Id
- -> ([TyVarTemplate], [(Class,TyVarTemplate)])
-getIdOverloading id
- = (tyvars, tyvar_part_of theta)
+data UsageDetails
+ = MkUD {
+ dict_binds :: !(Bag DictBind),
+ -- Floated dictionary bindings
+ -- The order is important;
+ -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
+ -- (Remember, Bags preserve order in GHC.)
+
+ calls :: !CallDetails
+ }
+
+type DictBind = (CoreBind, VarSet)
+ -- The set is the free vars of the binding
+ -- both tyvars and dicts
+
+type DictExpr = CoreExpr
+
+emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
+
+type ProtoUsageDetails = ([DictBind],
+ [(Id, CallKey, ([DictExpr], VarSet))]
+ )
+
+------------------------------------------------------------
+type CallDetails = FiniteMap Id CallInfo
+newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument
+type CallInfo = FiniteMap CallKey
+ ([DictExpr], VarSet) -- Dict args and the vars of the whole
+ -- call (including tyvars)
+ -- [*not* include the main id itself, of course]
+ -- The finite maps eliminate duplicates
+ -- The list of types and dictionaries is guaranteed to
+ -- match the type of f
+
+-- Type isn't an instance of Ord, so that we can control which
+-- instance we use. That's tiresome here. Oh well
+instance Eq CallKey where
+ k1 == k2 = case k1 `compare` k2 of { EQ -> True; other -> False }
+
+instance Ord CallKey where
+ compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2
+ where
+ cmp Nothing Nothing = EQ
+ cmp Nothing (Just t2) = LT
+ cmp (Just t1) Nothing = GT
+ cmp (Just t1) (Just t2) = tcCmpType t1 t2
+
+unionCalls :: CallDetails -> CallDetails -> CallDetails
+unionCalls c1 c2 = plusFM_C plusFM c1 c2
+
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall id tys dicts
+ = unitFM id (unitFM (CallKey tys) (dicts, call_fvs))
where
- (tyvars, theta, _) = splitType (getIdUniType id)
-
- tyvar_part_of [] = []
- tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of
- Nothing -> []
- Just tyvar -> (clas, tyvar) : tyvar_part_of theta
-\end{code}
+ call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
+ tys_fvs = tyVarsOfTypes (catMaybes tys)
+ -- The type args (tys) are guaranteed to be part of the dictionary
+ -- types, because they are just the constrained types,
+ -- and the dictionary is therefore sure to be bound
+ -- inside the binding for any type variables free in the type;
+ -- hence it's safe to neglect tyvars free in tys when making
+ -- the free-var set for this call
+ -- BUT I don't trust this reasoning; play safe and include tys_fvs
+ --
+ -- We don't include the 'id' itself.
-\begin{code}
-mkCallInstance :: Id
- -> Id
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
- -> SpecM UsageDetails
-
-mkCallInstance old_id new_id args
- = recordCallInst old_id args `thenSM` \ record_call ->
- case record_call of
- Nothing -- No specialisation required
- -> -- pprTrace "NoSpecReqd:"
- -- (ppCat [ppr PprDebug old_id, ppStr "at", ppCat (map (ppr PprDebug) args)])
-
- (returnSM call_fv_uds)
-
- Just (True, spec_tys, dict_args, rest_args) -- Requires specialisation: spec already exists
- -> -- pprTrace "SpecExists:"
- -- (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args),
- -- ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
- -- ppCat [ppr PprDebug dict | dict <- dict_args],
- -- ppStr ")"]])
-
- (returnSM call_fv_uds)
-
- Just (False, spec_tys, dict_args, rest_args) -- Requires specialisation: record call-instance
- -> -- pprTrace "CallInst:"
- -- (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args),
- -- ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
- -- ppCat [ppr PprDebug dict | dict <- dict_args],
- -- ppStr ")"]])
-
- (returnSM (singleCI new_id spec_tys dict_args `unionUDs` call_fv_uds))
+listToCallDetails calls
+ = foldr (unionCalls . mk_call) emptyFM calls
where
- call_fv_uds = singleFvUDs (CoVarAtom new_id) `unionUDs` unionUDList [uds | (_,uds,_) <- args]
-\end{code}
-
-\begin{code}
-recordCallInst :: Id
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
- -> SpecM (Maybe (Bool, [Maybe UniType], [PlainCoreArg],
- [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]))
-
-recordCallInst id [] -- No args => no call instance
- = returnSM Nothing
-
-recordCallInst id args
- | isBottomingId id -- No specialised versions for "error" and friends are req'd.
- = returnSM Nothing -- This is a special case in core lint etc.
-
- -- No call instances for Ids associated with a Class declaration,
- -- i.e. default methods, super-dict selectors and class ops.
- -- We rely on the instance declarations to provide suitable specialisations.
- -- These are dealt with in mkCall.
-
- | isDefaultMethodId id
- = returnSM Nothing
-
- | maybeToBool (isSuperDictSelId_maybe id)
- = returnSM Nothing
-
- | isClassOpId id
- = returnSM Nothing
-
- -- Finally, the default case ...
+ mk_call (id, tys, dicts_w_fvs) = unitFM id (unitFM tys dicts_w_fvs)
+ -- NB: the free vars of the call are provided
+
+callDetailsToList calls = [ (id,tys,dicts)
+ | (id,fm) <- fmToList calls,
+ (tys, dicts) <- fmToList fm
+ ]
+
+mkCallUDs subst f args
+ | null theta
+ || not (spec_tys `lengthIs` n_tyvars)
+ || not ( dicts `lengthIs` n_dicts)
+ || maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
+ -- There's already a rule covering this call. A typical case
+ -- is where there's an explicit user-provided rule. Then
+ -- we don't want to create a specialised version
+ -- of the function that overlaps.
+ = emptyUDs -- Not overloaded, or no specialisation wanted
| otherwise
- = getSwitchCheckerSM `thenSM` \ sw_chkr ->
- let
- spec_overloading = sw_chkr SpecialiseOverloaded
- spec_unboxed = sw_chkr SpecialiseUnboxed
- spec_all = sw_chkr SpecialiseAll
+ = MkUD {dict_binds = emptyBag,
+ calls = singleCall f spec_tys dicts
+ }
+ where
+ (tyvars, theta, _) = tcSplitSigmaTy (idType f)
+ constrained_tyvars = tyVarsOfTheta theta
+ n_tyvars = length tyvars
+ n_dicts = length theta
- (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading id
- constraint_vec = mkConstraintVector tyvar_tmpls class_tyvar_pairs
+ spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
+ dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
+
+ mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
+ = Just ty
+ | otherwise
+ = Nothing
+
+------------------------------------------------------------
+plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
+plusUDs (MkUD {dict_binds = db1, calls = calls1})
+ (MkUD {dict_binds = db2, calls = calls2})
+ = MkUD {dict_binds = d, calls = c}
+ where
+ d = db1 `unionBags` db2
+ c = calls1 `unionCalls` calls2
- arg_res = take_type_args tyvar_tmpls class_tyvar_pairs args
- enough_args = maybeToBool arg_res
+plusUDList = foldr plusUDs emptyUDs
- (Just (inst_tys, dict_args, rest_args)) = arg_res
- spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
- constraint_vec inst_tys
+-- zapCalls deletes calls to ids from uds
+zapCalls ids uds = uds {calls = delListFromFM (calls uds) ids}
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation id)
- inst_tys)
+mkDB bind = (bind, bind_fvs bind)
- -- We record the call instance if there is some meaningful
- -- type which we want to specialise on ...
- record_spec = any (not . isTyVarTy) (catMaybes spec_tys)
- in
- if (not enough_args) then
- pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
- else
- if record_spec then
- returnSM (Just (spec_exists, spec_tys, dict_args, rest_args))
- else
- returnSM Nothing
-
-
-take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
- = case take_type_args tyvars class_tyvar_pairs args of
- Nothing -> Nothing
- Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
-take_type_args (_:tyvars) class_tyvar_pairs []
- = Nothing
-take_type_args [] class_tyvar_pairs args
- = case take_dict_args class_tyvar_pairs args of
- Nothing -> Nothing
- Just (dicts, others) -> Just ([], dicts, others)
-
-take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
- = case take_dict_args class_tyvar_pairs args of
- Nothing -> Nothing
- Just (dicts, others) -> Just (dict:dicts, others)
-take_dict_args (_:class_tyvar_pairs) []
- = Nothing
-take_dict_args [] args
- = Just ([], args)
-\end{code}
+bind_fvs (NonRec bndr rhs) = exprFreeVars rhs
+bind_fvs (Rec prs) = foldl delVarSet rhs_fvs bndrs
+ where
+ bndrs = map fst prs
+ rhs_fvs = unionVarSets [exprFreeVars rhs | (bndr,rhs) <- prs]
-\begin{code}
-mkCall :: Id
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
- -> SpecM PlainCoreExpr
-
-mkCall main_id args
- | isDefaultMethodId main_id
- && any isUnboxedDataType ty_args
- -- No specialisations for default methods
- -- Unboxed calls to DefaultMethodIds should not occur
- -- The method should be specified in the instance declaration
- = panic "Specialise:mkCall:DefaultMethodId"
-
- | maybeToBool (isSuperDictSelId_maybe main_id)
- && any isUnboxedDataType ty_args
- -- No specialisations for super-dict selectors
- -- Specialise unboxed calls to SuperDictSelIds by extracting
- -- the super class dictionary directly form the super class
- -- NB: This should be dead code since all uses of this dictionary should
- -- have been specialised. We only do this to keep keep core-lint happy.
- = let
- Just (_, super_class) = isSuperDictSelId_maybe main_id
- super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
- Nothing -> panic "Specialise:mkCall:SuperDictId"
- Just id -> id
- in
- returnSM (CoVar super_dict_id)
+addDictBind (dict,rhs) uds = uds { dict_binds = mkDB (NonRec dict rhs) `consBag` dict_binds uds }
- | otherwise
- = case lookupSpecEnv (getIdSpecialisation main_id) ty_args of
- Nothing -> checkUnspecOK main_id ty_args (
- returnSM unspec_call
- )
-
- Just (spec_id, tys_left, dicts_to_toss)
- -> checkSpecOK main_id ty_args spec_id tys_left (
- let
- args_left = toss_dicts dicts_to_toss val_args
- in
-
- -- The resulting spec_id may be an unboxed constant method
- -- eg: pi Double# d.Floating.Double# ==> pi.Double#
- -- Since it is a top level id pi.Double# will have been lifted.
- -- We must add code to unlift such a spec_id
-
- if isUnboxedDataType (getIdUniType spec_id) then
- ASSERT (null tys_left && null args_left)
- if isConstMethodId spec_id then
- liftId spec_id `thenSM` \ (lifted_spec_id, unlifted_spec_id) ->
- returnSM (bindUnlift lifted_spec_id unlifted_spec_id
- (CoVar unlifted_spec_id))
- else
- -- ToDo: Are there other cases where we have an unboxed spec_id ???
- pprPanic "Specialise:mkCall: unboxed spec_id ...\n"
- (ppCat [ppr PprDebug main_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args),
- ppStr "==>",
- ppr PprDebug spec_id])
- else
- let
- (vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkCoTyApps (CoVar spec_id) tys_left
- applied_vals = applyToArgs applied_tys vals_left
- in
- returnSM (applyBindUnlifts unlifts_left applied_vals)
- )
+dumpAllDictBinds (MkUD {dict_binds = dbs}) binds
+ = foldrBag add binds dbs
where
- (tys_and_vals, _, unlifts) = unzip3 args
- unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar main_id) tys_and_vals)
-
-
- -- ty_args is the types at the front of the arg list
- -- val_args is the rest of the arg-list
-
- (ty_args, val_args) = get args
- where
- get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
- get args = ([], args)
+ add (bind,_) binds = bind : binds
- -- toss_dicts chucks away dict args, checking that they ain't types!
- toss_dicts 0 args = args
- toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args
-\end{code}
-
-\begin{code}
-checkUnspecOK :: Id -> [UniType] -> a -> a
-checkUnspecOK check_id tys
- = if isLocallyDefined check_id && any isUnboxedDataType tys
- then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
- (ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys)])
- else id
-
-checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a
-checkSpecOK check_id tys spec_id tys_left
- = if any isUnboxedDataType tys_left
- then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
- (ppAboves [ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys)],
- ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]])
- else id
-\end{code}
-
-\begin{code}
-mkTyConInstance :: Id
- -> [UniType]
- -> SpecM UsageDetails
-mkTyConInstance con tys
- = recordTyConInst con tys `thenSM` \ record_inst ->
- case record_inst of
- Nothing -- No TyCon instance
- -> -- pprTrace "NoTyConInst:"
- -- (ppCat [ppr PprDebug tycon, ppStr "at",
- -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
- (returnSM (singleConUDs con))
-
- Just spec_tys -- Record TyCon instance
- -> -- pprTrace "TyConInst:"
- -- (ppCat [ppr PprDebug tycon, ppStr "at",
- -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
- -- ppBesides [ppStr "(",
- -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
- -- ppStr ")"]])
- (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
+dumpUDs :: [CoreBndr]
+ -> UsageDetails -> CoreExpr
+ -> (UsageDetails, CoreExpr)
+dumpUDs bndrs uds body
+ = (free_uds, foldr add_let body dict_binds)
where
- tycon = getDataConTyCon con
-\end{code}
+ (free_uds, (dict_binds, _)) = splitUDs bndrs uds
+ add_let (bind,_) body = Let bind body
-\begin{code}
-recordTyConInst :: Id
- -> [UniType]
- -> SpecM (Maybe [Maybe UniType])
+splitUDs :: [CoreBndr]
+ -> UsageDetails
+ -> (UsageDetails, -- These don't mention the binders
+ ProtoUsageDetails) -- These do
+
+splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
+ calls = orig_calls})
-recordTyConInst con tys
- = let
- spec_tys = specialiseConstrTys tys
+ = if isEmptyBag dump_dbs && null dump_calls then
+ -- Common case: binder doesn't affect floats
+ (uds, ([],[]))
- do_tycon_spec = maybeToBool (firstJust spec_tys)
+ else
+ -- Binders bind some of the fvs of the floats
+ (MkUD {dict_binds = free_dbs,
+ calls = listToCallDetails free_calls},
+ (bagToList dump_dbs, dump_calls)
+ )
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation con)
- tys)
- in
- -- pprTrace "ConSpecExists?: "
- -- (ppAboves [ppStr (if spec_exists then "True" else "False"),
- -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
- (if (not spec_exists && do_tycon_spec)
- then returnSM (Just spec_tys)
- else returnSM Nothing)
+ where
+ bndr_set = mkVarSet bndrs
+
+ (free_dbs, dump_dbs, dump_idset)
+ = foldlBag dump_db (emptyBag, emptyBag, bndr_set) orig_dbs
+ -- Important that it's foldl not foldr;
+ -- we're accumulating the set of dumped ids in dump_set
+
+ -- Filter out any calls that mention things that are being dumped
+ orig_call_list = callDetailsToList orig_calls
+ (dump_calls, free_calls) = partition captured orig_call_list
+ captured (id,tys,(dicts, fvs)) = fvs `intersectsVarSet` dump_idset
+ || id `elemVarSet` dump_idset
+
+ dump_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
+ | dump_idset `intersectsVarSet` fvs -- Dump it
+ = (free_dbs, dump_dbs `snocBag` db,
+ dump_idset `unionVarSet` mkVarSet (bindersOf bind))
+
+ | otherwise -- Don't dump it
+ = (free_dbs `snocBag` db, dump_dbs, dump_idset)
\end{code}
-\begin{code}
-{- UNUSED: create specilaised constructor calls in Core
-mkConstrCall :: PlainCoreAtom -> [UniType] -- This constructor at these types
- -> SpecM (Id, [UniType]) -- The specialised constructor and reduced types
-
-mkConstrCall (CoVarAtom con_id) tys
- = case lookupSpecEnv (getIdSpecialisation con_id) tys of
- Nothing -> checkUnspecOK con_id tys (
- returnSM (con_id, tys)
- )
- Just (spec_id, tys_left, 0)
- -> checkSpecOK con_id tys spec_id tys_left (
- returnSM (spec_id, tys_left)
- )
--}
-\end{code}
%************************************************************************
%* *
-\subsection[monad-Specialise]{Monad used in specialisation}
+\subsubsection{Boring helper functions}
%* *
%************************************************************************
-Monad has:
-
- inherited: control flags and
- recordInst functions with flags cached
-
- environment mapping tyvars to types
- environment mapping Ids to Atoms
-
- threaded in and out: unique supply
-
-\begin{code}
-type SpecM result
- = (GlobalSwitch -> Bool)
- -> TypeEnv
- -> SpecIdEnv
- -> SplitUniqSupply
- -> result
-
-initSM m sw_chker uniqs
- = m sw_chker nullTyVarEnv nullIdEnv uniqs
-
-returnSM :: a -> SpecM a
-thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
-fixSM :: (a -> SpecM a) -> SpecM a
-
-thenSM m k sw_chkr tvenv idenv us
- = case splitUniqSupply us of { (s1, s2) ->
- case (m sw_chkr tvenv idenv s1) of { r ->
- k r sw_chkr tvenv idenv s2 }}
-
-returnSM r sw_chkr tvenv idenv us = r
-
-fixSM k sw_chkr tvenv idenv us
- = r
- where
- r = k r sw_chkr tvenv idenv us -- Recursive in r!
-\end{code}
-
\begin{code}
-getSwitchCheckerSM sw_chkr tvenv idenv us = sw_chkr
-\end{code}
-
-The only interesting bit is figuring out the type of the SpecId!
+type SpecM a = UniqSM a
+
+thenSM = thenUs
+returnSM = returnUs
+getUniqSM = getUniqueUs
+mapSM = mapUs
+initSM = initUs_
+
+mapAndCombineSM f [] = returnSM ([], emptyUDs)
+mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) ->
+ mapAndCombineSM f xs `thenSM` \ (ys, uds2) ->
+ returnSM (y:ys, uds1 `plusUDs` uds2)
+
+cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
+-- Clone the binders of the bind; return new bind with the cloned binders
+-- Return the substitution to use for RHSs, and the one to use for the body
+cloneBindSM subst (NonRec bndr rhs)
+ = getUs `thenUs` \ us ->
+ let
+ (subst', bndr') = substAndCloneId subst us bndr
+ in
+ returnUs (subst, subst', NonRec bndr' rhs)
-\begin{code}
-newSpecIds :: [Id] -- The id of which to make a specialised version
- -> [Maybe UniType] -- Specialise to these types
- -> Int -- No of dicts to specialise
- -> (Id -> UnfoldingDetails -> Id) -- copies any arity info required
- -> SpecM [Id]
-
-newSpecIds main_ids maybe_tys dicts_to_ignore copy_id_info sw_chkr tvenv idenv us
- = spec_ids
- where
- uniqs = getSUniques (length main_ids) us
- spec_id_ty id = specialiseTy (getIdUniType id) maybe_tys dicts_to_ignore
- spec_ids = [ copy_id_info (mkSpecId uniq id maybe_tys (spec_id_ty id) noIdInfo) (getIdUnfolding id)
- | (id,uniq) <- main_ids `zip` uniqs
- ]
-
-newTyVars :: Int -> SpecM [TyVar]
-newTyVars n sw_chkr tvenv idenv us
- = map mkPolySysTyVar uniqs
- where
- uniqs = getSUniques n us
+cloneBindSM subst (Rec pairs)
+ = getUs `thenUs` \ us ->
+ let
+ (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs)
+ in
+ returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
+
+cloneBinders subst bndrs
+ = getUs `thenUs` \ us ->
+ returnUs (substAndCloneIds subst us bndrs)
+
+newIdSM old_id new_ty
+ = getUniqSM `thenSM` \ uniq ->
+ let
+ -- Give the new Id a similar occurrence name to the old one
+ name = idName old_id
+ new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
+ in
+ returnSM new_id
\end{code}
-@cloneLambdaOrCaseBinders@ and @cloneLetrecBinders@ take a bunch of
-binders, and build ``clones'' for them. The clones differ from the
-originals in three ways:
- (a) they have a fresh unique
- (b) they have the current type environment applied to their type
- (c) for letrec binders which have been specialised to unboxed values
- the clone will have a lifted type
+ Old (but interesting) stuff about unboxed bindings
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As well as returning the list of cloned @Id@s they also return a list of
-@CloneInfo@s which the original binders should be bound to.
-
-\begin{code}
-cloneLambdaOrCaseBinders :: [Id] -- Old binders
- -> SpecM ([Id], [CloneInfo]) -- New ones
-
-cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us
- = let
- uniqs = getSUniques (length old_ids) us
- in
- unzip (zipWith clone_it old_ids uniqs)
- where
- clone_it old_id uniq
- = (new_id, NoLift (CoVarAtom new_id))
- where
- new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
-
-cloneLetrecBinders :: [Id] -- Old binders
- -> SpecM ([Id], [CloneInfo]) -- New ones
-
-cloneLetrecBinders old_ids sw_chkr tvenv idenv us
- = let
- uniqs = getSUniques (2 * length old_ids) us
- in
- unzip (clone_them old_ids uniqs)
- where
- clone_them [] [] = []
+What should we do when a value is specialised to a *strict* unboxed value?
- clone_them (old_id:olds) (u1:u2:uniqs)
- | toplevelishId old_id
- = (old_id,
- NoLift (CoVarAtom old_id)) : clone_rest
+ map_*_* f (x:xs) = let h = f x
+ t = map f xs
+ in h:t
- -- Don't clone if it is a top-level thing. Why not?
- -- (a) we don't want to change the uniques
- -- on such things (see TopLevId in Id.lhs)
- -- (b) we don't have to be paranoid about name capture
- -- (c) the thing is polymorphic so no need to subst
+Could convert let to case:
- | otherwise
- = if (isUnboxedDataType new_ty && not (isUnboxedDataType old_ty))
- then (lifted_id,
- Lifted lifted_id unlifted_id) : clone_rest
- else (new_id,
- NoLift (CoVarAtom new_id)) : clone_rest
+ map_*_Int# f (x:xs) = case f x of h# ->
+ let t = map f xs
+ in h#:t
- where
- clone_rest = clone_them olds uniqs
+This may be undesirable since it forces evaluation here, but the value
+may not be used in all branches of the body. In the general case this
+transformation is impossible since the mutual recursion in a letrec
+cannot be expressed as a case.
- new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
- new_ty = getIdUniType new_id
- old_ty = getIdUniType old_id
+There is also a problem with top-level unboxed values, since our
+implementation cannot handle unboxed values at the top level.
- (lifted_id, unlifted_id) = mkLiftedId new_id u2
+Solution: Lift the binding of the unboxed value and extract it when it
+is used:
+ map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
+ t = map f xs
+ in case h of
+ _Lift h# -> h#:t
-cloneTyVarSM :: TyVar -> SpecM TyVar
+Now give it to the simplifier and the _Lifting will be optimised away.
-cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
- = let
- uniq = getSUnique us
- in
- cloneTyVar old_tyvar uniq -- new_tyvar
-
-bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
-
-bindId id val specm sw_chkr tvenv idenv us
- = specm sw_chkr tvenv (addOneToIdEnv idenv id val) us
-
-bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing
-
-bindIds olds news specm sw_chkr tvenv idenv us
- = specm sw_chkr tvenv (growIdEnvList idenv (zip olds news)) us
-
-bindSpecIds :: [Id] -- Old
- -> [(CloneInfo)] -- New
- -> [[SpecInfo]] -- Corresponding specialisations
- -- Each sub-list corresponds to a different type,
- -- and contains one spec_info for each id
- -> SpecM thing
- -> SpecM thing
-
-bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us
- = specm sw_chkr tvenv (growIdEnvList idenv old_to_clone) us
- where
- old_to_clone = mk_old_to_clone olds clones spec_infos
-
- -- The important thing here is that we are *lazy* in spec_infos
- mk_old_to_clone [] [] _ = []
- mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos
- = (old, add_spec_info clone) :
- mk_old_to_clone rest_olds rest_clones spec_infos_rest
- where
- add_spec_info (NoLift (CoVarAtom new))
- = NoLift (CoVarAtom (new `addIdSpecialisation`
- (mkSpecEnv spec_infos_this_id)))
- add_spec_info lifted
- = lifted -- no specialised instances for unboxed lifted values
-
- spec_infos_this_id = map head spec_infos
- spec_infos_rest = map tail spec_infos
-
-{- UNUSED: creating specialised constructors
-bindConIds :: [Id] -- Old constructors
- -> [[SpecInfo]] -- Corresponding specialisations to be added
- -- Each sub-list corresponds to one constructor, and
- -- gives all its specialisations
- -> SpecM thing
- -> SpecM thing
-
-bindConIds ids spec_infos specm sw_chkr tvenv idenv us
- = specm sw_chkr tvenv (growIdEnvList idenv id_to_newspec) us
- where
- id_to_newspec = mk_id_to_newspec ids spec_infos
-
- -- The important thing here is that we are *lazy* in spec_infos
- mk_id_to_newspec [] _ = []
- mk_id_to_newspec (id:rest_ids) spec_infos
- = (id, CoVarAtom id_with_spec) :
- mk_id_to_newspec rest_ids spec_infos_rest
- where
- id_with_spec = id `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)
- spec_infos_this_id = head spec_infos
- spec_infos_rest = tail spec_infos
--}
-
-bindTyVar :: TyVar -> UniType -> SpecM thing -> SpecM thing
-
-bindTyVar tyvar ty specm sw_chkr tvenv idenv us
- = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
-\end{code}
+The benfit is that we have given the specialised "unboxed" values a
+very simplep lifted semantics and then leave it up to the simplifier to
+optimise it --- knowing that the overheads will be removed in nearly
+all cases.
-\begin{code}
-lookupId :: Id -> SpecM CloneInfo
+In particular, the value will only be evaluted in the branches of the
+program which use it, rather than being forced at the point where the
+value is bound. For example:
-lookupId id sw_chkr tvenv idenv us
- = case lookupIdEnv idenv id of
- Nothing -> NoLift (CoVarAtom id)
- Just info -> info
-\end{code}
+ filtermap_*_* p f (x:xs)
+ = let h = f x
+ t = ...
+ in case p x of
+ True -> h:t
+ False -> t
+ ==>
+ filtermap_*_Int# p f (x:xs)
+ = let h = case (f x) of h# -> _Lift h#
+ t = ...
+ in case p x of
+ True -> case h of _Lift h#
+ -> h#:t
+ False -> t
-\begin{code}
-specTy :: UniType -> SpecM UniType -- Apply the current type envt to the type
+The binding for h can still be inlined in the one branch and the
+_Lifting eliminated.
-specTy ty sw_chkr tvenv idenv us
- = applyTypeEnvToTy tvenv ty
-\end{code}
-\begin{code}
-liftId :: Id -> SpecM (Id, Id)
-liftId id sw_chkr tvenv idenv us
- = let
- uniq = getSUnique us
- in
- mkLiftedId id uniq
-\end{code}
+Question: When won't the _Lifting be eliminated?
-In other monads these @mapSM@ things are usually called @listM@.
-I think @mapSM@ is a much better name. The `2' and `3' variants are
-when you want to return two or three results, and get at them
-separately. It saves you having to do an (unzip stuff) right after.
+Answer: When they at the top-level (where it is necessary) or when
+inlining would duplicate work (or possibly code depending on
+options). However, the _Lifting will still be eliminated if the
+strictness analyser deems the lifted binding strict.
-\begin{code}
-mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
-mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
-mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
-mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
-
-mapSM f [] = returnSM []
-mapSM f (x:xs) = f x `thenSM` \ r ->
- mapSM f xs `thenSM` \ rs ->
- returnSM (r:rs)
-
-mapAndUnzipSM f [] = returnSM ([],[])
-mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
- mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
- returnSM ((r1:rs1),(r2:rs2))
-
-mapAndUnzip3SM f [] = returnSM ([],[],[])
-mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
- mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
- returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
-
-mapAndUnzip4SM f [] = returnSM ([],[],[],[])
-mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
- mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
- returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
-\end{code}
projects / ghc-hetmet.git / blobdiff