%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
%
\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
specProgram,
initSpecData,
- SpecialiseData(..),
- FiniteMap, Bag
-
+ SpecialiseData(..)
) where
-import PlainCore
-import SpecTyFuns
-
-IMPORT_Trace
-import Outputable -- ToDo: these may be removable...
-import Pretty
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(partition))
-import AbsPrel ( liftDataCon, PrimOp(..), PrimKind -- for CCallOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
+ partitionBag, listToBag, bagToList
+ )
+import Class ( GenClass{-instance Eq-} )
+import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
+ opt_CompilingGhcInternals, opt_SpecialiseTrace,
+ opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
+ opt_SpecialiseAll
)
-import AbsUniType
-import Bag
-import CmdLineOpts ( GlobalSwitch(..) )
import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
-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 CoreSyn
+import CoreUtils ( coreExprType, squashableDictishCcExpr )
+import FiniteMap ( addListToFM_C, FiniteMap )
+import Kind ( mkBoxedTypeKind )
+import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
+ isSuperDictSelId_maybe, isBottomingId,
+ isConstMethodId_maybe, isDataCon,
+ isImportedId, mkIdWithNewUniq,
+ dataConTyCon, applyTypeEnvToId,
+ nullIdEnv, addOneToIdEnv, growIdEnvList,
+ lookupIdEnv, SYN_IE(IdEnv),
+ emptyIdSet, mkIdSet, unitIdSet,
+ elementOfIdSet, minusIdSet,
+ unionIdSets, unionManyIdSets, SYN_IE(IdSet),
+ GenId{-instance Eq-}
+ )
+import Literal ( Literal{-instance Outputable-} )
+import Maybes ( catMaybes, firstJust, maybeToBool )
+import Name ( isLocallyDefined )
+import Outputable ( interppSP, Outputable(..){-instance * []-} )
+import PprStyle ( PprStyle(..) )
+import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
+ GenType{-instance Outputable-}, GenTyVar{-ditto-},
+ TyCon{-ditto-}
+ )
+import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
+ ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty)
+ )
+import PrimOp ( PrimOp(..) )
+import SpecUtils
+import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
+ tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
+ )
+import TyCon ( TyCon{-instance Eq-} )
+import TyVar ( cloneTyVar, mkSysTyVar,
+ elementOfTyVarSet, SYN_IE(TyVarSet),
+ nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv),
+ GenTyVar{-instance Eq-}
+ )
+import TysWiredIn ( liftDataCon )
+import Unique ( Unique{-instance Eq-} )
+import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
+import UniqSupply ( splitUniqSupply, getUniques, getUnique )
+import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
+ thenCmp, panic, pprTrace, pprPanic, assertPanic
+ )
infixr 9 `thenSM`
+
+--ToDo:kill
+data SpecInfo = SpecInfo [Maybe Type] Int Id
+lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
+addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
+cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
+getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
+isClassOpId = panic "Specialise.isClassOpId (ToDo)"
+isDictTy = panic "Specialise.isDictTy (ToDo)"
+isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
+isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
+isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
+isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)"
+lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)"
+mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
+mkSpecId = panic "Specialise.mkSpecId (ToDo)"
+selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
+specialiseTy = panic "Specialise.specialiseTy (ToDo)"
\end{code}
%************************************************************************
let f = <f_rhs>
in <body>
-and suppose f is overloaded.
+and suppose f is overloaded.
STEP 1: CALL-INSTANCE COLLECTION
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?
+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
+ SpecialiseAll
STEP 2: EQUIVALENCES
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
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 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.
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.)
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
+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.
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
+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.
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.
+substitute these in the Con 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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SpecInfo
- [Maybe UniType] -- Instance types
+ [Maybe Type] -- Instance types
Int -- No of dicts to eat
Id -- Specialised version
-For example, if f has this SpecInfo:
+For example, if f has this SpecInfo:
SpecInfo [Just t1, Nothing, Just t3] 2 f'
==.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
~~~~~~~~~~~~~
What about types/classes mentioned in SPECIALIZE pragmas spat out,
but not otherwise exported. Even if they are exported, what about
-their original names.
+their original names.
Suggestion: use qualified names in pragmas, omitting module for
prelude and "this module".
map_*_* f (x:xs) = let h = f x
t = map f xs
- in h:t
+ 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
+ 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
is used:
map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
- t = map f xs
- in case h of
+ 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.
filtermap_*_* p f (x:xs)
= let h = f x
t = ...
- in case p x of
+ 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
+ in case p x of
True -> case h of _Lift h#
-> h#:t
False -> t
%************************************************************************
\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
+type FreeVarsSet = IdSet
+type FreeTyVarsSet = TyVarSet
+
+data CallInstance
+ = CallInstance
+ Id -- This Id; *new* ie *cloned* id
+ [Maybe Type] -- Specialised at these types (*new*, cloned)
+ -- Nothing => no specialisation on this type arg
+ -- is required (flag dependent).
+ [CoreArg] -- 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}
\begin{code}
= 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)
+ Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
+ Just (SpecInfo _ _ spec_id)
-> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
])
+-- ToDo: instance Outputable CoreArg?
+ppr_arg sty (TyArg t) = ppr sty t
+ppr_arg sty (LitArg i) = ppr sty i
+ppr_arg sty (VarArg v) = ppr sty v
+
isUnboxedCI :: CallInstance -> Bool
isUnboxedCI (CallInstance _ spec_tys _ _ _)
- = any isUnboxedDataType (catMaybes spec_tys)
+ = any isUnboxedType (catMaybes spec_tys)
isExplicitCI :: CallInstance -> Bool
isExplicitCI (CallInstance _ _ _ _ (Just _))
\begin{code}
cmpCI :: CallInstance -> CallInstance -> TAG_
-cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
- = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
+ = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
cmpCI_tys :: CallInstance -> CallInstance -> TAG_
cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
= cmpUniTypeMaybeList tys1 tys2
+eqCI_tys :: CallInstance -> CallInstance -> Bool
+eqCI_tys c1 c2
+ = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
+
isCIofTheseIds :: [Id] -> CallInstance -> Bool
-isCIofTheseIds ids (CallInstance ci_id _ _ _ _) = any (eqId ci_id) ids
+isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
+ = any ((==) ci_id) ids
-singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails
+singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
singleCI id tys dicts
= UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
- emptyBag [] emptyUniqSet
+ emptyBag [] emptyIdSet 0 0
where
- fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts])
+ fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
-explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails
+explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
explicitCI id tys specinfo
- = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet
+ = UsageDetails (unitBag call_inst) emptyBag [] emptyIdSet 0 0
where
call_inst = CallInstance id tys dicts fv_set (Just specinfo)
dicts = panic "Specialise:explicitCI:dicts"
- fv_set = singletonUniqSet id
+ fv_set = unitIdSet id
+
+-- We do not process the CIs for top-level dfuns or defms
+-- Instead we require an explicit SPEC inst pragma for dfuns
+-- and an explict method within any instances for the defms
-getCIs :: [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
-getCIs ids (UsageDetails cis tycon_cis dbs fvs)
+getCIids :: Bool -> [Id] -> [Id]
+getCIids True ids = filter not_dict_or_defm ids
+getCIids _ ids = ids
+
+not_dict_or_defm id
+ = not (isDictTy (idType id) || maybeToBool (isDefaultMethodId_maybe id))
+
+getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
+getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
= let
- (cis_here, cis_not_here) = partitionBag (isCIofTheseIds ids) cis
+ (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev 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)
+ -- (ppHang (ppBesides [ppStr "{",
+ -- interppSP PprDebug ids,
+ -- ppStr "}"])
+ -- 4 (ppAboves (map pprCI cis_here_list)))
+ (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
dumpCIs :: Bag CallInstance -- The call instances
+ -> Bool -- True <=> top level bound Ids
+ -> Bool -- True <=> dict bindings to be floated (specBind only)
+ -> [CallInstance] -- Call insts for bound ids (instBind only)
-> [Id] -- Bound ids *new*
+ -> [Id] -- Full bound ids: includes dumped dicts
-> 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
+
+ -- CIs are dumped if:
+ -- 1) they are a CI for one of the bound ids, or
+ -- 2) they mention any of the dicts in a local unfloated binding
+ --
+ -- For top-level bindings we allow the call instances to
+ -- float past a dict bind and place all the top-level binds
+ -- in a *global* Rec.
+ -- We leave it to the simplifier will sort it all out ...
+
+dumpCIs cis top_lev floating inst_cis bound_ids full_ids
+ = (if not (isEmptyBag cis_of_bound_id) &&
+ not (isEmptyBag cis_of_bound_id_without_inst_cis)
+ then
+ pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
+ " (may be a non-HM recursive call)\n")
+ (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug bound_ids,
+ ppStr "}"])
+ 4 (ppAboves [ppStr "Dumping CIs:",
+ ppAboves (map pprCI (bagToList cis_of_bound_id)),
+ ppStr "Instantiating CIs:",
+ ppAboves (map pprCI inst_cis)]))
+ else id) (
+ if top_lev || floating then
+ cis_not_bound_id
+ else
+ (if not (isEmptyBag cis_dump_unboxed)
+ then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
+ (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug full_ids,
+ ppStr "}"])
+ 4 (ppAboves (map pprCI (bagToList cis_dump))))
+ else id)
+ cis_keep_not_bound_id
+ )
where
- (cis_dump, cis_keep) = partitionBag mentions_bound_ids cis
+ (cis_of_bound_id, cis_not_bound_id)
+ = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
+
+ (cis_dump, cis_keep_not_bound_id)
+ = partitionBag ok_to_dump_ci cis_not_bound_id
+
+ ok_to_dump_ci (CallInstance _ _ _ fv_set _)
+ = any (\ i -> i `elementOfIdSet` fv_set) full_ids
- mentions_bound_ids (CallInstance _ _ _ fv_set _)
- = or [i `elementOfUniqSet` fv_set | i <- bound_ids]
+ (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
+ have_inst_ci ci = any (eqCI_tys ci) inst_cis
- (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
+ (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
\end{code}
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
+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#).
-ToDo: We should check this rather than just dumping them.
+We check this in dumpCIs by passing in all the instantiated call
+instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
+for which there is no such instance.
-However, we do report any call instances which are mysteriously dumped
-because they have a dictionary argument which is bound here ...
-
-ToDo: Under what circumstances does this occur, if at all?
+We also report CIs dumped due to a bound dictionary arg if they
+contain unboxed types.
%************************************************************************
%* *
\begin{code}
data TyConInstance
= TyConInstance TyCon -- Type Constructor
- [Maybe UniType] -- Applied to these specialising types
+ [Maybe Type] -- 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 (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
+ = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
-cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
+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
+singleTyConI :: TyCon -> [Maybe Type] -> UsageDetails
+singleTyConI ty_con spec_tys
+ = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyIdSet 0 0
isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
-isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con
+isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = 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)
+getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
= 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)
+ (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
\end{code}
\begin{code}
data UsageDetails
- = 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)
+ Int -- no. of spec calls
+ Int -- no. of spec insts
\end{code}
The DictBindDetails are fully processed; their call-instance information is
A @DictBindDetails@ contains bindings for dictionaries *only*.
\begin{code}
-data DictBindDetails
- = DictBindDetails
+data DictBindDetails
+ = DictBindDetails
[Id] -- Main binders, originally visible in scope of binding (cloned)
- PlainCoreBinding -- Fully processed
+ CoreBinding -- Fully processed
FreeVarsSet -- Free in binding group (cloned)
FreeTyVarsSet -- Free in binding group
\end{code}
unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
unionUDList :: [UsageDetails] -> UsageDetails
-emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet
+-- tickSpecCall :: Bool -> UsageDetails -> UsageDetails
+tickSpecInsts :: UsageDetails -> UsageDetails
+
+-- tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
+-- = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
+
+tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
+ = UsageDetails cis ty_cis dbs fvs c (i+1)
-unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2)
+emptyUDs = UsageDetails emptyBag emptyBag [] emptyIdSet 0 0
+
+unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
= UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
- (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2)
+ (dbs1 ++ dbs2) (fvs1 `unionIdSets` fvs2) (c1+c2) (i1+i2)
-- 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 (VarArg v) | not (isImportedId v)
+ = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
singleFvUDs other
= emptyUDs
-singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con)
+singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
-dumpDBs :: [DictBindDetails]
+dumpDBs :: [DictBindDetails]
+ -> Bool -- True <=> top level bound Ids
-> [TyVar] -- TyVars being bound (cloned)
-> [Id] -- Ids being bound (cloned)
-> FreeVarsSet -- Fvs of body
- -> ([PlainCoreBinding], -- These ones have to go here
+ -> ([CoreBinding], -- 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
+ FreeVarsSet -- Incoming 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]
+ -- It is just to complex to try to float top-level
+ -- dict bindings with constant methods, inst methods,
+ -- auxillary derived instance defns and user instance
+ -- defns all getting in the way.
+ -- So we dump all dbinds as soon as we get to the top
+ -- level and place them in a *global* Rec.
+ -- We leave it to the simplifier will sort it all out ...
+
+dumpDBs [] top_lev bound_tyvars bound_ids fvs
+ = ([], [], bound_ids, fvs)
+
+dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
+ top_lev bound_tyvars bound_ids fvs
+ | top_lev
+ || any (\ i -> i `elementOfIdSet` db_fvs) bound_ids
+ || any (\ t -> t `elementOfTyVarSet` db_ftv) 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)
+ = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionIdSets` fvs)
in
(dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
| otherwise -- This one can float out further
= let
(dbinds_here, dbs_outer, full_bound_ids, full_fvs)
- = dumpDBs dbs bound_tyvars bound_ids fvs
+ = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
in
(dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
-
+
dumpUDs :: UsageDetails
+ -> Bool -- True <=> top level bound Ids
+ -> Bool -- True <=> dict bindings to be floated (specBind only)
+ -> [CallInstance] -- Call insts for bound Ids (instBind only)
-> [Id] -- Ids which are just being bound; *new*
-> [TyVar] -- TyVars which are just being bound
- -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids
+ -> ([CoreBinding], -- 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
+dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis 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)
+ (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
+ = dumpDBs dbs top_lev tvs bound_ids fvs
+ cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
+ fvs_outer = full_fvs `minusIdSet` (mkIdSet full_bound_ids)
in
- (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer)
+ (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
\end{code}
\begin{code}
-addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails -- Dict binding and RHS usage
+addDictBinds :: [Id] -> CoreBinding -> 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)
+addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
+ (UsageDetails cis tycon_cis dbs fvs c i)
= UsageDetails (db_cis `unionBags` cis)
(db_tycon_cis `unionBags` tycon_cis)
- (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
- fvs
+ (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
+ fvs c i
+ -- NB: We ignore counts from dictbinds since it is not user code
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.
+ -- 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))
+ db_ftvs = tyVarsOfTypes (map idType dbinders)
\end{code}
%************************************************************************
@SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
-1) (NoLift CoLitAtom l) : an Id which is bound to a literal
+1) (NoLift LitArg l) : an Id which is bound to a literal
-2) (NoLift CoLitAtom l) : an Id bound to a "new" Id
+2) (NoLift LitArg 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 :
type SpecIdEnv = IdEnv CloneInfo
data CloneInfo
- = NoLift PlainCoreAtom -- refers to cloned id or literal
+ = NoLift CoreArg -- refers to cloned id or literal
| Lifted Id -- lifted, cloned id
Id -- unlifted, cloned id
[TyCon]
-- Those in-scope data types for which we want to
-- generate code for their constructors.
- -- Namely: data types declared in this module +
+ -- 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]])
+ (FiniteMap TyCon [(Bool, [Maybe Type])])
-- TyCon specialisations to be generated
- -- We generate specialisations for data types defined
- -- in this module and any tuples used in this module
+ -- We generate specialialised code (Bool=True) 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
+ -- requested by source-level SPECIALIZE data pragmas (Bool=True)
+ -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
- (Bag (Id,[Maybe UniType]))
+ (Bag (Id,[Maybe Type]))
-- Imported specialisation errors
- (Bag (Id,[Maybe UniType]))
+ (Bag (Id,[Maybe Type]))
-- Imported specialisation warnings
- (Bag (TyCon,[Maybe UniType]))
+ (Bag (TyCon,[Maybe Type]))
-- Imported TyCon specialisation errors
initSpecData local_tycons tycon_specs
%************************************************************************
\begin{code}
-specProgram :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> [PlainCoreBinding] -- input ...
+specProgram :: UniqSupply
+ -> [CoreBinding] -- input ...
-> SpecialiseData
- -> ([PlainCoreBinding], -- main result
+ -> ([CoreBinding], -- main result
SpecialiseData) -- result specialise data
-specProgram sw_chker uniqs binds
+specProgram 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)
+ = case (initSM (specTyConsAndScope (specTopBinds binds)) uniqs) of
+ (final_binds, tycon_specs_list,
+ UsageDetails import_cis import_tycis _ fvs spec_calls spec_insts)
-> let
used_conids = filter isDataCon (uniqSetToList fvs)
- used_tycons = map getDataConTyCon used_conids
+ used_tycons = map dataConTyCon used_conids
used_gen = filter isLocalGenTyCon used_tycons
- gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen)
+ gen_tycons = uniqSetToList (mkUniqSet local_tycons `unionUniqSets` mkUniqSet 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_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list
cis_warn = init_warn `unionBags` listToBag cis_other
cis_errs = init_errs `unionBags` listToBag cis_unboxed
tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
- && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn)
+ && (not opt_SpecialiseImports || isEmptyBag cis_warn)
in
+ (if opt_D_simplifier_stats then
+ pprTrace "\nSpecialiser Stats:\n" (ppAboves [
+ ppBesides [ppStr "SpecCalls ", ppInt spec_calls],
+ ppBesides [ppStr "SpecInsts ", ppInt spec_insts],
+ ppSP])
+ else id)
+
(final_binds,
SpecData True no_errs local_tycons gen_tycons result_specs
- cis_errs cis_warn tycis_errs)
+ cis_errs cis_warn tycis_errs)
-specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _)
+specProgram uniqs binds (SpecData True _ _ _ _ _ _ _)
= panic "Specialise:specProgram: specialiser called more than once"
--- It may be possible safely to call the specialiser 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 ???
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!
+ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
\begin{code}
-specTyConsAndScope :: SpecM ([PlainCoreBinding], UsageDetails)
- -> SpecM ([PlainCoreBinding], [(TyCon,[[Maybe UniType]])], UsageDetails)
+specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
+ -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
specTyConsAndScope scopeM
= scopeM `thenSM` \ (binds, scope_uds) ->
- getSwitchCheckerSM `thenSM` \ sw_chkr ->
let
(tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds
+ = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds
tycon_specs_list = collectTyConSpecs tycons_cis
in
- (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then
+ (if opt_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])
+ (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)
)
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)
-
- 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)
-
- tycon_specs = [spec_tys | TyConInstance _ spec_tys <- uniq_cis]
-
- 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)
+ (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
+ uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
+ tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
- copy_arity_info old new = addIdArity new (getDataConArity old)
+ pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
- pp_inst (TyConInstance _ spec_tys)
- = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- spec_tys]
--}
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-specTopBinds :: [PlainCoreBinding]
- -> SpecM ([PlainCoreBinding], UsageDetails)
+specTopBinds :: [CoreBinding]
+ -> SpecM ([CoreBinding], UsageDetails)
specTopBinds binds
- = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs) ->
+ = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs c i) ->
let
-- Add bindings for floated dbinds and collect fvs
-- In actual fact many of these bindings are dead code since dict
(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))
+ full_fvs = fvs `unionIdSets` unionManyIdSets dfvs_s
+ fvs_outer = full_fvs `minusIdSet` (mkIdSet (concat dbinders_s))
+
+ -- It is just to complex to try to sort out top-level dependencies
+ -- So we just place all the top-level binds in a *global* Rec and
+ -- leave it to the simplifier to sort it all out ...
in
- returnSM (dbinds ++ binds, UsageDetails cis tycis [] fvs_outer)
+ ASSERT(null dbinds)
+ returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
where
spec_top_binds (first_bind:rest_binds)
- = specBindAndScope True {- top level -} first_bind (
+ = specBindAndScope True 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)
+ ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) ->
+ returnSM (first_binds ++ rest_binds, all_uds)
spec_top_binds []
= returnSM ([], emptyUDs)
%************************************************************************
\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 ->
+specExpr :: CoreExpr
+ -> [CoreArg] -- The arguments:
+ -- TypeArgs are speced
+ -- ValArgs are unprocessed
+ -> SpecM (CoreExpr, -- Result expression with specialised versions installed
+ UsageDetails)-- Details of usage of enclosing binders in the result
+ -- expression.
+
+specExpr (Var 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))
+ returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg 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)
+ NoLift vatom@(VarArg new_v)
+ -> mapSM specOutArg args `thenSM` \ arg_info ->
+ mkCallInstance v new_v arg_info `thenSM` \ call_uds ->
+ mkCall new_v arg_info `thenSM` \ call ->
+ let
+ uds = unionUDList [call_uds,
+ singleFvUDs vatom,
+ unionUDList [uds | (_,uds,_) <- arg_info]
+ ]
+ in
+ returnSM (call, {- tickSpecCall speced -} uds)
-specExpr expr@(CoLit _) null_args
+specExpr expr@(Lit _) 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
+specExpr (Con con 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,
+ let
+ (targs, vargs) = partition_args args
+ in
+ mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
+ mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
+ mkTyConInstance con tys `thenSM` \ con_uds ->
+ returnSM (applyBindUnlifts unlifts (Con con (targs ++ vargs)),
unionUDList args_uds_s `unionUDs` con_uds)
--}
-specExpr (CoPrim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args
+specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) 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),
+ let
+ (targs, vargs) = partition_args args
+ in
+ ASSERT (null targs)
+ mapSM specTy arg_tys `thenSM` \ arg_tys ->
+ specTy res_ty `thenSM` \ res_ty ->
+ mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
+ returnSM (applyBindUnlifts unlifts (Prim (CCallOp str is_asm may_gc arg_tys res_ty) vargs),
unionUDList args_uds_s)
-specExpr (CoPrim prim tys args) null_args
+specExpr (Prim prim args) null_args
= ASSERT (null null_args)
- mapSM specTy tys `thenSM` \ tys ->
- mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) ->
+ let
+ (targs, vargs) = partition_args args
+ in
+ mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
+ mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
-- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (applyBindUnlifts unlifts (CoPrim prim tys args),
+ returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)),
unionUDList args_uds_s {-`unionUDs` prim_uds-} )
{- ToDo: specPrimOp
specPrimOp :: PrimOp
- -> [UniType]
+ -> [Type]
-> SpecM (PrimOp,
- [UniType],
+ [Type],
UsageDetails)
-- Checks that PrimOp can handle (possibly unboxed) tys passed
-- 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
+-- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
-}
-specExpr (CoApp fun arg) args
- = -- Arg is passed on unprocessed
- specExpr fun (ValArg arg : args) `thenSM` \ (expr,uds) ->
+specExpr (App fun arg) args
+ = -- If TyArg, arg will be processed; otherwise, left alone
+ preSpecArg arg `thenSM` \ new_arg ->
+ specExpr fun (new_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 (Lam (ValBinder binder) body) (arg : args) | isValArg arg
+ = lookup_arg arg `thenSM` \ arg ->
+ bindId binder arg (specExpr body args)
+ where
+ lookup_arg (LitArg l) = returnSM (NoLift (LitArg l))
+ lookup_arg (VarArg v) = lookupId v
-specExpr (CoLam bound_ids body) args
- = specLam bound_ids body args
+specExpr (Lam (ValBinder binder) body) []
+ = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
+ returnSM (Lam (ValBinder binder) body, uds)
-specExpr (CoTyLam tyvar body) (TypeArg ty : args)
+specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
= -- Type lambda with argument; argument already spec'd
- bindTyVar tyvar ty (
- specExpr body args
- )
+ bindTyVar tyvar ty ( specExpr body args )
-specExpr (CoTyLam tyvar body) []
+specExpr (Lam (TyBinder 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)
+ (binds_here, final_uds) = dumpUDs body_uds False False [] [] [new_tyvar]
+ in
+ returnSM (Lam (TyBinder new_tyvar)
+ (mkCoLetsNoUnboxed binds_here body),
+ final_uds)
)
-specExpr (CoCase scrutinee alts) args
+specExpr (Case 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)
+ returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
where
- scrutinee_type = typeOfCoreExpr scrutinee
-
+ scrutinee_type = coreExprType scrutinee
-specExpr (CoLet bind body) args
- = specBindAndScope False {- not top level -} bind (
+specExpr (Let bind body) args
+ = specBindAndScope False 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)
+ returnSM (mkCoLetsUnboxedToCase binds body, all_uds)
-specExpr (CoSCC cc expr) args
- = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
- mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) ->
+specExpr (SCC cc expr) args
+ = specExpr expr [] `thenSM` \ (expr, expr_uds) ->
+ mapAndUnzip3SM specOutArg args `thenSM` \ (args, args_uds_s, unlifts) ->
let
scc_expr
= if squashableDictishCcExpr cc expr -- can toss the _scc_
then expr
- else CoSCC cc expr
+ else SCC cc expr
in
- returnSM (applyBindUnlifts unlifts (applyToArgs scc_expr args),
+ returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
unionUDList args_uds_s `unionUDs` expr_uds)
--- ToDo:DPH: add stuff here!
+specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
+
+-- ToDo: This may leave some unspec'd dictionaries!!
\end{code}
%************************************************************************
%************************************************************************
\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
+ -> CoreExpr -- The body
+ -> [CoreArg] -- Its args
-> SpecM ([Id], -- New binders
- PlainCoreExpr, -- New body
+ CoreExpr, -- New body
UsageDetails)
specLambdaOrCaseBody bound_ids body args
specExpr body args `thenSM` \ (body, body_uds) ->
let
- -- Dump any dictionary bindings (and call instances)
+ -- Dump any dictionary bindings (and call instances)
-- from the scope which mention things bound here
- (binds_here, final_uds) = dumpUDs body_uds new_ids []
+ (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
in
returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
)
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}
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:
Though this is still invalid, after further simplification we get:
op1_Int_Int# = opInt1 {Int#}
-
+
Another round of specialisation will result in the specialised
version of op1Int being called directly.
\begin{code}
-specAlts (CoAlgAlts alts deflt) scrutinee_ty args
+specAlts (AlgAlts 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,
+ returnSM (AlgAlts 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
+ -- We use ty_args of scrutinee type to identify specialisation of
+ -- alternatives:
- 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)
+ (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
+ getAppDataTyConExpandingDicts scrutinee_ty
-{- 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)
--}
+ returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
-specAlts (CoPrimAlts alts deflt) scrutinee_ty args
+specAlts (PrimAlts alts deflt) scrutinee_ty args
= mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- returnSM (CoPrimAlts alts deflt,
+ returnSM (PrimAlts 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
+specDeflt NoDefault args = returnSM (NoDefault, emptyUDs)
+specDeflt (BindDefault binder rhs) args
= specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
- returnSM (CoBindDefault binder rhs, uds)
+ returnSM (BindDefault binder rhs, uds)
\end{code}
%************************************************************************
\begin{code}
-specAtom :: PlainCoreAtom -> SpecM (PlainCoreAtom, UsageDetails,
- PlainCoreExpr -> PlainCoreExpr)
+partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
+partition_args args
+ = span is_ty_arg args
+ where
+ is_ty_arg (TyArg _) = True
+ is_ty_arg _ = False
-specAtom (CoLitAtom lit)
- = returnSM (CoLitAtom lit, emptyUDs, id)
+----------
+preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else
-specAtom (CoVarAtom v)
+preSpecArg (TyArg ty)
+ = specTy ty `thenSM` \ new_ty ->
+ returnSM (TyArg new_ty)
+
+preSpecArg other = returnSM other
+
+--------------------
+specValArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+ CoreExpr -> CoreExpr)
+
+specValArg (LitArg lit)
+ = returnSM (LitArg lit, emptyUDs, id)
+
+specValArg (VarArg v)
= lookupId v `thenSM` \ vlookup ->
- case vlookup of
+ case vlookup of
Lifted vl vu
- -> returnSM (CoVarAtom vu, singleFvUDs (CoVarAtom vl), bindUnlift vl vu)
+ -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
NoLift vatom
-> returnSM (vatom, singleFvUDs vatom, id)
-specArg :: PlainCoreArg -> SpecM (PlainCoreArg, UsageDetails,
- PlainCoreExpr -> PlainCoreExpr)
+------------------
+specTyArg (TyArg ty)
+ = specTy ty `thenSM` \ new_ty ->
+ returnSM (TyArg new_ty, new_ty)
+
+--------------
+specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
+ CoreExpr -> CoreExpr)
-specArg (ValArg arg) -- unprocessed; spec the atom
- = specAtom arg `thenSM` \ (arg, uds, unlift) ->
- returnSM (ValArg arg, uds, unlift)
+specOutArg (TyArg ty) -- already speced; no action
+ = returnSM (TyArg ty, emptyUDs, id)
-specArg (TypeArg ty) -- already speced; no action
- = returnSM (TypeArg ty, emptyUDs, id)
+specOutArg other_arg -- unprocessed; spec the atom
+ = specValArg other_arg
\end{code}
A classic case of when having a polymorphic recursive function would help!
\begin{code}
-data BindsOrExpr = ItsABinds [PlainCoreBinding]
- | ItsAnExpr PlainCoreExpr
+data BindsOrExpr = ItsABinds [CoreBinding]
+ | ItsAnExpr CoreExpr
\end{code}
\begin{code}
-specBindAndScope
+specBindAndScope
:: Bool -- True <=> a top level group
- -> PlainCoreBinding -- As yet unprocessed
+ -> CoreBinding -- As yet unprocessed
-> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
- -> SpecM ([PlainCoreBinding], -- Processed
+ -> SpecM ([CoreBinding], -- 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) ->
+specBindAndScope top_lev bind scopeM
+ = cloneLetBinders top_lev (is_rec bind) 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.
+ -- Two cases now: either this is a bunch of local 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 from processing the scope
- 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.
- --
- -- Solution: float the constant methods in the same way as dictionaries
- --
- -- 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.
+ if not top_lev && all (isDictTy . idType) binders
+ then
+ -- Ha! A group of local dictionary bindings
bindIds binders clone_infos (
-- Process the dictionary bindings themselves
- specBind new_binders bind `thenSM` \ (bind, rhs_uds) ->
+ specBind False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
-- Process their scope
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
+ scopeM `thenSM` \ (thing, scope_uds) ->
+ let
-- Add the bindings to the current stuff
final_uds = addDictBinds new_binders bind rhs_uds scope_uds
in
returnSM ([], thing, final_uds)
)
else
- -- Ho! A group of ordinary (non-dict) bindings
+ -- Ho! A group of bindings
+
fixSM (\ ~(_, _, _, rec_spec_infos) ->
- bindSpecIds binders clone_infos 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
+ let
+ (call_insts, gotci_scope_uds) = getCIs top_lev new_binders scope_uds
+
+ equiv_ciss = equivClasses cmpCI_tys call_insts
+ inst_cis = map head equiv_ciss
in
-- Do the bindings themselves
- specBind new_binders bind `thenSM` \ (spec_bind, spec_uds) ->
+ specBind top_lev False new_binders inst_cis 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) ->
+ instBind top_lev new_binders bind equiv_ciss inst_cis
+ `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))
- ]
-
+ -- NB: dumpUDs only worries about new_binders since the free var
+ -- stuff only records free new_binders
+ -- The spec_ids only appear in SpecInfos and final speced calls
+
+ -- Build final binding group and usage details
+ (final_binds, final_uds)
+ = if top_lev then
+ -- For a top-level binding we have to dumpUDs from
+ -- spec_uds and inst_uds and scope_uds creating
+ -- *global* dict bindings
+ let
+ (scope_dict_binds, final_scope_uds)
+ = dumpUDs gotci_scope_uds True False [] new_binders []
+ (spec_dict_binds, final_spec_uds)
+ = dumpUDs spec_uds True False inst_cis new_binders []
+ (inst_dict_binds, final_inst_uds)
+ = dumpUDs inst_uds True False inst_cis new_binders []
+ in
+ ([spec_bind] ++ inst_binds ++ scope_dict_binds
+ ++ spec_dict_binds ++ inst_dict_binds,
+ final_spec_uds `unionUDs` final_scope_uds `unionUDs` final_inst_uds)
+ else
+ -- For a local binding we only have to dumpUDs from
+ -- scope_uds since the UDs from spec_uds and inst_uds
+ -- have already been dumped by specBind and instBind
+ let
+ (scope_dict_binds, final_scope_uds)
+ = dumpUDs gotci_scope_uds False False [] new_binders []
+ in
+ ([spec_bind] ++ inst_binds ++ scope_dict_binds,
+ spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds)
+
+ -- inst_uds comes last, because there may be dict bindings
+ -- floating outward in 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.
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)
- )
+ returnSM (final_binds, thing, final_uds, 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!
-
+ is_rec (NonRec _ _) = False
+ is_rec _ = True
+\end{code}
\begin{code}
-specBind :: [Id] -> PlainCoreBinding -> SpecM (PlainCoreBinding, UsageDetails)
+specBind :: Bool -> Bool -> [Id] -> [CallInstance]
+ -> CoreBinding
+ -> SpecM (CoreBinding, 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 top_lev floating new_binders inst_cis (NonRec binder rhs)
+ = specOneBinding top_lev floating new_binders inst_cis (binder,rhs)
+ `thenSM` \ ((binder,rhs), rhs_uds) ->
+ returnSM (NonRec 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)
+specBind top_lev floating new_binders inst_cis (Rec pairs)
+ = mapAndUnzipSM (specOneBinding top_lev floating new_binders inst_cis) pairs
+ `thenSM` \ (pairs, rhs_uds_s) ->
+ returnSM (Rec pairs, unionUDList rhs_uds_s)
-specOneBinding :: [Id] -> (Id,PlainCoreExpr) -> SpecM ((Id,PlainCoreExpr), UsageDetails)
+specOneBinding :: Bool -> Bool -> [Id] -> [CallInstance]
+ -> (Id,CoreExpr)
+ -> SpecM ((Id,CoreExpr), UsageDetails)
-specOneBinding new_binders (binder, rhs)
+specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
= lookupId binder `thenSM` \ blookup ->
specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
let
is_specid = maybeToBool specid_maybe_maybe
Just specinfo_maybe = specid_maybe_maybe
specid_with_info = maybeToBool specinfo_maybe
- Just spec_info = specinfo_maybe
+ Just spec_info = specinfo_maybe
+
+ -- If we have a SpecInfo stored in a SpecPragmaId binder
+ -- it will contain a SpecInfo with an explicit SpecId
+ -- We add the explicit ci to the usage details
+ -- Any ordinary cis for orig_id (there should only be one)
+ -- will be ignored later
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
ASSERT(toplevelishId orig_id) -- must not be cloned!
explicitCI orig_id spec_tys spec_info
else
- emptyUDs
+ emptyUDs
+
+ -- For a local binding we dump the usage details, creating
+ -- any local dict bindings required
+ -- At the top-level the uds will be dumped in specBindAndScope
+ -- and the dict bindings made *global*
- (binds_here, final_uds) = dumpUDs rhs_uds new_binders []
+ (local_dict_binds, final_uds)
+ = if not top_lev then
+ dumpUDs rhs_uds False floating inst_cis new_binders []
+ else
+ ([], rhs_uds)
in
case blookup of
- Lifted lift_binder unlift_binder
- -> -- We may need to record an unboxed instance 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]
+ mkTyConInstance liftDataCon [idType unlift_binder]
`thenSM` \ lift_uds ->
returnSM ((lift_binder,
- mkCoLetsNoUnboxed binds_here (liftExpr unlift_binder rhs)),
+ mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
- NoLift (CoVarAtom binder)
- -> returnSM ((binder, mkCoLetsNoUnboxed binds_here rhs),
+ NoLift (VarArg binder)
+ -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
final_uds `unionUDs` pragma_uds)
\end{code}
%************************************************************************
\begin{code}
-instBind main_ids@(first_binder:other_binders) bind call_insts_for_main_ids
+instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
+ | null equiv_ciss
+ = returnSM ([], emptyUDs, [])
+
| 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) ->
+ = -- For each call_inst, build an instance
+ mapAndUnzip3SM do_this_class equiv_ciss
+ `thenSM` \ (inst_binds, inst_uds_s, spec_infos) ->
-- Add in the remaining UDs
- returnSM (catMaybes inst_binds,
+ 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)))
+ = (if not (null (filter isUnboxedCI (concat equiv_ciss)))
+ then pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n"
+ else if top_lev
+ then pprTrace "dumpCIs: not same overloading ... top level \n"
+ else (\ x y -> y)
+ ) (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug new_ids,
+ ppStr "}"])
+ 4 (ppAboves [ppAboves (map (pprGenType PprDebug . idType) new_ids),
+ ppAboves (map pprCI (concat equiv_ciss))]))
(returnSM ([], emptyUDs, []))
where
(tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
- tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls
+ tyvar_tmpl_tys = mkTyVarTys 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
+ = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
where
- explicit_cis = filter isExplicitCI equiv_cis
- [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis
-
+ (explicit_cis, normal_cis) = partition isExplicitCI equiv_cis
+ do_cis = head (normal_cis ++ explicit_cis)
+ -- must choose a normal_cis in preference since dict_args will
+ -- not be defined for an explicit_cis
-- same_overloading tests whether the types of all the binders
-- are "compatible"; ie have the same type and dictionary abstractions
-- 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
+ 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)
+ && length class_tyvar_pairs == length 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)
+ same_ov (clas1,tyvar1) (clas2,tyvar2)
= clas1 == clas2 &&
tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
\end{code}
The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
- SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
+ SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
Based on this SpecInfo, a call instance of f
\begin{code}
mkOneInst :: CallInstance
+ -> [CallInstance] -- Any explicit cis for this inst
-> Int -- No of dicts to specialise
+ -> Bool -- Top level binders?
+ -> [CallInstance] -- Instantiated call insts for binders
-> [Id] -- New binders
- -> PlainCoreBinding -- Unprocessed
- -> SpecM (Maybe PlainCoreBinding, -- Instantiated version of input
+ -> CoreBinding -- Unprocessed
+ -> SpecM (Maybe CoreBinding, -- Instantiated version of input
UsageDetails,
- [SpecInfo] -- One for each id in the original binding
+ [Maybe 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
+mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis
+ no_of_dicts_to_specialise top_lev inst_cis new_ids orig_bind
+ = newSpecIds new_ids spec_tys no_of_dicts_to_specialise
`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 :: [Type]
(_,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)
+ args :: [CoreArg]
+ args = map TyArg arg_tys ++ dict_args
+
+ (new_id:_) = new_ids
+ (spec_id:_) = spec_ids
+
+ do_bind (NonRec orig_id rhs)
+ = do_one_rhs (spec_id, new_id, (orig_id,rhs))
+ `thenSM` \ (maybe_spec, rhs_uds, spec_info) ->
+ case maybe_spec of
+ Just (spec_id, rhs) -> returnSM (Just (NonRec spec_id rhs), rhs_uds, [spec_info])
+ Nothing -> returnSM (Nothing, rhs_uds, [spec_info])
+
+ do_bind (Rec pairs)
+ = mapAndUnzip3SM do_one_rhs (zip3 spec_ids new_ids pairs)
+ `thenSM` \ (maybe_pairs, rhss_uds_s, spec_infos) ->
+ returnSM (Just (Rec (catMaybes maybe_pairs)),
+ unionUDList rhss_uds_s, spec_infos)
+
+ do_one_rhs (spec_id, new_id, (orig_id, orig_rhs))
+
+ -- Avoid duplicating a spec which has already been created ...
+ -- This can arise in a Rec involving a dfun for which a
+ -- a specialised instance has been created but specialisation
+ -- "required" by one of the other Ids in the Rec
+ | top_lev && maybeToBool lookup_orig_spec
+ = (if opt_SpecialiseTrace
+ then trace_nospec " Exists: " orig_id
+ else id) (
+
+ returnSM (Nothing, emptyUDs, Nothing)
+ )
+
+ -- Check for a (single) explicit call instance for this id
+ | not (null explicit_cis_for_this_id)
+ = ASSERT (length explicit_cis_for_this_id == 1)
+ (if opt_SpecialiseTrace
+ then trace_nospec " Explicit: " explicit_id
+ else id) (
+
+ returnSM (Nothing, tickSpecInsts emptyUDs, Just explicit_spec_info)
+ )
+
+ -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2)
+ | otherwise
+ = ASSERT (no_of_dicts_to_specialise == length dict_args)
+ specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) ->
+ let
+ -- For a local binding we dump the usage details, creating
+ -- any local dict bindings required
+ -- At the top-level the uds will be dumped in specBindAndScope
+ -- and the dict bindings made *global*
+
+ (local_dict_binds, final_uds)
+ = if not top_lev then
+ dumpUDs inst_uds False False inst_cis new_ids []
+ else
+ ([], inst_uds)
+
+ spec_info = Just (SpecInfo spec_tys no_of_dicts_to_specialise spec_id)
+ in
+ if isUnboxedType (idType spec_id) then
+ ASSERT (null poly_tyvars)
+ liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
+ mkTyConInstance liftDataCon [idType unlift_spec_id]
+ `thenSM` \ lift_uds ->
+ returnSM (Just (lift_spec_id,
+ mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_spec_id inst_rhs)),
+ tickSpecInsts (final_uds `unionUDs` lift_uds), spec_info)
+ else
+ returnSM (Just (spec_id,
+ mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
+ tickSpecInsts final_uds, spec_info)
+ where
+ lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
+
+ explicit_cis_for_this_id = filter (isCIofTheseIds [new_id]) explicit_cis
+ [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis_for_this_id
+ SpecInfo _ _ explicit_id = explicit_spec_info
+
+ trace_nospec :: String -> Id -> a -> a
+ trace_nospec str spec_id
+ = pprTrace str
+ (ppCat [ppr PprDebug new_id, ppInterleave ppNil (map pp_ty arg_tys),
+ ppStr "==>", ppr PprDebug spec_id])
in
- getSwitchCheckerSM `thenSM` \ sw_chkr ->
- (if sw_chkr SpecialiseTrace then
+ (if opt_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]]))
+ (ppHang (ppBesides [ppStr "{",
+ interppSP PprDebug new_ids,
+ ppStr "}"])
+ 4 (ppAboves [
+ ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
+ if isExplicitCI do_cis then ppNil else
+ ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
+ ppBesides [ppStr "specs: ", 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]
- )
+ do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
+
+ returnSM (maybe_inst_bind, inst_uds, spec_infos)
)
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]
+ pp_dict d = ppr_arg PprDebug d
+ pp_ty t = pprParendGenType PprDebug t
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
\end{code}
%************************************************************************
%* *
%************************************************************************
-@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)
- 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}
-
-\begin{code}
-mkCallInstance :: Id
+mkCallInstance :: Id
-> Id
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
+ -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
-> 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)])
+mkCallInstance id new_id []
+ = returnSM emptyUDs
- (returnSM call_fv_uds)
+mkCallInstance id new_id args
- 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 ")"]])
+ -- No specialised versions for "error" and friends are req'd.
+ -- This is a special case in core lint etc.
- (returnSM call_fv_uds)
+ | isBottomingId id
+ = returnSM emptyUDs
- 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 ")"]])
+ -- No call instances for SuperDictSelIds
+ -- These are a special case in mkCall
- (returnSM (singleCI new_id spec_tys dict_args `unionUDs` call_fv_uds))
- 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
+ = returnSM emptyUDs
- | isClassOpId id
- = returnSM Nothing
-
- -- Finally, the default case ...
+ -- There are also no call instances for ClassOpIds
+ -- However, we need to process it to get any second-level call
+ -- instances for a ConstMethodId extracted from its SpecEnv
| otherwise
- = getSwitchCheckerSM `thenSM` \ sw_chkr ->
- let
- spec_overloading = sw_chkr SpecialiseOverloaded
- spec_unboxed = sw_chkr SpecialiseUnboxed
- spec_all = sw_chkr SpecialiseAll
+ = let
+ spec_overloading = opt_SpecialiseOverloaded
+ spec_unboxed = opt_SpecialiseUnboxed
+ spec_all = opt_SpecialiseAll
- (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading id
- constraint_vec = mkConstraintVector tyvar_tmpls class_tyvar_pairs
+ (tyvars, class_tyvar_pairs) = getIdOverloading id
- arg_res = take_type_args tyvar_tmpls class_tyvar_pairs args
+ arg_res = take_type_args tyvars class_tyvar_pairs args
enough_args = maybeToBool arg_res
- (Just (inst_tys, dict_args, rest_args)) = arg_res
- spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
- constraint_vec inst_tys
+ (Just (tys, dicts, rest_args)) = arg_res
+
+ record_spec id tys
+ = (record, lookup, spec_tys)
+ where
+ spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
+ (mkConstraintVector id) tys
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation id)
- inst_tys)
+ record = any (not . isTyVarTy) (catMaybes spec_tys)
- -- 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)
+ lookup = lookupSpecEnv (getIdSpecialisation id) 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))
+ (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) [arg | (arg,_,_) <- 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)
+ case record_spec id tys of
+ (False, _, _)
+ -> -- pprTrace "CallInst:NotReqd\n"
+ -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
+ (returnSM emptyUDs)
+
+ (True, Nothing, spec_tys)
+ -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
+ returnSM emptyUDs
+ else
+ -- pprTrace "CallInst:Reqd\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
+ -- ppCat (map (ppr PprDebug) dicts)]])
+ (returnSM (singleCI new_id spec_tys dicts))
+
+ (True, Just (spec_id, tys_left, toss), _)
+ -> if maybeToBool (isConstMethodId_maybe spec_id) then
+ -- If we got a const method spec_id see if further spec required
+ -- NB: const method is top-level so spec_id will not be cloned
+ case record_spec spec_id tys_left of
+ (False, _, _)
+ -> -- pprTrace "CallInst:Exists\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- ppCat [ppStr "->", ppr PprDebug spec_id,
+ -- ppr PprDebug (tys_left ++ drop toss dicts)]])
+ (returnSM emptyUDs)
+
+ (True, Nothing, spec_tys)
+ -> -- pprTrace "CallInst:Exists:Reqd\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- ppCat [ppStr "->", ppr PprDebug spec_id,
+ -- ppr PprDebug (tys_left ++ drop toss dicts)],
+ -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
+ -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
+ (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
+
+ (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
+ -> -- pprTrace "CallInst:Exists:Exists\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- ppCat [ppStr "->", ppr PprDebug spec_id,
+ -- ppr PprDebug (tys_left ++ drop toss dicts)],
+ -- ppCat [ppStr "->", ppr PprDebug spec_spec_id,
+ -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
+ (returnSM emptyUDs)
+
+ else
+ -- pprTrace "CallInst:Exists\n"
+ -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
+ -- ppCat [ppStr "->", ppr PprDebug spec_id,
+ -- ppr PprDebug (tys_left ++ drop toss dicts)]])
+ (returnSM emptyUDs)
+
+
+take_type_args (_:tyvars) class_tyvar_pairs ((TyArg 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,_,_):args) | isValArg dict
+ = 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}
\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
+ -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
+ -> SpecM CoreExpr
+
+mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
+
+{-
+ | maybeToBool (isSuperDictSelId_maybe new_id)
+ && any isUnboxedType 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.
+ -- have been specialised. We only do this to keep core-lint happy.
= let
- Just (_, super_class) = isSuperDictSelId_maybe main_id
- super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
+ Just (_, super_class) = isSuperDictSelId_maybe new_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)
+ returnSM (False, Var super_dict_id)
| otherwise
- = case lookupSpecEnv (getIdSpecialisation main_id) ty_args of
- Nothing -> checkUnspecOK main_id ty_args (
- returnSM unspec_call
+ = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
+ Nothing -> checkUnspecOK new_id ty_args (
+ returnSM (False, unspec_call)
)
- Just (spec_id, tys_left, dicts_to_toss)
- -> checkSpecOK main_id ty_args spec_id tys_left (
- let
+ Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
+ -> let
+ -- It may be necessary to specialsie a constant method spec_id again
+ (spec_id, tys_left, dicts_to_toss) =
+ case (maybeToBool (isConstMethodId_maybe spec_id_1),
+ lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
+ (False, _ ) -> spec_1_details
+ (True, Nothing) -> spec_1_details
+ (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
+ -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
+
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
+ checkSpecOK new_id ty_args spec_id tys_left (
+
+ -- The resulting spec_id may be a top-level unboxed value
+ -- This can arise for:
+ -- 1) constant method values
+ -- eq: class Num a where pi :: a
+ -- instance Num Double# where pi = 3.141#
+ -- 2) specilised overloaded values
+ -- eq: i1 :: Num a => a
+ -- i1 Int# d.Num.Int# ==> i1.Int#
+ -- These top level defns should have been lifted.
+ -- We must add code to unlift such a spec_id.
+
+ if isUnboxedType (idType 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))
+ if toplevelishId spec_id then
+ liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
+ returnSM (True, bindUnlift lift_spec_id unlift_spec_id
+ (Var unlift_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),
+ pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
+ (ppCat [ppr PprDebug new_id,
+ ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
ppStr "==>",
ppr PprDebug spec_id])
- else
+ else
let
(vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkCoTyApps (CoVar spec_id) tys_left
- applied_vals = applyToArgs applied_tys vals_left
+ applied_tys = mkTyApp (Var spec_id) tys_left
+ applied_vals = mkGenApp applied_tys vals_left
in
- returnSM (applyBindUnlifts unlifts_left applied_vals)
+ returnSM (True, applyBindUnlifts unlifts_left applied_vals)
)
where
(tys_and_vals, _, unlifts) = unzip3 args
- unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar main_id) tys_and_vals)
+ unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
-- ty_args is the types at the front 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)
+ get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
+ get args = ([], args)
+
-- 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
+ toss_dicts 0 args = args
+ toss_dicts n ((a,_,_) : args)
+ | isValArg a = toss_dicts (n-1) args
+
\end{code}
\begin{code}
-checkUnspecOK :: Id -> [UniType] -> a -> a
+checkUnspecOK :: Id -> [Type] -> a -> a
checkUnspecOK check_id tys
- = if isLocallyDefined check_id && any isUnboxedDataType tys
+ = if isLocallyDefined check_id && any isUnboxedType tys
then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
(ppCat [ppr PprDebug check_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys)])
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys)])
else id
-checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a
+checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
checkSpecOK check_id tys spec_id tys_left
- = if any isUnboxedDataType tys_left
+ = if any isUnboxedType 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)],
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys)],
ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]])
+ ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
else id
+-}
\end{code}
\begin{code}
mkTyConInstance :: Id
- -> [UniType]
+ -> [Type]
-> 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)])
+ -> -- 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 ")"]])
+ -- (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))
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
\end{code}
\begin{code}
recordTyConInst :: Id
- -> [UniType]
- -> SpecM (Maybe [Maybe UniType])
+ -> [Type]
+ -> SpecM (Maybe [Maybe Type])
recordTyConInst con tys
= let
- spec_tys = specialiseConstrTys tys
+ spec_tys = specialiseConstrTys tys
do_tycon_spec = maybeToBool (firstJust spec_tys)
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation con)
+ 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)])
+ -- (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)
\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}
inherited: control flags and
recordInst functions with flags cached
- environment mapping tyvars to types
+ environment mapping tyvars to types
environment mapping Ids to Atoms
-
+
threaded in and out: unique supply
\begin{code}
+type TypeEnv = TyVarEnv Type
+
type SpecM result
- = (GlobalSwitch -> Bool)
- -> TypeEnv
+ = TypeEnv
-> SpecIdEnv
- -> SplitUniqSupply
+ -> UniqSupply
-> result
-initSM m sw_chker uniqs
- = m sw_chker nullTyVarEnv nullIdEnv uniqs
+initSM m uniqs
+ = m 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
+thenSM m k 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 }}
+ case (m tvenv idenv s1) of { r ->
+ k r tvenv idenv s2 }}
-returnSM r sw_chkr tvenv idenv us = r
+returnSM r tvenv idenv us = r
-fixSM k sw_chkr tvenv idenv us
+fixSM k 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
+ r = k r tvenv idenv us -- Recursive in r!
\end{code}
The only interesting bit is figuring out the type of the SpecId!
\begin{code}
newSpecIds :: [Id] -- The id of which to make a specialised version
- -> [Maybe UniType] -- Specialise to these types
+ -> [Maybe Type] -- 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
+newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
+ = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
+ | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
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
- ]
+ uniqs = getUniques (length new_ids) us
+ spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
newTyVars :: Int -> SpecM [TyVar]
-newTyVars n sw_chkr tvenv idenv us
- = map mkPolySysTyVar uniqs
- where
- uniqs = getSUniques n us
+newTyVars n tvenv idenv us
+ = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
\end{code}
-@cloneLambdaOrCaseBinders@ and @cloneLetrecBinders@ take a bunch of
+@cloneLambdaOrCaseBinders@ and @cloneLetBinders@ 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
+ (c) for Let binders which have been specialised to unboxed values
the clone will have a lifted type
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
+cloneLambdaOrCaseBinders old_ids tvenv idenv us
= let
- uniqs = getSUniques (length old_ids) us
+ uniqs = getUniques (length old_ids) us
in
- unzip (zipWith clone_it old_ids uniqs)
+ unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
where
clone_it old_id uniq
- = (new_id, NoLift (CoVarAtom new_id))
+ = (new_id, NoLift (VarArg new_id))
where
new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
-cloneLetrecBinders :: [Id] -- Old binders
- -> SpecM ([Id], [CloneInfo]) -- New ones
+cloneLetBinders :: Bool -- Top level ?
+ -> Bool -- Recursice
+ -> [Id] -- Old binders
+ -> SpecM ([Id], [CloneInfo]) -- New ones
-cloneLetrecBinders old_ids sw_chkr tvenv idenv us
+cloneLetBinders top_lev is_rec old_ids tvenv idenv us
= let
- uniqs = getSUniques (2 * length old_ids) us
+ uniqs = getUniques (2 * length old_ids) us
in
unzip (clone_them old_ids uniqs)
where
clone_them [] [] = []
clone_them (old_id:olds) (u1:u2:uniqs)
- | toplevelishId old_id
+ | top_lev
= (old_id,
- NoLift (CoVarAtom old_id)) : clone_rest
+ NoLift (VarArg old_id)) : clone_rest
-- Don't clone if it is a top-level thing. Why not?
- -- (a) we don't want to change the uniques
+ -- (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
| otherwise
- = if (isUnboxedDataType new_ty && not (isUnboxedDataType old_ty))
+ = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
then (lifted_id,
Lifted lifted_id unlifted_id) : clone_rest
else (new_id,
- NoLift (CoVarAtom new_id)) : clone_rest
+ NoLift (VarArg new_id)) : clone_rest
- where
+ where
clone_rest = clone_them olds uniqs
new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
- new_ty = getIdUniType new_id
- old_ty = getIdUniType old_id
+ new_ty = idType new_id
+ old_ty = idType old_id
(lifted_id, unlifted_id) = mkLiftedId new_id u2
cloneTyVarSM :: TyVar -> SpecM TyVar
-cloneTyVarSM old_tyvar sw_chkr tvenv idenv us
+cloneTyVarSM old_tyvar tvenv idenv us
= let
- uniq = getSUnique us
+ uniq = getUnique 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
+bindId id val specm tvenv idenv us
+ = specm 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
+bindIds olds news specm tvenv idenv us
+ = specm 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
+bindSpecIds :: [Id] -- Old
+ -> [(CloneInfo)] -- New
+ -> [[Maybe SpecInfo]] -- Corresponding specialisations
+ -- Each sub-list corresponds to a different type,
+ -- and contains one Maybe 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
+bindSpecIds olds clones spec_infos specm tvenv idenv us
+ = specm 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) :
+ = (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 (NoLift (VarArg new))
+ = NoLift (VarArg (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_this_id = catMaybes (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 -> Type -> SpecM thing -> SpecM thing
-bindTyVar tyvar ty specm sw_chkr tvenv idenv us
- = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
+bindTyVar tyvar ty specm tvenv idenv us
+ = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
\end{code}
\begin{code}
lookupId :: Id -> SpecM CloneInfo
-lookupId id sw_chkr tvenv idenv us
+lookupId id tvenv idenv us
= case lookupIdEnv idenv id of
- Nothing -> NoLift (CoVarAtom id)
+ Nothing -> NoLift (VarArg id)
Just info -> info
\end{code}
\begin{code}
-specTy :: UniType -> SpecM UniType -- Apply the current type envt to the type
+specTy :: Type -> SpecM Type -- Apply the current type envt to the type
-specTy ty sw_chkr tvenv idenv us
+specTy ty tvenv idenv us
= applyTypeEnvToTy tvenv ty
\end{code}
\begin{code}
liftId :: Id -> SpecM (Id, Id)
-liftId id sw_chkr tvenv idenv us
+liftId id tvenv idenv us
= let
- uniq = getSUnique us
+ uniq = getUnique us
in
mkLiftedId id uniq
\end{code}
projects / ghc-hetmet.git / blobdiff