\begin{code}
module Specialise (
- specProgram,
- initSpecData,
-
- SpecialiseData(..)
+ specProgram
) where
#include "HsVersions.h"
-import Bag ( emptyBag, unitBag, isEmptyBag, unionBags,
- partitionBag, listToBag, bagToList, Bag
- )
-import Class ( Class )
-import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats,
- opt_SpecialiseTrace
- )
-import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
-import CoreSyn
-import CoreUtils ( coreExprType, squashableDictishCcExpr )
-import FiniteMap ( addListToFM_C, FiniteMap )
-import Kind ( mkBoxedTypeKind, isBoxedTypeKind )
-import Id ( idType, isDefaultMethodId_maybe, toplevelishId,
- isBottomingId,
- isDataCon,
- isImportedId, mkIdWithNewUniq,
- dataConTyCon, applyTypeEnvToId,
- nullIdEnv, addOneToIdEnv, growIdEnvList,
- lookupIdEnv, IdEnv,
- emptyIdSet, mkIdSet, unitIdSet,
- elementOfIdSet, minusIdSet,
- unionIdSets, unionManyIdSets, IdSet,
- GenId{-instance Eq-}, Id
- )
-import Literal ( Literal{-instance Outputable-} )
-import Maybes ( catMaybes, firstJust, maybeToBool )
-import Name ( isLocallyDefined )
-import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
- GenType{-instance Outputable-}, GenTyVar{-ditto-},
- TyCon{-ditto-}
+import Id ( Id, DictVar, idType, mkUserLocal,
+
+ getIdSpecialisation, addIdSpecialisation, isSpecPragmaId,
+
+ IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet,
+ emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet,
+
+ IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv
)
-import PrimOp ( PrimOp(..) )
-import SpecUtils
-import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, splitAlgTyConApp,
- tyVarsOfTypes, instantiateTy, isUnboxedType, isDictTy,
- Type
+
+import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
+ tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
)
-import TyCon ( TyCon{-instance Eq-} )
-import TyVar ( cloneTyVar, mkSysTyVar,
- elementOfTyVarSet, TyVarSet,
- emptyTyVarEnv, growTyVarEnvList, TyVarEnv,
- GenTyVar{-instance Eq-}
+import TyCon ( TyCon )
+import TyVar ( TyVar,
+ TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
+ elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
+ TyVarEnv, mkTyVarEnv
)
-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
+import CoreSyn
+import OccurAnal ( occurAnalyseGlobalExpr )
+import Name ( NamedThing(..), getSrcLoc )
+import SpecEnv ( addToSpecEnv )
+
+import UniqSupply ( UniqSupply,
+ UniqSM, initUs, thenUs, returnUs, getUnique, mapUs
)
+
+import FiniteMap
+import Maybes ( MaybeErr(..) )
+import Bag
import List ( partition )
+import Util ( zipEqual )
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)"
-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)"
+infixr 9 `thenSM`
\end{code}
%************************************************************************
*** no specialised version is overloaded ***
+%************************************************************************
+%* *
+\subsubsection{The exported function}
+%* *
+%************************************************************************
+
+\begin{code}
+specProgram :: UniqSupply -> [CoreBinding] -> [CoreBinding]
+specProgram us binds
+ = initSM us (go binds `thenSM` \ (binds', _) ->
+ returnSM binds'
+ )
+ where
+ go [] = returnSM ([], emptyUDs)
+ go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
+ specBind bind uds `thenSM` \ (bind', uds') ->
+ returnSM (bind' ++ binds', uds')
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@specExpr@: the main function}
+%* *
+%************************************************************************
+
\begin{code}
specExpr :: CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr (Coerce co ty body)
= specExpr body `thenSM` \ (body', uds) ->
- returnSM (Coerce co ty body')
+ returnSM (Coerce co ty body', uds)
specExpr (SCC cc body)
= specExpr body `thenSM` \ (body', uds) ->
- returnSM (SCC cc body')
+ returnSM (SCC cc body', uds)
---------------- Applications might generate a call instance --------------------
let
(filtered_uds, body'') = dumpUDs bndrs uds body'
in
- returnSM (Lam bndr body'', filtered_uds)
+ returnSM (foldr Lam body'' bndrs, filtered_uds)
where
(bndrs, body) = go [] e
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)
+ returnSM (PrimAlts alts' deflt', uds1 `plusUDs` uds2)
spec_alg_alt (con, args, rhs)
= specExpr rhs `thenSM` \ (rhs', uds) ->
= specExpr rhs `thenSM` \ (rhs', uds) ->
returnSM ((lit, rhs'), uds)
- spec_deflt NoDefault = (NoDefault, emptyUDs)
+ spec_deflt NoDefault = returnSM (NoDefault, emptyUDs)
spec_deflt (BindDefault arg rhs)
= specExpr rhs `thenSM` \ (rhs', uds) ->
let
- (uds', rhs'') = dumpManyUDs [ValBinder arg] uds rhs'
+ (uds', rhs'') = dumpUDs [ValBinder arg] uds rhs'
in
returnSM (BindDefault arg rhs'', uds')
---------------- Finally, let is the interesting case --------------------
-specExpr (Let (NonRec bndr rhs) body)
- = -- Deal with the body
+specExpr (Let bind body)
+ = -- Deal with the body
specExpr body `thenSM` \ (body', body_uds) ->
- -- Deal with the RHS, specialising it according
- -- to the calls found in the body
- specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+ -- Deal with the bindings
+ specBind bind body_uds `thenSM` \ (binds', uds) ->
+
+ -- All done
+ returnSM (foldr Let body' binds', uds)
+\end{code}
+%************************************************************************
+%* *
+\subsubsection{Dealing with a binding}
+%* *
+%************************************************************************
+
+\begin{code}
+specBind :: CoreBinding
+ -> UsageDetails -- Info on how the scope of the binding
+ -> SpecM ([CoreBinding], -- New bindings
+ UsageDetails) -- And info to pass upstream
+
+specBind (NonRec bndr rhs) body_uds
+ | isDictTy (idType bndr)
+ = -- It's a dictionary binding
+ -- Pick it up and float it outwards.
+ specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
let
- all_uds = deleteCalls (rhs_uds `plusUDs` body_uds) bndr'
+ all_uds = rhs_uds `plusUDs` addDictBind body_uds bndr rhs'
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')
+ returnSM ([], all_uds)
- else if isSpecPragmaId bndr then
+ | isSpecPragmaId bndr
-- SpecPragmaIds are there solely to generate specialisations
- -- Just drop the whole binding
- ASSERT( null spec_defns )
- returnSM (body', all_uds)
+ -- Just drop the whole binding; keep only its usage details
+ = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
+ returnSM ([], rhs_uds `plusUDs` body_uds)
- else
- -- An ordinary binding, so glue it all together
- returnSM (
- Let (NonRec bndr' rhs') (mkLets spec_defns body'),
- all_uds
- )
+ | otherwise
+ = -- Deal with the RHS, specialising it according
+ -- to the calls found in the body
+ specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
+ let
+ (all_uds, (dict_binds, dump_calls))
+ = splitUDs [ValBinder bndr'] (spec_uds `plusUDs` body_uds)
+ in
+ returnSM ( [NonRec bndr' rhs']
+ ++ dict_binds
+ ++ spec_defns,
+ all_uds )
+specBind (Rec pairs) body_uds
+ = mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff ->
+ let
+ (pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
+ spec_defns = concat spec_defns_s
+ spec_uds = plusUDList spec_uds_s
+ (all_uds, (dict_binds, dump_calls))
+ = splitUDs (map (ValBinder . fst) pairs') (spec_uds `plusUDs` body_uds)
+ in
+ returnSM ( [Rec pairs']
+ ++ dict_binds
+ ++ spec_defns,
+ all_uds )
+
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
+ [CoreBinding], -- 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
+ && n_dicts <= length rhs_bndrs -- and enough dict args
&& not (null calls_for_me) -- And there are some calls to specialise
= -- Specialise the body of the function
specExpr body `thenSM` \ (body', body_uds) ->
+ let
+ (float_uds, bound_uds@(dict_binds,_)) = splitUDs rhs_bndrs body_uds
+ in
-- Make a specialised version for each call in calls_for_me
- mapSM (spec_call body_uds) calls_for_me `thenSM` \ stuff ->
+ mapSM (spec_call bound_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
+ fn' = addIdSpecialisations fn spec_env_stuff
+ rhs' = foldr Lam (foldr Let body' dict_binds) rhs_bndrs
in
returnSM ((fn',rhs'),
spec_defns,
- rhs_uds `plusUDs` plusUDList spec_uds)
+ float_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)
+ fn_type = idType fn
+ (tyvars, theta, tau) = splitSigmaTy fn_type
n_tyvars = length tyvars
n_dicts = length theta
Nothing -> []
Just cs -> fmToList cs
-
-- Specialise to one particular call pattern
- spec_call :: UsageDetails -- From the original body
+ spec_call :: ProtoUsageDetails -- From the original body, captured by
+ -- the dictionary lambdas
-> ([Maybe Type], [DictVar]) -- Call instance
- -> ((Id, CoreExpr), -- Specialised definition
- UsageDetails, -- Usage details from specialised body
- ([Type], CoreExpr)) -- Info for the Id's SpecEnv
- spec_call body_uds (call_ts, call_ds)
+ -> SpecM (CoreBinding, -- Specialised definition
+ UsageDetails, -- Usage details from specialised body
+ ([Type], CoreExpr)) -- Info for the Id's SpecEnv
+ spec_call bound_uds (call_ts, call_ds)
= ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
-- Calls are only recorded for properly-saturated applications
-- Supppose the call is for f [Just t1, Nothing, Just t3, Nothing] [d1, d2]
-- Construct the new binding
- -- f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
+ -- f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
-- and the type of this binder
let
- spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_tys]
+ spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_ts]
spec_tys = zipWith mk_spec_ty call_ts tyvars
spec_rhs = mkTyLam spec_tyvars $
mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
- spec_id_ty = mkForAllTys spec_tyvars (applyTys (idType f) spec_tys)
+ spec_id_ty = mkForAllTys spec_tyvars (applyTys fn_type spec_tys)
mk_spec_ty (Just ty) _ = ty
mk_spec_ty Nothing tyvar = mkTyVarTy tyvar
in
- newIdSM f spec_id_ty `thenSM` \ spec_f ->
+ newIdSM fn spec_id_ty `thenSM` \ spec_f ->
-- Construct the stuff for f's spec env
in
-- Specialise the UDs from f's RHS
- specUDs (zipEqual rhs_tyvars call_ts)
- (zipEqual rhs_dicts call_ds)
- body_uds `thenSM` \ spec_uds ->
+ let
+ tv_env = [ (rhs_tyvar,ty)
+ | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts
+ ]
+ dict_env = zipEqual "specUDs2" rhs_dicts call_ds
+ in
+ specUDs tv_env dict_env bound_uds `thenSM` \ spec_uds ->
- returnSM ((spec_f, spec_rhs),
+ returnSM (NonRec spec_f spec_rhs,
spec_uds,
spec_env_info
)
data UsageDetails
= MkUD {
- free_dicts :: !FreeDicts, -- Dicts free in any of the calls or dict binds
-
- dict_binds :: !Bag (DictVar, CoreExpr, FreeDicts),
+ dict_binds :: !(Bag (DictVar, CoreExpr, TyVarSet, FreeDicts)),
-- Floated dictionary bindings
-- The order is important;
-- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
calls :: !CallDetails
}
-type CallMap = FiniteMap Id CallInfo
-type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument
- [DictVar] -- Dict args
+emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM }
+
+type ProtoUsageDetails = ([CoreBinding], -- Dict bindings
+ [(Id, [Maybe Type], [DictVar])]
+ )
+
+------------------------------------------------------------
+type CallDetails = 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}
+callDetailsToList calls = [ (id,tys,dicts)
+ | (id,fm) <- fmToList calls,
+ (tys,dicts) <- fmToList fm
+ ]
+
+listToCallDetails calls = foldr (unionCalls . singleCall) emptyFM calls
+
+unionCalls :: CallDetails -> CallDetails -> CallDetails
+unionCalls c1 c2 = plusFM_C plusFM c1 c2
+
+singleCall (id, tys, dicts) = unitFM id (unitFM tys dicts)
+
+mkCallUDs f args
+ | null theta
+ || length spec_tys /= n_tyvars
+ || length dicts /= n_dicts
+ = emptyUDs -- Not overloaded
+
+ | otherwise
+ = MkUD {dict_binds = emptyBag,
+ calls = singleCall (f, spec_tys, dicts)
+ }
where
- fvs = fvs1 `unionIdSets` fvs2
- dictBinds = db1 `unionBags` db2
- calls = calls1 `unionBags` calls2
+ (tyvars, theta, tau) = splitSigmaTy (idType f)
+ constrained_tyvars = foldr (unionTyVarSets . tyVarsOfTypes . snd) emptyTyVarSet theta
+ n_tyvars = length tyvars
+ n_dicts = length theta
+
+ spec_tys = [mk_spec_ty tv ty | (tv, TyArg ty) <- tyvars `zip` args]
+ dicts = [d | (_, VarArg d) <- theta `zip` (drop n_tyvars args)]
+
+ mk_spec_ty tyvar ty | tyvar `elementOfTyVarSet` constrained_tyvars
+ = Just ty
+ | otherwise
+ = Nothing
+------------------------------------------------------------
+plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
+plusUDs (MkUD {dict_binds = db1, calls = calls1})
+ (MkUD {dict_binds = db2, calls = calls2})
+ = MkUD {dict_binds, calls}
+ where
+ dict_binds = db1 `unionBags` db2
+ calls = calls1 `unionCalls` calls2
-tyVarsOfUDs (MkUD {fvs}) = tyVarsOfTypes (map idType (idSetToList fvs))
+plusUDList = foldr plusUDs emptyUDs
-deleteCalls uds bndr = uds { calls = delFromFM (calls uds) bndr }
+mkDB dict rhs = (dict, rhs, db_ftvs, db_fvs)
+ where
+ db_ftvs = tyVarsOfType (idType dict) -- Superset of RHS fvs
+ db_fvs = dictRhsFVs rhs
-addDictBind uds dict rhs = uds { free_dicts = addToIdSet (free_dicts uds) dict,
- dict_binds = (dict, rhs, f
+addDictBind uds dict rhs = uds { dict_binds = mkDB dict rhs `consBag` dict_binds uds }
dumpUDs :: [CoreBinder]
-> UsageDetails -> CoreExpr
-> (UsageDetails, CoreExpr)
+dumpUDs bndrs uds body
+ = (free_uds, foldr Let body dict_binds)
+ where
+ (free_uds, (dict_binds, _)) = splitUDs bndrs uds
-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
+splitUDs :: [CoreBinder]
+ -> UsageDetails
+ -> (UsageDetails, -- These don't mention the binders
+ ProtoUsageDetails) -- These do
+
+splitUDs bndrs uds@(MkUD {dict_binds = orig_dbs,
+ calls = orig_calls})
- if isEmptyIdSet (id_set `intersectIdSets` fvs) then
+ = if isEmptyBag dump_dbs && null dump_calls then
-- Common case: binder doesn't affect floats
- (uds, body)
+ (uds, ([],[]))
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)
+ (MkUD {dict_binds = free_dbs,
+ calls = listToCallDetails free_calls},
+ (bagToList dump_dbs, dump_calls)
+ )
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
+ tyvar_set = mkTyVarSet [tv | TyBinder tv <- bndrs]
+ id_set = mkIdSet [id | ValBinder id <- bndrs]
+
+ (free_dbs, dump_dbs, dump_idset)
+ = foldlBag dump_db (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)
+ -- Don't need to worry about the tyvars because the dicts will
+ -- spot the captured ones; any fully polymorphic arguments will
+ -- be Nothings in the call details
+ orig_call_list = callDetailsToList orig_calls
+ (dump_calls, free_calls) = partition captured orig_call_list
+ captured (id,tys,dicts) = any (`elementOfIdSet` dump_idset) (id:dicts)
+
+ dump_db (free_dbs, dump_dbs, dump_idset) db@(dict, rhs, ftvs, fvs)
+ | isEmptyIdSet (dump_idset `intersectIdSets` fvs)
+ && isEmptyTyVarSet (tyvar_set `intersectTyVarSets` ftvs)
+ = (free_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
+ = (free_dbs, dump_dbs `snocBag` NonRec dict rhs,
+ dump_idset `addOneToIdSet` dict)
\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
- }
+specUDs :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails
+specUDs tv_env_list dict_env_list (dbs, calls)
+ = specDBs dict_env dbs `thenSM` \ (dict_env', dbs') ->
+ returnSM (MkUD { dict_binds = dbs',
+ calls = listToCallDetails (map (inst_call dict_env') calls)
+ })
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}
+ tv_env = mkTyVarEnv tv_env_list
+ dict_env = mkIdEnv dict_env_list
+
+ inst_call dict_env (id, tys, dicts) = (id, map inst_maybe_ty tys,
+ map (lookupId dict_env) dicts)
+ inst_maybe_ty Nothing = Nothing
+ inst_maybe_ty (Just ty) = Just (instantiateTy tv_env ty)
+
+ specDBs dict_env []
+ = returnSM (dict_env, emptyBag)
+ specDBs dict_env (NonRec dict rhs : dbs)
+ = newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' ->
+ let
+ dict_env' = addOneToIdEnv dict_env dict dict'
+ rhs' = instantiateDictRhs tv_env dict_env rhs
+ in
+ specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') ->
+ returnSM ( dict_env'', mkDB dict' rhs' `consBag` dbs' )
+\end{code}
%************************************************************************
%* *
%************************************************************************
\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
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 (VarArg a)) = App (go e1) (VarArg (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 =================================
-
-%************************************************************************
-%* *
-\subsubsection[CallInstances]{@CallInstances@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-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}
-pprCI :: CallInstance -> Doc
-pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
- = hang (hsep [ptext SLIT("Call inst for"), ppr id])
- 4 (vcat [hsep (text "types" : [pprMaybeTy ty | ty <- spec_tys]),
- case maybe_specinfo of
- Nothing -> hsep (text "dicts" : [ppr_arg dict | dict <- dicts])
- Just (SpecInfo _ _ spec_id)
- -> hsep [ptext SLIT("Explicit SpecId"), ppr spec_id]
- ])
-
--- ToDo: instance Outputable CoreArg?
-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 _ _ _)
- = any isUnboxedType (catMaybes spec_tys)
-
-isExplicitCI :: CallInstance -> Bool
-isExplicitCI (CallInstance _ _ _ _ (Just _))
- = True
-isExplicitCI (CallInstance _ _ _ _ Nothing)
- = False
-\end{code}
-
-Comparisons are based on the {\em types}, ignoring the dictionary args:
-
-\begin{code}
-
-cmpCI :: CallInstance -> CallInstance -> Ordering
-cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
- = compare id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
-
-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 }
-
-isCIofTheseIds :: [Id] -> CallInstance -> Bool
-isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
- = any ((==) ci_id) ids
-
-singleCI :: Id -> [Maybe Type] -> [CoreArg] -> UsageDetails
-singleCI id tys dicts
- = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
- emptyBag [] emptyIdSet 0 0
- where
- fv_set = mkIdSet (id : [dict | (VarArg dict) <- dicts])
-
-explicitCI :: Id -> [Maybe Type] -> SpecInfo -> UsageDetails
-explicitCI id tys specinfo
- = 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 = 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
-
-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 (getCIids top_lev ids)) cis
- cis_here_list = bagToList cis_here
- in
- -- pprTrace "getCIs:"
- -- (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
- -> 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
-
- -- 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")
- (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"
- (hang (hcat [char '{',
- interppSP full_ids,
- char '}'])
- 4 (vcat (map pprCI (bagToList cis_dump))))
- else id)
- cis_keep_not_bound_id
- )
- where
- (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
-
- (_, 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_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
-
-\end{code}
-
-Any call instances of a bound_id can be safely dumped, because any
-recursive calls should be at the same instance as the parent instance.
-
- letrec f = /\a -> \x::a -> ...(f t x')...
-
-Here, the type, t, at which f is used in its own RHS should be
-just "a"; that is, the recursive call is at the same type as
-the original call. That means that when specialising f at some
-type, say Int#, we shouldn't find any *new* instances of f
-arising from specialising f's RHS. The only instance we'll find
-is another call of (f Int#).
-
-We 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.
-
-We also report CIs dumped due to a bound dictionary arg if they
-contain unboxed types.
-
-%************************************************************************
-%* *
-\subsubsection[TyConInstances]{@TyConInstances@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-data TyConInstance
- = TyConInstance TyCon -- Type Constructor
- [Maybe Type] -- Applied to these specialising types
-
-cmpTyConI :: TyConInstance -> TyConInstance -> Ordering
-cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
- = compare tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2
-
-cmpTyConI_tys :: TyConInstance -> TyConInstance -> Ordering
-cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
- = cmpUniTypeMaybeList tys1 tys2
-
-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 _) = 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 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 c i)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[UsageDetails]{@UsageDetails@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-data UsageDetails
- = UsageDetails
- (Bag CallInstance) -- The collection of call-instances
- (Bag TyConInstance) -- Constructor call-instances
- [DictBindDetails] -- Dictionary bindings in data-dependence order!
- FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned)
- Int -- no. of spec calls
- 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
-will *include* the binders of the DictBind details.
+dictRhsFVs (App e1 (VarArg a)) = dictRhsFVs e1 `addOneToIdSet` a
+dictRhsFVs (App e1 (TyArg t)) = dictRhsFVs e1
+dictRhsFVs (Var v) = unitIdSet v
+dictRhsFVs (Lit l) = emptyIdSet
-A @DictBindDetails@ contains bindings for dictionaries *only*.
-\begin{code}
-data DictBindDetails
- = DictBindDetails
- [Id] -- Main binders, originally visible in scope of binding (cloned)
- CoreBinding -- Fully processed
- FreeVarsSet -- Free in binding group (cloned)
- FreeTyVarsSet -- Free in binding group
-\end{code}
-
-\begin{code}
-emptyUDs :: UsageDetails
-unionUDs :: UsageDetails -> UsageDetails -> UsageDetails
-unionUDList :: [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
-
-tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
- = UsageDetails cis ty_cis dbs fvs c (i+1)
-
-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 `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 (VarArg v) | not (isImportedId v)
- = UsageDetails emptyBag emptyBag [] (unitIdSet v) 0 0
-singleFvUDs other
- = emptyUDs
-
-singleConUDs con = UsageDetails emptyBag emptyBag [] (unitIdSet con) 0 0
-
-dumpDBs :: [DictBindDetails]
- -> Bool -- True <=> top level bound Ids
- -> [TyVar] -- TyVars being bound (cloned)
- -> [Id] -- Ids being bound (cloned)
- -> FreeVarsSet -- Fvs of body
- -> ([CoreBinding], -- These ones have to go here
- [DictBindDetails], -- These can float further
- [Id], -- Incoming list + names of dicts bound here
- FreeVarsSet -- Incoming fvs + fvs of dicts bound here
- )
-
- -- 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 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 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
- -> ([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 c i) top_lev floating inst_cis bound_ids tvs
- = let
- (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 c i)
-\end{code}
-
-\begin{code}
-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 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 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.
- -- Doing the proper job would entail keeping track of free tyvars as
- -- well as free vars, which would be a bore.
- db_ftvs = tyVarsOfTypes (map idType dbinders)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[cloning-binders]{The Specialising IdEnv and CloneInfo}
-%* *
-%************************************************************************
-
-@SpecIdEnv@ maps old Ids to their new "clone". There are three cases:
-
-1) (NoLift LitArg l) : an Id which is bound to a literal
-
-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 :
-
- This indicates that the original Id has been specialised to an
- unboxed value which must be lifted (see "Unboxed bindings" above)
- @unlifted_id@ is the unboxed clone of the original Id
- @lifted_id@ is a *lifted* version of the original Id
-
- When you lookup Ids which are Lifted, you have to insert a case
- expression to un-lift the value (done with @bindUnlift@)
-
- You also have to insert a case to lift the value in the binding
- (done with @liftExpr@)
-
-
-\begin{code}
-type SpecIdEnv = IdEnv CloneInfo
-
-data CloneInfo
- = NoLift CoreArg -- refers to cloned id or literal
-
- | Lifted Id -- lifted, cloned id
- Id -- unlifted, cloned id
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specialise-data]{Data returned by specialiser}
-%* *
-%************************************************************************
-
-\begin{code}
--}
-
-data SpecialiseData
- = SpecData Bool
- -- True <=> Specialisation performed
- Bool
- -- False <=> Specialisation completed with errors
-
- [TyCon]
- -- Local tycons declared in this module
-
- [TyCon]
- -- Those in-scope data types for which we want to
- -- generate code for their constructors.
- -- Namely: data types declared in this module +
- -- any big tuples used in this module
- -- The initial (and default) value is the local tycons
-
- (FiniteMap TyCon [(Bool, [Maybe Type])])
- -- TyCon specialisations to be generated
- -- 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 (Bool=True)
- -- and _SPECIALISE_ pragmas (Bool=False) in the interface files
-
- (Bag (Id,[Maybe Type]))
- -- Imported specialisation errors
- (Bag (Id,[Maybe Type]))
- -- Imported specialisation warnings
- (Bag (TyCon,[Maybe Type]))
- -- Imported TyCon specialisation errors
-
-initSpecData local_tycons tycon_specs
- = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag
-
-{-
-\end{code}
-
-ToDo[sansom]: Transformation data to process specialisation requests.
-
-%************************************************************************
-%* *
-\subsection[specProgram]{Specialising a core program}
-%* *
-%************************************************************************
-
-\begin{code}
-specProgram :: UniqSupply
- -> [CoreBinding] -- input ...
- -> SpecialiseData
- -> ([CoreBinding], -- main result
- SpecialiseData) -- result specialise data
-
-specProgram uniqs binds
- (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs)
- = 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 dataConTyCon used_conids
- used_gen = filter isLocalGenTyCon used_tycons
- 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_warn = init_warn `unionBags` listToBag cis_other
- cis_errs = init_errs `unionBags` listToBag cis_unboxed
-
- uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis))
- tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis]
- tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed
-
- no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs
- && (not opt_SpecialiseImports || isEmptyBag cis_warn)
- in
- (if opt_D_simplifier_stats then
- pprTrace "\nSpecialiser Stats:\n" (vcat [
- hcat [ptext SLIT("SpecCalls "), int spec_calls],
- hcat [ptext SLIT("SpecInsts "), int spec_insts],
- space])
- else id)
-
- (final_binds,
- SpecData True no_errs local_tycons gen_tycons result_specs
- cis_errs cis_warn tycis_errs)
-
-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,
--- but I am not sure there is any benefit in doing so (Patrick)
-
--- ToDo: What about unfoldings performed after specialisation ???
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specTyConsAndScope]{Specialising data constructors within tycons}
-%* *
-%************************************************************************
-
-In the specialiser we just collect up the specialisations which will
-be required. We don't create the specialised constructors in
-Core. These are only introduced when we convert to StgSyn.
-
-ToDo: Perhaps this collection should be done in CoreToStg to ensure no inconsistencies!
-
-\begin{code}
-specTyConsAndScope :: SpecM ([CoreBinding], UsageDetails)
- -> SpecM ([CoreBinding], [(TyCon,[(Bool,[Maybe Type])])], UsageDetails)
-
-specTyConsAndScope scopeM
- = scopeM `thenSM` \ (binds, scope_uds) ->
- let
- (tycons_cis, gotci_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"
- (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)
- )
- where
- collectTyConSpecs []
- = []
- collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _)
- = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis
- where
- (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis
- uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis)
- tycon_specs = [(False, spec_tys) | TyConInstance _ spec_tys <- uniq_cis]
-
- pp_specs (False, spec_tys) = hsep [pprMaybeTy spec_ty | spec_ty <- spec_tys]
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specTopBinds]{Specialising top-level bindings}
-%* *
-%************************************************************************
-
-\begin{code}
-specTopBinds :: [CoreBinding]
- -> SpecM ([CoreBinding], UsageDetails)
-
-specTopBinds binds
- = 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
- -- arguments are dropped when a specialised call is created
- -- The simplifier should be able to cope ...
-
- (dbinders_s, dbinds, dfvs_s)
- = unzip3 [(dbinders, dbind, dfvs) | DictBindDetails dbinders dbind dfvs _ <- dbind_details]
-
- full_fvs = fvs `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
- ASSERT(null dbinds)
- returnSM ([Rec (pairsFromCoreBinds binds)], UsageDetails cis tycis [] fvs_outer c i)
-
- where
- spec_top_binds (first_bind:rest_binds)
- = 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)
-
- spec_top_binds []
- = returnSM ([], emptyUDs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[specExpr]{Specialising expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-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
- = 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)
- returnSM (expr, emptyUDs)
-
-specExpr (Con con args) null_args
- = ASSERT (null null_args)
- 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)
- 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)
- specArgs args $ \ args' ->
- -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) ->
- returnSM (Prim prim args', emptyUDs {-`unionUDs` prim_uds-} )
-
-{- ToDo: specPrimOp
-
-specPrimOp :: PrimOp
- -> [Type]
- -> SpecM (PrimOp,
- [Type],
- UsageDetails)
-
--- Checks that PrimOp can handle (possibly unboxed) tys passed
--- and/or chooses PrimOp specialised to any unboxed tys
--- Errors are dealt with by returning a PrimOp call instance
--- which will result in a cis_errs message
-
--- ToDo: Deal with checkSpecTyApp for Prim in CoreLint
--}
-
-
-specExpr (App fun arg) args
- = 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
- = 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 (Lam (ValBinder binder) body) []
- = specLambdaOrCaseBody [binder] body [] `thenSM` \ ([binder], body, uds) ->
- returnSM (Lam (ValBinder binder) body, uds)
-
-specExpr (Lam (TyBinder tyvar) body) (TyArg ty : args)
- = -- Type lambda with argument; argument already spec'd
- bindTyVar tyvar ty ( specExpr body args )
-
-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 False False [] [] [new_tyvar]
- in
- returnSM (Lam (TyBinder new_tyvar)
- (mkCoLetsNoUnboxed binds_here body),
- final_uds)
+addIdSpecialisations id spec_stuff
+ = (if not (null errs) then
+ pprTrace "Duplicate specialisations" (vcat (map ppr errs))
+ else \x -> x
)
-
-specExpr (Case scrutinee alts) args
- = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) ->
- specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) ->
- returnSM (Case scrutinee alts, scrut_uds `unionUDs` alts_uds)
- where
- scrutinee_type = coreExprType scrutinee
-
-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 (mkCoLetsUnboxedToCase binds body, all_uds)
-
-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 SCC cc expr
- in
- 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}
-
-%************************************************************************
-%* *
-\subsubsection{Specialising a lambda}
-%* *
-%************************************************************************
-
-\begin{code}
-specLambdaOrCaseBody :: [Id] -- The binders
- -> CoreExpr -- The body
- -> [CoreArg] -- Its args
- -> SpecM ([Id], -- New binders
- CoreExpr, -- New body
- UsageDetails)
-
-specLambdaOrCaseBody bound_ids body args
- = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) ->
- bindIds bound_ids clone_infos (
-
- specExpr body args `thenSM` \ (body, body_uds) ->
-
- let
- -- Dump any dictionary bindings (and call instances)
- -- from the scope which mention things bound here
- (binds_here, final_uds) = dumpUDs body_uds False False [] new_ids []
- in
- returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds)
- )
-
--- ToDo: Opportunity here to common-up dictionaries with same type,
--- thus avoiding recomputation.
-\end{code}
-
-A variable bound in a lambda or case is normally monomorphic so no
-specialised versions will be required. This is just as well since we
-do not know what code to specialise!
-
-Unfortunately this is not always the case. For example a class Foo
-with polymorphic methods gives rise to a dictionary with polymorphic
-components as follows:
-
-\begin{verbatim}
-class Foo a where
- op1 :: a -> b -> a
- op2 :: a -> c -> a
-
-instance Foo Int where
- op1 = op1Int
- op2 = op2Int
-
-... op1 1 3# ...
-
-==>
-
-d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int )
-d.Foo.Int = (op1_Int, op2_Int)
-
-op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b
-
-... op1 {Int Int#} d.Foo.Int 1 3# ...
-\end{verbatim}
-
-N.B. The type of the dictionary is not Hindley Milner!
-
-Now we must specialise op1 at {* Int#} which requires a version of
-meth1 at {Int#}. But since meth1 was extracted from a dictionary we do
-not have access to its code to create the specialised version.
-
-If we specialise on overloaded types as well we specialise op1 at
-{Int Int#} d.Foo.Int:
-
-op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {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.
-
-For now we PANIC if a polymorphic lambda/case bound variable is found
-in a call instance with an unboxed type. Other call instances, arising
-from overloaded type arguments, are discarded since the unspecialised
-version extracted from the method can be called as normal.
-
-ToDo: Implement and test second round of specialisation.
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising case alternatives}
-%* *
-%************************************************************************
-
-
-\begin{code}
-specAlts (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 (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, _) = --trace "Specialise.specAlts:getAppData..." $
- splitAlgTyConApp scrutinee_ty
-
- specAlgAlt ty_args (con,binders,rhs)
- = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) ->
- mkTyConInstance con ty_args `thenSM` \ con_uds ->
- returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds)
-
-specAlts (PrimAlts alts deflt) scrutinee_ty args
- = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) ->
- specDeflt deflt args `thenSM` \ (deflt, deflt_uds) ->
- 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 NoDefault args = returnSM (NoDefault, emptyUDs)
-specDeflt (BindDefault binder rhs) args
- = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) ->
- returnSM (BindDefault binder rhs, uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising an atom}
-%* *
-%************************************************************************
-
-\begin{code}
-partition_args :: [CoreArg] -> ([CoreArg], [CoreArg])
-partition_args args
- = span is_ty_arg args
+ addIdSpecialisation id new_spec_env
where
- is_ty_arg (TyArg _) = True
- is_ty_arg _ = False
-
-----------
-specId :: Id
- -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
- -> SpecM (CoreExpr, UsageDetails)
-specId v
- = lookupId v `thenSM` \ vlookup ->
- case vlookup of
-
- Lifted vl vu
- -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) ->
- returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds)
-
- NoLift vatom
- -> thing_inside vatom `thenSM` \ (expr, uds) ->
- returnSM (expr, singleFvUDs vatom `unionUDs` uds)
-
-specArg :: CoreArg
- -> (CoreArg -> SpecM (CoreExpr, UsageDetails))
- -> SpecM (CoreExpr, UsageDetails))
-
-specArg (TyArg ty) thing_inside
- = specTy ty `thenSM` \ new_ty ->
- thing_inside (TyArg new_ty)
-
-specArg (LitArg lit)
- = thing_inside (LitArg lit)
-
-specArg (VarArg v)
-
-
-specArgs [] thing_inside
- = thing_inside []
-
-specArgs (arg:args) thing_inside
- = specArg arg $ \ arg' ->
- specArgs args $ \ args' ->
- thing_inside (arg' : args')
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Specialising bindings}
-%* *
-%************************************************************************
-
-A classic case of when having a polymorphic recursive function would help!
-
-\begin{code}
-data BindsOrExpr = ItsABinds [CoreBinding]
- | ItsAnExpr CoreExpr
-\end{code}
-
-\begin{code}
-specBindAndScope
- :: Bool -- True <=> a top level group
- -> CoreBinding -- As yet unprocessed
- -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings
- -> SpecM ([CoreBinding], -- Processed
- BindsOrExpr, -- Combined result
- UsageDetails) -- Usage details of the whole lot
-
-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 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 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 False True new_binders [] bind `thenSM` \ (bind, rhs_uds) ->
-
- -- Process their scope
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
- -- Add the bindings to the current stuff
- final_uds = addDictBinds new_binders bind rhs_uds scope_uds
- in
- returnSM ([], thing, final_uds)
- )
- else
- -- Ho! A group of bindings
-
- fixSM (\ ~(_, _, _, rec_spec_infos) ->
-
- bindSpecIds binders clone_infos rec_spec_infos (
- -- It's ok to have new binders in scope in
- -- non-recursive decls too, cos name shadowing is gone by now
-
- -- Do the scope of the bindings
- scopeM `thenSM` \ (thing, scope_uds) ->
- let
- (call_insts, 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 top_lev False new_binders inst_cis bind
- `thenSM` \ (spec_bind, spec_uds) ->
-
- -- Create any necessary instances
- instBind top_lev new_binders bind equiv_ciss inst_cis
- `thenSM` \ (inst_binds, inst_uds, spec_infos) ->
-
- let
- -- 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
- returnSM (final_binds, thing, final_uds, spec_infos)
- )
- ) `thenSM` \ (binds, thing, final_uds, spec_infos) ->
- returnSM (binds, thing, final_uds)
- where
- binders = bindersOf bind
-
- is_rec (NonRec _ _) = False
- is_rec _ = True
-\end{code}
-
-\begin{code}
-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 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 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 :: Bool -> Bool -> [Id] -> [CallInstance]
- -> (Id,CoreExpr)
- -> SpecM ((Id,CoreExpr), UsageDetails)
-
-specOneBinding top_lev floating new_binders inst_cis (binder, rhs)
- = lookupId binder `thenSM` \ blookup ->
- specExpr rhs [] `thenSM` \ (rhs, rhs_uds) ->
- let
- specid_maybe_maybe = isSpecPragmaId_maybe binder
- is_specid = maybeToBool specid_maybe_maybe
- Just specinfo_maybe = specid_maybe_maybe
- specid_with_info = maybeToBool specinfo_maybe
- Just spec_info = specinfo_maybe
-
- -- 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
- let
- (SpecInfo spec_tys _ spec_id) = spec_info
- Just (orig_id, _) = isSpecId_maybe spec_id
- in
- ASSERT(toplevelishId orig_id) -- must not be cloned!
- explicitCI orig_id spec_tys spec_info
- else
- emptyUDs
-
- -- 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 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
- -- the _Lift data type in the usage details
- mkTyConInstance liftDataCon [idType unlift_binder]
- `thenSM` \ lift_uds ->
- returnSM ((lift_binder,
- mkCoLetsNoUnboxed local_dict_binds (liftExpr unlift_binder rhs)),
- final_uds `unionUDs` pragma_uds `unionUDs` lift_uds)
-
- NoLift (VarArg binder)
- -> returnSM ((binder, mkCoLetsNoUnboxed local_dict_binds rhs),
- final_uds `unionUDs` pragma_uds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{@instBind@}
-%* *
-%************************************************************************
-
-\begin{code}
-instBind top_lev new_ids@(first_binder:other_binders) bind equiv_ciss inst_cis
- | null equiv_ciss
- = returnSM ([], emptyUDs, [])
-
- | all same_overloading other_binders
- = -- 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,
- unionUDList inst_uds_s,
- spec_infos
- )
-
- | otherwise -- Incompatible overloadings; see below by same_overloading
- = (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)
- ) (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
- (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder
- tyvar_tmpl_tys = mkTyVarTys tyvar_tmpls
-
- no_of_tyvars = length tyvar_tmpls
- no_of_dicts = length class_tyvar_pairs
-
- do_this_class equiv_cis
- = mkOneInst do_cis explicit_cis no_of_dicts top_lev inst_cis new_ids bind
- where
- (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
- -- Almost always this is the case, because a recursive group is abstracted
- -- all together. But, it can happen that it ain't the case, because of
- -- code generated from instance decls:
- --
- -- rec
- -- dfun.Foo.Int :: (forall a. a -> Int, Int)
- -- dfun.Foo.Int = (const.op1.Int, const.op2.Int)
- --
- -- const.op1.Int :: forall a. a -> Int
- -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int
- --
- -- const.op2.Int :: Int
- -- const.op2.Int = 3
- --
- -- Note that the first two defns have different polymorphism, but they are
- -- mutually recursive!
-
- same_overloading :: Id -> Bool
- same_overloading id
- = no_of_tyvars == length this_id_tyvars
- -- Same no of tyvars
- && no_of_dicts == length this_id_class_tyvar_pairs
- -- Same no of vdicts
- && and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs)
- && 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)
- = clas1 == clas2 &&
- tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2
-\end{code}
-
-OK, so we have:
- - a call instance eg f [t1,t2,t3] [d1,d2]
- - the rhs of the function eg orig_rhs
- - a constraint vector, saying which of eg [T,F,T]
- the functions type args are constrained
- (ie overloaded)
-
-We return a new definition
-
- $f1 = /\a -> orig_rhs t1 a t3 d1 d2
-
-The SpecInfo for f will be:
-
- SpecInfo [t1, a, t3] (\d1 d2 -> $f1 a)
-
-Based on this SpecInfo, a call instance of f
-
- ...(f t1 t2 t3)...
-
-should get replaced by
-
- ...(\d1 d2 -> $f1 t2)...
-
-(But that is the business of the simplifier.)
-
-\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
- -> CoreBinding -- Unprocessed
- -> SpecM (Maybe CoreBinding, -- Instantiated version of input
- UsageDetails,
- [Maybe SpecInfo] -- One for each id in the original binding
- )
-
-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 unspecialised args
- arg_tys :: [Type]
- (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys
-
- 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 = 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
- SpecInfo _ _ explicit_id = explicit_spec_info
-
- trace_nospec :: String -> Id -> a -> a
- trace_nospec str spec_id
- = pprTrace str
- (hsep [ppr new_id, hsep (map pp_ty arg_tys),
- ptext SLIT("==>"), ppr spec_id])
- in
- (if opt_SpecialiseTrace then
- pprTrace "Specialising:"
- (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)
+ (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff
+
+ add (tys, template) (spec_env, errs)
+ = case addToSpecEnv spec_env tys (occurAnalyseGlobalExpr template) of
+ Succeeded spec_env' -> (spec_env', errs)
+ Failed err -> (spec_env, err:errs)
+
+----------------------------------------
+type SpecM a = UniqSM a
+
+thenSM = thenUs
+returnSM = returnUs
+getUniqSM = getUnique
+mapSM = mapUs
+initSM = initUs
+
+mapAndCombineSM f [] = returnSM ([], emptyUDs)
+mapAndCombineSM f (x:xs) = f x `thenSM` \ (y, uds1) ->
+ mapAndCombineSM f xs `thenSM` \ (ys, uds2) ->
+ returnSM (y:ys, uds1 `plusUDs` uds2)
+
+newIdSM old_id new_ty
+ = getUnique `thenSM` \ uniq ->
+ returnSM (mkUserLocal (getOccName old_id)
+ uniq
+ new_ty
+ (getSrcLoc old_id)
)
- where
- 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)
-
\end{code}
-%************************************************************************
-%* *
-\subsection[Misc]{Miscellaneous junk}
-%* *
-%************************************************************************
-
-\begin{code}
-mkCallInstance :: Id
- -> Id
- -> [CoreArg]
- -> SpecM UsageDetails
-
-mkCallInstance id new_id args
- | 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
-
- | otherwise
- = returnSM (singleCI new_id spec_tys dicts)
-
- 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) [] = Nothing
-
- 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
- = case (take_dict_args class_tyvar_pairs args) of
- Nothing -> Nothing
- Just (dicts, others) -> Just (dict:dicts, others)
-
- take_dict_args (_:class_tyvar_pairs) args = Nothing
-
- take_dict_args [] args = Just ([], args)
-\end{code}
-
-
-\begin{code}
-mkTyConInstance :: Id
- -> [Type]
- -> SpecM UsageDetails
-mkTyConInstance con tys
- = recordTyConInst con tys `thenSM` \ record_inst ->
- case record_inst of
- Nothing -- No TyCon instance
- -> -- pprTrace "NoTyConInst:"
- -- (hsep [ppr tycon, ptext SLIT("at"),
- -- ppr con, hsep (map (ppr) tys)])
- (returnSM (singleConUDs con))
-
- Just spec_tys -- Record TyCon instance
- -> -- pprTrace "TyConInst:"
- -- (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
-\end{code}
-
-\begin{code}
-recordTyConInst :: Id
- -> [Type]
- -> SpecM (Maybe [Maybe Type])
-
-recordTyConInst con tys
- = let
- spec_tys = specialiseConstrTys tys
-
- do_tycon_spec = maybeToBool (firstJust spec_tys)
-
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation con)
- tys)
- in
- -- pprTrace "ConSpecExists?: "
- -- (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)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[monad-Specialise]{Monad used in specialisation}
-%* *
-%************************************************************************
-
-Monad has:
-
- inherited: control flags and
- recordInst functions with flags cached
-
- environment mapping tyvars to types
- environment mapping Ids to Atoms
-
- threaded in and out: unique supply
-
-\begin{code}
-type TypeEnv = TyVarEnv Type
-
-type SpecM result
- = TypeEnv
- -> SpecIdEnv
- -> UniqSupply
- -> result
-
-initSM m uniqs = m emptyTyVarEnv nullIdEnv uniqs
-
-returnSM :: a -> SpecM a
-thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b
-fixSM :: (a -> SpecM a) -> SpecM a
-
-thenSM m k tvenv idenv us
- = case splitUniqSupply us of { (s1, s2) ->
- case (m tvenv idenv s1) of { r ->
- k r tvenv idenv s2 }}
-
-returnSM r tvenv idenv us = r
-
-fixSM k tvenv idenv us
- = r
- where
- 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 Type] -- Specialise to these types
- -> Int -- No of dicts to specialise
- -> SpecM [Id]
-
-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 = 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
- = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us]
-\end{code}
-
-@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 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 tvenv idenv us
- = let
- uniqs = getUniques (length old_ids) us
- in
- unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs)
- where
- clone_it old_id uniq
- = (new_id, NoLift (VarArg new_id))
- where
- new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq)
-
-cloneLetBinders :: Bool -- Top level ?
- -> Bool -- Recursice
- -> [Id] -- Old binders
- -> SpecM ([Id], [CloneInfo]) -- New ones
-
-cloneLetBinders top_lev is_rec old_ids tvenv idenv us
- = let
- 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)
- | top_lev
- = (old_id,
- 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
- -- on such things
- -- (b) we don't have to be paranoid about name capture
- -- (c) the thing is polymorphic so no need to subst
-
- | otherwise
- = if (is_rec && isUnboxedType new_ty && not (isUnboxedType old_ty))
- then (lifted_id,
- Lifted lifted_id unlifted_id) : clone_rest
- else (new_id,
- NoLift (VarArg new_id)) : clone_rest
-
- where
- clone_rest = clone_them olds uniqs
-
- new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1)
- 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 tvenv idenv us
- = let
- uniq = getUnique us
- in
- cloneTyVar old_tyvar uniq -- new_tyvar
-
-bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing
-
-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 tvenv idenv us
- = specm tvenv (growIdEnvList idenv (zip olds news)) us
-
-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 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) :
- 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)))
- add_spec_info lifted
- = lifted -- no specialised instances for unboxed lifted values
-
- spec_infos_this_id = catMaybes (map head spec_infos)
- spec_infos_rest = map tail spec_infos
-
-
-bindTyVar :: TyVar -> Type -> SpecM thing -> SpecM thing
-
-bindTyVar tyvar ty specm tvenv idenv us
- = specm (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us
-\end{code}
-
-\begin{code}
-lookupId :: Id -> SpecM CloneInfo
-
-lookupId id tvenv idenv us
- = case lookupIdEnv idenv id of
- Nothing -> NoLift (VarArg id)
- Just info -> info
-\end{code}
-
-\begin{code}
-specTy :: Type -> SpecM Type -- Apply the current type envt to the type
-
-specTy ty tvenv idenv us
- = instantiateTy tvenv ty
-\end{code}
-
-\begin{code}
-liftId :: Id -> SpecM (Id, Id)
-liftId id tvenv idenv us
- = let
- uniq = getUnique us
- in
- mkLiftedId id uniq
-\end{code}
-
-In other monads these @mapSM@ things are usually called @listM@.
-I think @mapSM@ is a much better name. The `2' and `3' variants are
-when you want to return two or three results, and get at them
-separately. It saves you having to do an (unzip stuff) right after.
-
-\begin{code}
-mapSM :: (a -> SpecM b) -> [a] -> SpecM [b]
-mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2])
-mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3])
-mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4])
-
-mapSM f [] = returnSM []
-mapSM f (x:xs) = f x `thenSM` \ r ->
- mapSM f xs `thenSM` \ rs ->
- returnSM (r:rs)
-
-mapAndUnzipSM f [] = returnSM ([],[])
-mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) ->
- mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) ->
- returnSM ((r1:rs1),(r2:rs2))
-
-mapAndUnzip3SM f [] = returnSM ([],[],[])
-mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) ->
- mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) ->
- returnSM ((r1:rs1),(r2:rs2),(r3:rs3))
-
-mapAndUnzip4SM f [] = returnSM ([],[],[],[])
-mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) ->
- mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) ->
- returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4))
--}
-\end{code}
-
-
-
-===================== 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}
projects / ghc-hetmet.git / commitdiff