\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
\begin{code}
-#include "HsVersions.h"
-
module Specialise (
specProgram,
initSpecData,
- SpecialiseData(..),
- FiniteMap, Bag
-
+ SpecialiseData(..)
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
- partitionBag, listToBag, bagToList
+ partitionBag, listToBag, bagToList, Bag
)
-import Class ( GenClass{-instance Eq-} )
+import Class ( Class )
import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
- opt_CompilingPrelude, opt_SpecialiseTrace,
- opt_SpecialiseOverloaded, opt_SpecialiseUnboxed,
- opt_SpecialiseAll
+ opt_SpecialiseTrace
)
import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
import CoreSyn
import CoreUtils ( coreExprType, squashableDictishCcExpr )
-import FiniteMap ( addListToFM_C )
+import FiniteMap ( addListToFM_C, FiniteMap )
+import Kind ( mkBoxedTypeKind, isBoxedTypeKind )
import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
- isSuperDictSelId_maybe, isBottomingId,
- isConstMethodId_maybe, isDataCon,
+ isBottomingId,
+ isDataCon,
isImportedId, mkIdWithNewUniq,
dataConTyCon, applyTypeEnvToId,
nullIdEnv, addOneToIdEnv, growIdEnvList,
- lookupIdEnv, IdEnv(..),
+ lookupIdEnv, IdEnv,
emptyIdSet, mkIdSet, unitIdSet,
elementOfIdSet, minusIdSet,
- unionIdSets, unionManyIdSets, IdSet(..),
- GenId{-instance Eq-}
+ unionIdSets, unionManyIdSets, IdSet,
+ GenId{-instance Eq-}, Id
)
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 PrelInfo ( liftDataCon )
-import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
- ppInt, ppSP, ppInterleave, ppNil, Pretty(..)
- )
import PrimOp ( PrimOp(..) )
import SpecUtils
-import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyCon,
- tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
+import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp,
+ tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy,
+ Type
)
import TyCon ( TyCon{-instance Eq-} )
-import TyVar ( cloneTyVar,
- elementOfTyVarSet, TyVarSet(..),
- nullTyVarEnv, growTyVarEnvList, TyVarEnv(..),
+import TyVar ( cloneTyVar, mkSysTyVar,
+ elementOfTyVarSet, TyVarSet,
+ emptyTyVarEnv, growTyVarEnvList, 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, zipWithEqual,
- panic, pprTrace, pprPanic, assertPanic
+import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual,
+ thenCmp
)
+import List ( partition )
+import Outputable
infixr 9 `thenSM`
+specProgram = panic "SpecProgram"
+
--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)"
-lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)"
-mkPolySysTyVar = panic "Specialise.mkPolySysTyVar (ToDo)"
mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)"
mkSpecId = panic "Specialise.mkSpecId (ToDo)"
selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)"
Now give it to the simplifier and the _Lifting will be optimised away.
The benfit is that we have given the specialised "unboxed" values a
-very simple lifted semantics and then leave it up to the simplifier to
+very simplep lifted semantics and then leave it up to the simplifier to
optimise it --- knowing that the overheads will be removed in nearly
all cases.
strictness analyser deems the lifted binding strict.
+A note about non-tyvar dictionaries
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Ids have types like
+
+ forall a,b,c. Eq a -> Ord [a] -> tau
+
+This seems curious at first, because we usually only have dictionary
+args whose types are of the form (C a) where a is a type variable.
+But this doesn't hold for the functions arising from instance decls,
+which sometimes get arguements with types of form (C (T a)) for some
+type constructor T.
+
+Should we specialise wrt this compound-type dictionary? We used to say
+"no", saying:
+ "This is a heuristic judgement, as indeed is the fact that we
+ specialise wrt only dictionaries. We choose *not* to specialise
+ wrt compound dictionaries because at the moment the only place
+ they show up is in instance decls, where they are simply plugged
+ into a returned dictionary. So nothing is gained by specialising
+ wrt them."
+
+But it is simpler and more uniform to specialise wrt these dicts too;
+and in future GHC is likely to support full fledged type signatures
+like
+ f ;: Eq [(a,b)] => ...
+
+
+%************************************************************************
+%* *
+\subsubsection{The new specialiser}
+%* *
+%************************************************************************
+
+Our basic game plan is this. For let(rec) bound function
+ f :: (C a, D c) => (a,b,c,d) -> Bool
+
+* Find any specialised calls of f, (f ts ds), where
+ ts are the type arguments t1 .. t4, and
+ ds are the dictionary arguments d1 .. d2.
+
+* Add a new definition for f1 (say):
+
+ f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
+
+ Note that we abstract over the unconstrained type arguments.
+
+* Add the mapping
+
+ [t1,b,t3,d] |-> \d1 d2 -> f1 b d
+
+ to the specialisations of f. This will be used by the
+ simplifier to replace calls
+ (f t1 t2 t3 t4) da db
+ by
+ (\d1 d1 -> f1 t2 t4) da db
+
+ All the stuff about how many dictionaries to discard, and what types
+ to apply the specialised function to, are handled by the fact that the
+ SpecEnv contains a template for the result of the specialisation.
+
+We don't build *partial* specialisations for f. For example:
+
+ f :: Eq a => a -> a -> Bool
+ {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
+
+Here, little is gained by making a specialised copy of f.
+There's a distinct danger that the specialised version would
+first build a dictionary for (Eq b, Eq c), and then select the (==)
+method from it! Even if it didn't, not a great deal is saved.
+
+We do, however, generate polymorphic, but not overloaded, specialisations:
+
+ f :: Eq a => [a] -> b -> b -> b
+ {#- SPECIALISE f :: [Int] -> b -> b -> b #-}
+
+The invariant is this:
+
+ *** no specialised version is overloaded ***
+
+
+\begin{code}
+specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
+
+---------------- First the easy cases --------------------
+specExpr e@(Var _) = returnSM (e, emptyUDs)
+specExpr e@(Lit _) = returnSM (e, emptyUDs)
+specExpr e@(Con _ _) = returnSM (e, emptyUDs)
+specExpr e@(Prim _ _) = returnSM (e, emptyUDs)
+
+specExpr (Coerce co ty body)
+ = specExpr body `thenSM` \ (body', uds) ->
+ returnSM (Coerce co ty body')
+
+specExpr (SCC cc body)
+ = specExpr body `thenSM` \ (body', uds) ->
+ returnSM (SCC cc body')
+
+
+---------------- Applications might generate a call instance --------------------
+specExpr e@(App fun arg)
+ = go fun [arg]
+ where
+ go (App fun arg) args = go fun (arg:args)
+ go (Var f) args = returnSM (e, mkCallUDs f args)
+ go other args = specExpr other `thenSM` \ (e', uds) ->
+ returnSM (foldl App e' args, uds)
+
+---------------- Lambda/case require dumping of usage details --------------------
+specExpr e@(Lam _ _)
+ = specExpr body `thenSM` \ (body', uds) ->
+ let
+ (filtered_uds, body'') = dumpUDs bndrs uds body'
+ in
+ returnSM (Lam bndr body'', filtered_uds)
+ where
+ (bndrs, body) = go [] e
+
+ -- More efficient to collect a group of binders together all at once
+ go bndrs (Lam bndr e) = go (bndr:bndrs) e
+ go bndrs e = (reverse bndrs, e)
+
+
+specExpr (Case scrut alts)
+ = specExpr scrut `thenSM` \ (scrut', uds_scrut) ->
+ spec_alts alts `thenSM` \ (alts', uds_alts) ->
+ returnSM (Case scrut' alts', uds_scrut `plusUDs` uds_alts)
+ where
+ spec_alts (AlgAlts alts deflt)
+ = mapAndCombineSM spec_alg_alt alts `thenSM` \ (alts', uds1) ->
+ spec_deflt deflt `thenSM` \ (deflt', uds2) ->
+ returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2)
+
+ spec_alts (PrimAlts alts deflt)
+ = mapAndCombineSM spec_prim_alt alts `thenSM` \ (alts', uds1) ->
+ spec_deflt deflt `thenSM` \ (deflt', uds2) ->
+ returnSM (AlgAlts alts' deflt', uds1 `plusUDs` uds2)
+
+ spec_alg_alt (con, args, rhs)
+ = specExpr rhs `thenSM` \ (rhs', uds) ->
+ let
+ (uds', rhs'') = dumpUDs (map ValBinder args) uds rhs'
+ in
+ returnSM ((con, args, rhs''), uds')
+
+ spec_prim_alt (lit, rhs)
+ = specExpr rhs `thenSM` \ (rhs', uds) ->
+ returnSM ((lit, rhs'), uds)
+
+ spec_deflt NoDefault = (NoDefault, emptyUDs)
+ spec_deflt (BindDefault arg rhs)
+ = specExpr rhs `thenSM` \ (rhs', uds) ->
+ let
+ (uds', rhs'') = dumpManyUDs [ValBinder arg] uds rhs'
+ in
+ returnSM (BindDefault arg rhs'', uds')
+
+---------------- Finally, let is the interesting case --------------------
+specExpr (Let (NonRec bndr rhs) body)
+ = specExpr body `thenSM` \ (body', body_uds) ->
+ specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+
+ let
+ all_uds = rhs_uds `plusUDs` body_uds
+ in
+ if bndr `elementOfIdSet` free_dicts body_uds then
+ -- This is a dictionary binding; we must pick it up
+ -- and float it outwards.
+ ASSERT( null spec_defns )
+ returnSM (body', addDictBind all_uds bndr' rhs')
+
+ else if isSpecPragmaId bnd then
+ -- SpecPragmaIds are there solely to generate specialisations
+ -- Just drop the whole binding
+ ASSERT( null spec_defns )
+ returnSM (body', all_uds)
+
+ else
+ -- An ordinary binding, so glue it all together
+ returnSM (
+ Let (NonRec bndr' rhs') (mkLets spec_defns body'),
+ deleteCalls all_uds bndr'
+ )
+
+specDefn :: CallDetails -- Info on how it is used in its scope
+ -> (Id, CoreExpr) -- The thing being bound and its un-processed RHS
+ -> SpecM ((Id, CoreExpr), -- The thing and its processed RHS
+ -- the Id may now have specialisations attached
+ [(Id, CoreExpr)], -- Extra, specialised bindings
+ UsageDetails -- Stuff to fling upwards from the RHS and its
+ ) -- specialised versions
+
+specDefn calls (fn, rhs)
+ -- The first case is the interesting one
+ | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
+ && n_dicts <= length rhs_bndrs -- and enough dict args
+ && not (null calls_for_me) -- And there are some calls to specialise
+ = specExpr body `thenSM` \ (body', body_uds) ->
+ mapSM (specCall body_uds) calls_for_me `thenSM` \ stuff ->
+ let
+ (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
+
+ (rhs_uds, body'') = dumpUDs rhs_bndrs body_uds body'
+ rhs' = foldr Lam bndrs body''
+
+ fn' = addIdSpecialisations fn spec_env_stuff
+ in
+ returnSM ((fn',rhs'), spec_defns, rhs_uds `plusUDs` plusUDList spec_uds)
+
+ | otherwise -- No calls or RHS doesn't fit our preconceptions
+ = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
+ returnSM ((fn, rhs'), [], rhs_uds)
+
+ where
+ (tyvars, theta, tau) = splitSigmaTy (idType fn)
+ n_tyvars = length tyvars
+ n_dicts = length theta
+
+ (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
+ rhs_dicts = take n_dicts rhs_ids
+ rhs_bndrs = map TyBinder rhs_tyvars ++ map ValBinder rhs_dicts
+ body = mkValLam (drop n_dicts rhs_ids) rhs_body
+ -- Glue back on the non-dict lambdas
+
+ calls_for_me = case lookupFM calls fn of
+ Nothing -> []
+ Just cs -> fmToList cs
+
+
+ -- Specialise to one particular call pattern
+ spec_call body_uds (call_ts, call_ds)
+ = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
+ -- The calls are only recorded for properly-saturated applications
+
+ -- Construct the new binding
+ -- f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
+ -- and the type of this binder
+ let
+ spec_tys = zipNothings call_ts tyvars
+ spec_rhs = mkTyLam tyvars (mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds))
+ spec_ty = mkForAllTys tyvars (applyTys (idType f) spec_tys)
+ in
+ newIdSM f spec_ty `thenSM` \ spec_f ->
+
+
+ -- Construct the stuff for f's spec env
+ -- [t1,b,t3,d] |-> \d1 d2 -> f1 b d
+ let
+ spec_env_rhs = mkValLam call_ds $
+ mkTyApp (Var spec_f) $
+ map mkTyVarTy tyvars
+ in
+
+ -- Specialise the UDs from f's RHS
+ specUDs (zipEqual defn_tvs call_ts)
+ (zipEqual rhs_dicts call_ds)
+ body_uds `thenSM` \ spec_uds ->
+
+ returnSM ((spec_f, spec_rhs),
+ spec_uds,
+ (spec_tys, spec_env_rhs)
+ )
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{UsageDetails and suchlike}
+%* *
+%************************************************************************
+
+\begin{code}
+type FreeDicts = IdSet
+
+data UsageDetails
+ = MkUD {
+ free_dicts :: !FreeDicts, -- Dicts free in any of the calls or dict binds
+
+ dict_binds :: !Bag (DictVar, CoreExpr, FreeDicts),
+ -- Floated dictionary bindings
+ -- The order is important;
+ -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
+ -- (Remember, Bags preserve order in GHC.)
+ -- The FreeDicts is the free vars of the RHS
+
+ calls :: !CallDetails
+ }
+
+type CallMap = FiniteMap Id CallInfo
+type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
+ [DictVar] -- Dict args
+ -- The finite maps eliminate duplicates
+ -- The list of types and dictionaries is guaranteed to
+ -- match the type of f
+
+
+plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
+plusUDs (MkUD {fvs = fvs1, dictBinds = db1, calls = calls1})
+ (MkUD {fvs = fvs2, dictBinds = db2, calls = calls2})
+ = MkUD {fvs, dictBinds, calls}
+ where
+ fvs = fvs1 `unionIdSets` fvs2
+ dictBinds = db1 `unionBags` db2
+ calls = calls1 `unionBags` calls2
+
+
+tyVarsOfUDs (MkUD {fvs}) = tyVarsOfTypes (map idType (idSetToList fvs))
+
+deleteCalls uds bndr = uds { calls = delFromFM (calls uds) bndr }
+
+addDictBind uds dict rhs = uds { free_dicts = addToIdSet (free_dicts uds) dict,
+ dict_binds = (dict, rhs, f
+
+dumpUDs :: [CoreBinder]
+ -> UsageDetails -> CoreExpr
+ -> (UsageDetails, CoreExpr)
+
+dumpUDs bndrs uds@(MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls}) body
+ = ASSERT( isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs)
+ -- The tyvars shouldn't be free in any of the usage details
+ -- If it was, then we should have found a dictionary lambda first
+
+ if isEmptyIdSet (id_set `intersectIdSets` fvs) then
+ -- Common case: binder doesn't affect floats
+ (uds, body)
+
+ else
+ -- Binders bind some of the fvs of the floats
+ (MkUDs {fvs = filtered_fvs,
+ dictBinds = filtered_dbs,
+ calls = filtered_calls},
+ foldrBag mk_dict_bind body dump_dbs)
+
+ where
+ tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs]
+ id_list = [id | ValBinder id <- bndrs]
+ id_set = mkIdSet id_list
+ ftvs = tyVarsOfUDs uds
+ filtered_fvs = orig_fvs `minusIdSet` id_set
+
+ (filtered_dbs, dump_dbs, dump_idset)
+ = foldlBag dump (emptyBag, emptyBag, id_set) orig_dbs
+ -- Important that it's foldl not foldr;
+ -- we're accumulating the set of dumped ids in dump_set
+
+ -- Filter out any calls that mention things that are being dumped
+ -- It's a bit tiresome because of the two-level finite map
+ filtered_calls = mapFM del (foldr delFromFM orig_calls id_list)
+ del _ dicts = filter (not (`elementOfIdSet` dump_id_set)) dicts
+
+ dump (ok_dbs, dump_dbs, dump_idset) db@(dict, rhs, fvs)
+ | isEmptyIdSet (dump_idset `intersectIdSets` fvs)
+ = (ok_dbs `snocBag` db, dump_dbs, dump_idset)
+
+ | otherwise -- Dump it
+ = (ok_dbs, dump_dbs `snocBag` db, idEmptyIdSet (dump_idset `intersectIdSets` fvs)
+
+ mk_dict_bind (dict, rhs, _) body = Let (NonRec dict rhs) body
+\end{code}
+
+Given a type and value substitution, specUDs creates a specialised copy of
+the given UDs
+
+\begin{code}
+specUDs tv_assoc id_assoc (MkUDs {fvs = orig_fvs, dictBinds = orig_dbs, calls = orig_calls})
+ = mapAccumLSM spec_bind
+ (tv_env, id_env)
+ (bagToList orig_dbs) `thenSM` \ ((tv_env', id_env'), new_dbs) ->
+ let
+ subst_call call_info = listToFM [(map (instantiateTy ty_env') ts,
+ map (lookupId id_env') call_ds)
+ | (call_ts, call_ds) <- fmToList call_info
+ ]
+ in
+ MkUDs { fvs = substFVSet id_env orig_fvs,
+ dictBinds = listToBag new_dbs,
+ calls = mapFM orig_calls subst_call
+ }
+ where
+ tv_env = mkTyVarEnv tv_assoc
+ id_env = mkIdEnv id_assoc
+
+ spec_bind (ty_env, id_env) (dict, rhs, fvs)
+ = newIdSM dict spec_ty `thenSM` \ spec_dict ->
+ returnSM ((ty_env, addOneToIdEnv id_env dict spec_dict), (spec_dict, spec_rhs))
+ where
+ spec_ty = instantiateTy ty_env (idType dict)
+ spec_rhs = instantiateDictRhs ty_env id_env rhs
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Boring helper functions}
+%* *
+%************************************************************************
+
+\begin{code}
+substFVSet :: IdEnv Id -> IdSet -> IdSet
+substFVSet env s = mkIdSet [lookupId env id | id <- idSetToList s]
+
+lookupId:: IdEnv Id -> Id -> Id
+lookupId env id = case lookupIdEnv env id of
+ Nothing -> id
+ Just id' -> id'
+
+instantiateDictRhs :: TyVarEnv Type -> IdEnv Id -> CoreExpr -> CoreExpr
+ -- Cheapo function for simple RHSs
+instantiateDictRhs ty_env id_env rhs
+ = go rhs
+ where
+ go (App e1 (ValArg a)) = App (go e1) (ValArg (lookupId id_env a))
+ go (App e1 (TyArg t)) = App (go e1) (TyArg (instantiateTy ty_env t))
+ go (Var v) = Var (lookupId id_env v)
+ go (Lit l) = Lit l
+
+dictRhsFVs :: CoreExpr -> IdSet
+ -- Cheapo function for simple RHSs
+dictRhsFVs (App e1 (ValArg a)) = dictRhsFVs e1 `addOneToIdSet` a
+ go (App e1 (TyArg t)) = dictRhsFVs e1
+ go (Var v) = singletonIdSet v
+ go (Lit l) = emptyIdSet
+
+mkLets [] body = body
+mkLets ((bndr,rhs):binds) body = Let (NonRec bndr rhs) (mkLets binds body)
+
+zipNothings [] [] = []
+zipNothings (Nothing : tys) (tyvar : tyvars) = mkTyVarTy tyvar : zipNothings tys tyvars
+zipNothings (Just ty : tys) tyvars = ty : zipNothings tys tyvars
+\end{code}
+
+
+=========================== OLD STUFF =================================
%************************************************************************
%* *
\end{code}
\begin{code}
-pprCI :: CallInstance -> Pretty
+pprCI :: CallInstance -> Doc
pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
- = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
- 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
+ = hang (hsep [ptext SLIT("Call inst for"), ppr id])
+ 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]),
case maybe_specinfo of
- Nothing -> ppCat (ppStr "dicts" : [ppr_arg PprDebug dict | dict <- dicts])
+ Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts])
Just (SpecInfo _ _ spec_id)
- -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
+ -> hsep [ptext SLIT("Explicit SpecId"), ppr 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
+ppr_arg (TyArg t) = ppr sty t
+ppr_arg (LitArg i) = ppr sty i
+ppr_arg (VarArg v) = ppr sty v
isUnboxedCI :: CallInstance -> Bool
isUnboxedCI (CallInstance _ spec_tys _ _ _)
\begin{code}
-cmpCI :: CallInstance -> CallInstance -> TAG_
+cmpCI :: CallInstance -> CallInstance -> Ordering
cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
- = case (id1 `cmp` id2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+ = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
-cmpCI_tys :: CallInstance -> CallInstance -> TAG_
+cmpCI_tys :: CallInstance -> CallInstance -> Ordering
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 }
+ = case cmpCI_tys c1 c2 of { EQ -> True; other -> False }
isCIofTheseIds :: [Id] -> CallInstance -> Bool
isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
cis_here_list = bagToList cis_here
in
-- pprTrace "getCIs:"
- -- (ppHang (ppBesides [ppStr "{",
- -- interppSP PprDebug ids,
- -- ppStr "}"])
- -- 4 (ppAboves (map pprCI cis_here_list)))
+ -- (hang (hcat [char '{',
+ -- interppSP ids,
+ -- char '}'])
+ -- 4 (vcat (map pprCI cis_here_list)))
(cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
dumpCIs :: Bag CallInstance -- The call instances
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)]))
+ (hang (hcat [char '{',
+ interppSP bound_ids,
+ char '}'])
+ 4 (vcat [ptext SLIT("Dumping CIs:"),
+ vcat (map pprCI (bagToList cis_of_bound_id)),
+ ptext SLIT("Instantiating CIs:"),
+ vcat (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))))
+ (hang (hcat [char '{',
+ interppSP full_ids,
+ char '}'])
+ 4 (vcat (map pprCI (bagToList cis_dump))))
else id)
cis_keep_not_bound_id
)
= TyConInstance TyCon -- Type Constructor
[Maybe Type] -- Applied to these specialising types
-cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
+cmpTyConI :: TyConInstance -> TyConInstance -> Ordering
cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
- = case (cmp tc1 tc2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
+ = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
-cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
+cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering
cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
= cmpUniTypeMaybeList tys1 tys2
Int -- no. of spec insts
\end{code}
-The DictBindDetails are fully processed; their call-instance information is
-incorporated in the call-instances of the
-UsageDetails which includes the DictBindDetails. The free vars in a usage details
+The DictBindDetails are fully processed; their call-instance
+information is incorporated in the call-instances of the UsageDetails
+which includes the DictBindDetails. The free vars in a usage details
will *include* the binders of the DictBind details.
A @DictBindDetails@ contains bindings for dictionaries *only*.
unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
unionUDList :: [UsageDetails] -> UsageDetails
-tickSpecCall :: Bool -> UsageDetails -> UsageDetails
+-- 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
+-- 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)
%************************************************************************
\begin{code}
+-}
+
data SpecialiseData
= SpecData Bool
-- True <=> Specialisation performed
initSpecData local_tycons tycon_specs
= SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
+
+{-
\end{code}
ToDo[sansom]: Transformation data to process specialisation requests.
&& (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])
+ pprTrace "\nSpecialiser Stats:\n" (vcat [
+ hcat [ptext SLIT("SpecCalls "), int spec_calls],
+ hcat [ptext SLIT("SpecInsts "), int spec_insts],
+ space])
else id)
(final_binds,
= scopeM `thenSM` \ (binds, scope_uds) ->
let
(tycons_cis, gotci_scope_uds)
- = getLocalSpecTyConIs opt_CompilingPrelude scope_uds
+ = getLocalSpecTyConIs False{-OLD:opt_CompilingGhcInternals-} scope_uds
tycon_specs_list = collectTyConSpecs tycons_cis
in
(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
+ (vcat [ if not (null specs) then
+ hang (hsep [(ppr tycon), ptext SLIT("at types")])
+ 4 (vcat (map pp_specs specs))
+ else empty
| (tycon, specs) <- tycon_specs_list])
else id) (
returnSM (binds, tycon_specs_list, gotci_scope_uds)
uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
- pp_specs (False, spec_tys) = ppInterleave ppNil [pprMaybeTy PprDebug spec_ty | spec_ty <- spec_tys]
+ pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys]
\end{code}
-- 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 (Var vu), singleFvUDs (VarArg vl))
-
- 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` \ ~(speced, call) ->
- let
- uds = unionUDList [call_uds,
- singleFvUDs vatom,
- unionUDList [uds | (_,uds,_) <- arg_info]
- ]
- in
- returnSM (call, tickSpecCall speced uds)
+ = specId v $ \ v_arg ->
+ case v_arg of
+ LitArg lit -> ASSERT( null args )
+ returnSM (Lit lit, emptyUDs)
+
+ VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds ->
+ returnSM (mkGenApp (Var new_v) args, uds)
specExpr expr@(Lit _) null_args
= ASSERT (null null_args)
specExpr (Con con args) null_args
= ASSERT (null null_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)
+ specArgs args $ \ args' ->
+ mkTyConInstance con args' `thenSM` \ con_uds ->
+ returnSM (Con con args', con_uds)
specExpr (Prim op@(CCallOp str is_asm may_gc arg_tys res_ty) args) null_args
= ASSERT (null null_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)
+ specArgs args $ \ args' ->
+ mapSM specTy arg_tys `thenSM` \ arg_tys' ->
+ specTy res_ty `thenSM` \ res_ty' ->
+ returnSM (Prim (CCallOp str is_asm may_gc arg_tys' res_ty') args', emptuUDs)
specExpr (Prim prim args) null_args
= ASSERT (null null_args)
- let
- (targs, vargs) = partition_args args
- in
- mapAndUnzipSM specTyArg targs `thenSM` \ (targs, tys) ->
- mapAndUnzip3SM specValArg vargs `thenSM` \ (vargs, args_uds_s, unlifts) ->
+ specArgs args $ \ args' ->
-- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (applyBindUnlifts unlifts (Prim prim (targs ++ vargs)),
- unionUDList args_uds_s {-`unionUDs` prim_uds-} )
+ returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
{- ToDo: specPrimOp
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) ->
+ = specArg arg `thenSM` \ new_arg ->
+ specExpr fun (new_arg : args) `thenSM` \ (expr,uds) ->
returnSM (expr, uds)
specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg
returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
unionUDList args_uds_s `unionUDs` expr_uds)
+specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
+
-- ToDo: This may leave some unspec'd dictionaries!!
\end{code}
-- We use ty_args of scrutinee type to identify specialisation of
-- alternatives:
- (_, ty_args, _) = getAppDataTyCon scrutinee_ty
+ (_, ty_args, _) = --trace "Specialise.specAlts:getAppData..." $
+ splitAlgTyConApp scrutinee_ty
specAlgAlt ty_args (con,binders,rhs)
= specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
is_ty_arg _ = False
----------
-preSpecArg :: CoreArg -> SpecM CoreArg -- diddle TyArgs, but nothing else
-
-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)
+specId :: Id
+ -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
+ -> SpecM (CoreExpr, UsageDetails)
+specId v
= lookupId v `thenSM` \ vlookup ->
case vlookup of
+
Lifted vl vu
- -> returnSM (VarArg vu, singleFvUDs (VarArg vl), bindUnlift vl vu)
+ -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) ->
+ returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
NoLift vatom
- -> returnSM (vatom, singleFvUDs vatom, id)
+ -> thing_inside vatom `thenSM` \ (expr, uds) ->
+ returnSM (expr, singleFvUDs vatom `unionUDs` uds)
+specArg :: CoreArg
+ -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
+ -> SpecM (CoreExpr, UsageDetails))
-------------------
-specTyArg (TyArg ty)
+specArg (TyArg ty) thing_inside
= specTy ty `thenSM` \ new_ty ->
- returnSM (TyArg new_ty, new_ty)
+ thing_inside (TyArg new_ty)
+
+specArg (LitArg lit)
+ = thing_inside (LitArg lit)
+
+specArg (VarArg v)
---------------
-specOutArg :: CoreArg -> SpecM (CoreArg, UsageDetails,
- CoreExpr -> CoreExpr)
-specOutArg (TyArg ty) -- already speced; no action
- = returnSM (TyArg ty, emptyUDs, id)
+specArgs [] thing_inside
+ = thing_inside []
-specOutArg other_arg -- unprocessed; spec the atom
- = specValArg other_arg
+specArgs (arg:args) thing_inside
+ = specArg arg $ \ arg' ->
+ specArgs args $ \ args' ->
+ thing_inside (arg' : args')
\end{code}
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))]))
+ ) (hang (hcat [ptext SLIT("{"),
+ interppSP new_ids,
+ ptext SLIT("}")])
+ 4 (vcat [vcat (map (pprGenType . idType) new_ids),
+ vcat (map pprCI (concat equiv_ciss))]))
(returnSM ([], emptyUDs, []))
where
We return a new definition
- f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2
+ $f1 = /\a -> orig_rhs t1 a t3 d1 d2
-The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat)
+The SpecInfo for f will be:
- SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3
+ SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
Based on this SpecInfo, a call instance of f
- ...(f t1 t2 t3 d1 d2)...
+ ...(f t1 t2 t3)...
should get replaced by
- ...(f@t1//t3 t2)...
+ ...(\d1 d2 -> $f1 t2)...
-(But that is the business of @mkCall@.)
+(But that is the business of the simplifier.)
\begin{code}
mkOneInst :: CallInstance
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
+ -- which correspond to unspecialised args
arg_tys :: [Type]
(_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
-- "required" by one of the other Ids in the Rec
| top_lev && maybeToBool lookup_orig_spec
= (if opt_SpecialiseTrace
- then trace_nospec " Exists: " exists_id
+ then trace_nospec " Exists: " orig_id
else id) (
returnSM (Nothing, emptyUDs, Nothing)
mkCoLetsNoUnboxed local_dict_binds (mkTyLam poly_tyvars inst_rhs)),
tickSpecInsts final_uds, spec_info)
where
- lookup_orig_spec = lookupSpecEnv (getIdSpecialisation orig_id) arg_tys
- Just (exists_id, _, _) = lookup_orig_spec
+ lookup_orig_spec = matchSpecEnv (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
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])
+ (hsep [ppr new_id, hsep (map pp_ty arg_tys),
+ ptext SLIT("==>"), ppr spec_id])
in
(if opt_SpecialiseTrace then
pprTrace "Specialising:"
- (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]]))
+ (hang (hcat [char '{',
+ interppSP new_ids,
+ char '}'])
+ 4 (vcat [
+ hcat [ptext SLIT("types: "), hsep (map pp_ty arg_tys)],
+ if isExplicitCI do_cis then empty else
+ hcat [ptext SLIT("dicts: "), hsep (map pp_dict dict_args)],
+ hcat [ptext SLIT("specs: "), ppr spec_ids]]))
else id) (
do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
returnSM (maybe_inst_bind, inst_uds, spec_infos)
)
where
- pp_dict d = ppr_arg PprDebug d
- pp_ty t = pprParendGenType PprDebug t
+ pp_dict d = ppr_arg d
+ pp_ty t = pprParendGenType t
do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
do_the_wotsit tyvars (Just ty) = (tyvars, ty)
\begin{code}
mkCallInstance :: Id
-> Id
- -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
+ -> [CoreArg]
-> SpecM UsageDetails
-mkCallInstance id new_id []
- = returnSM emptyUDs
-
mkCallInstance id new_id args
-
- -- No specialised versions for "error" and friends are req'd.
- -- This is a special case in core lint etc.
-
- | isBottomingId id
- = returnSM emptyUDs
-
- -- No call instances for SuperDictSelIds
- -- These are a special case in mkCall
-
- | maybeToBool (isSuperDictSelId_maybe id)
+ | null args || -- No args at all
+ idWantsToBeINLINEd id || -- It's going to be inlined anyway
+ not enough_args || -- Not enough type and dict args
+ not interesting_overloading -- Overloaded types are just tyvars
= returnSM emptyUDs
- -- 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
- = let
- spec_overloading = opt_SpecialiseOverloaded
- spec_unboxed = opt_SpecialiseUnboxed
- spec_all = opt_SpecialiseAll
+ = returnSM (singleCI new_id spec_tys dicts)
- (tyvars, class_tyvar_pairs) = getIdOverloading id
-
- arg_res = take_type_args tyvars class_tyvar_pairs args
- enough_args = maybeToBool arg_res
-
- (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
-
- record = 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 : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args]))
- else
- 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
+ where
+ (tyvars, theta, _) = splitSigmaTy (idType id)
+ constrained_tyvars = tyvarsOfTypes (map snd class_tyvar_pairs)
+
+ arg_res = take_type_args tyvars class_tyvar_pairs args
+ enough_args = maybeToBool arg_res
+ (Just (tys, dicts, rest_args)) = arg_res
+
+ interesting_overloading = not (null (catMaybes spec_tys))
+ spec_tys = zipWithEqual "spec_ty" spec_ty tyvars tys
+
+ ---------------------------------------------------------------
+ -- Should we specialise on this type argument?
+ spec_ty tyvar ty | isTyVarTy ty = Nothing
+
+ spec_ty tyvar ty | opt_SpecialiseAll
+ || (opt_SpecialiseUnboxed
+ && isUnboxedType ty
+ && isBoxedTypeKind (tyVarKind tyvar))
+ || (opt_SpecialiseOverloaded
+ && tyvar `elemTyVarSet` constrained_tyvars)
+ = Just ty
+
+ | otherwise = Nothing
+
+ ----------------- Rather a gruesome help-function ---------------
+ take_type_args (_:tyvars) (TyArg ty : args)
+ = case (take_type_args tyvars args) of
+ Nothing -> Nothing
Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
-take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing
+ take_type_args (_:tyvars) [] = Nothing
-take_type_args [] class_tyvar_pairs args
+ take_type_args [] 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
+ 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 (_:class_tyvar_pairs) args = Nothing
-take_dict_args [] args = Just ([], args)
+ take_dict_args [] args = Just ([], args)
\end{code}
-\begin{code}
-mkCall :: Id
- -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
- -> SpecM (Bool, CoreExpr)
-
-mkCall new_id args
- | 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 core-lint happy.
- = let
- 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 (False, Var super_dict_id)
-
- | otherwise
- = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
- Nothing -> checkUnspecOK new_id ty_args (
- returnSM (False, unspec_call)
- )
-
- 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
- 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 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
- 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
- let
- (vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkTyApp (Var spec_id) tys_left
- applied_vals = mkGenApp applied_tys vals_left
- in
- returnSM (True, applyBindUnlifts unlifts_left applied_vals)
- )
- where
- (tys_and_vals, _, unlifts) = unzip3 args
- unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
-
-
- -- ty_args is the types at the front of the arg list
- -- val_args is the rest of the arg-list
-
- (ty_args, val_args) = get args
- where
- get ((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 ((a,_,_) : args)
- | isValArg a = toss_dicts (n-1) args
-
-\end{code}
-
-\begin{code}
-checkUnspecOK :: Id -> [Type] -> a -> a
-checkUnspecOK check_id 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 (pprParendGenType PprDebug) tys)])
- else id
-
-checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
-checkSpecOK check_id tys spec_id 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 (pprParendGenType PprDebug) tys)],
- ppCat [ppr PprDebug spec_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]])
- else id
-\end{code}
\begin{code}
mkTyConInstance :: Id
case record_inst of
Nothing -- No TyCon instance
-> -- pprTrace "NoTyConInst:"
- -- (ppCat [ppr PprDebug tycon, ppStr "at",
- -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
+ -- (hsep [ppr tycon, ptext SLIT("at"),
+ -- ppr con, hsep (map (ppr) 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 ")"]])
+ -- (hsep [ppr tycon, ptext SLIT("at"),
+ -- ppr con, hsep (map (ppr) tys),
+ -- hcat [char '(',
+ -- hsep [pprMaybeTy ty | ty <- spec_tys],
+ -- char ')']])
(returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
where
tycon = dataConTyCon con
tys)
in
-- pprTrace "ConSpecExists?: "
- -- (ppAboves [ppStr (if spec_exists then "True" else "False"),
- -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
+ -- (vcat [ptext (if spec_exists then SLIT("True") else SLIT("False")),
+ -- ppr PprShowAll con, hsep (map ppr tys)])
(if (not spec_exists && do_tycon_spec)
then returnSM (Just spec_tys)
else returnSM Nothing)
-> UniqSupply
-> result
-initSM m uniqs
- = m nullTyVarEnv nullIdEnv uniqs
+initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs
returnSM :: a -> SpecM a
thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us
= [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id)
- | (id,uniq) <- new_ids `zip` uniqs ]
+ | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ]
where
uniqs = getUniques (length new_ids) us
spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore
newTyVars :: Int -> SpecM [TyVar]
-newTyVars n tvenv idenv us
- = map mkPolySysTyVar uniqs
- where
- uniqs = getUniques n us
+newTyVars n tvenv idenv us
+ = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
\end{code}
@cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of
= let
uniqs = getUniques (length old_ids) us
in
- unzip (zipWithEqual clone_it old_ids uniqs)
+ unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
where
clone_it old_id uniq
= (new_id, NoLift (VarArg new_id))
-- Don't clone if it is a top-level thing. Why not?
-- (a) we don't want to change the uniques
- -- on such things (see TopLevId in Id.lhs)
+ -- on such things
-- (b) we don't have to be paranoid about name capture
-- (c) the thing is polymorphic so no need to subst
mk_old_to_clone rest_olds rest_clones spec_infos_rest
where
add_spec_info (NoLift (VarArg new))
- = NoLift (VarArg (new `addIdSpecialisation`
- (mkSpecEnv spec_infos_this_id)))
+ = NoLift (VarArg (new `addIdSpecialisation` (mkSpecEnv spec_infos_this_id)))
add_spec_info lifted
= lifted -- no specialised instances for unboxed lifted values
specTy :: Type -> SpecM Type -- Apply the current type envt to the type
specTy ty tvenv idenv us
- = applyTypeEnvToTy tvenv ty
+ = instantiateTy tvenv ty
\end{code}
\begin{code}
mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
+-}
+\end{code}
+
+
+
+===================== OLD CODE, scheduled for deletion =================
+
+\begin{code}
+{-
+mkCall :: Id
+ -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
+ -> SpecM CoreExpr
+
+mkCall new_id arg_infos = returnSM (
+
+ | 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 core-lint happy.
+ = let
+ 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 (False, Var super_dict_id)
+
+ | otherwise
+ = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
+ Nothing -> checkUnspecOK new_id ty_args (
+ returnSM (False, unspec_call)
+ )
+
+ 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
+ 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 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
+ pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
+ (hsep [ppr new_id,
+ hsep (map (pprParendGenType) ty_args),
+ ptext SLIT("==>"),
+ ppr spec_id])
+ else
+ let
+ (vals_left, _, unlifts_left) = unzip3 args_left
+ applied_tys = mkTyApp (Var spec_id) tys_left
+ applied_vals = mkGenApp applied_tys vals_left
+ in
+ returnSM (True, applyBindUnlifts unlifts_left applied_vals)
+ )
+ where
+ (tys_and_vals, _, unlifts) = unzip3 args
+ unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
+
+
+ -- ty_args is the types at the front of the arg list
+ -- val_args is the rest of the arg-list
+
+ (ty_args, val_args) = get args
+ where
+ get ((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 ((a,_,_) : args)
+ | isValArg a = toss_dicts (n-1) args
+
+\end{code}
+
+\begin{code}
+checkUnspecOK :: Id -> [Type] -> a -> a
+checkUnspecOK check_id tys
+ = if isLocallyDefined check_id && any isUnboxedType tys
+ then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
+ (hsep [ppr check_id,
+ hsep (map (pprParendGenType) tys)])
+ else id
+
+checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a
+checkSpecOK check_id tys spec_id tys_left
+ = if any isUnboxedType tys_left
+ then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
+ (vcat [hsep [ppr check_id,
+ hsep (map (pprParendGenType) tys)],
+ hsep [ppr spec_id,
+ hsep (map (pprParendGenType) tys_left)]])
+ else id
+-}
\end{code}