From: sof Date: Mon, 19 May 1997 06:37:48 +0000 (+0000) Subject: [project @ 1997-05-19 06:37:47 by sof] X-Git-Tag: Approximately_1000_patches_recorded~582 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=df7720960f37a22b769727dc539ba48cf1f144b6;p=ghc-hetmet.git [project @ 1997-05-19 06:37:47 by sof] ghc-2-03-p1 merged onto main trunk --- diff --git a/ghc/compiler/specialise/SpecMisc.lhs b/ghc/compiler/specialise/SpecMisc.lhs deleted file mode 100644 index 09b727e..0000000 --- a/ghc/compiler/specialise/SpecMisc.lhs +++ /dev/null @@ -1,693 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 -% -\section[SpecMisc]{Miscellaneous stuff for the Specialiser} - -\begin{code} -#include "HsVersions.h" - -module SpecMisc where - -import PlainCore -import SpecTyFuns -import SpecMonad - -IMPORT_Trace -import Outputable -- ToDo: these may be removable... -import Pretty - -import AbsUniType -import Bag -import CmdLineOpts ( GlobalSwitch(..) ) -import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) -import IdEnv -import Id -import IdInfo -import InstEnv ( lookupClassInstAtSimpleType ) -import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) ) -import TyVarEnv -- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) ) -import Util -import UniqSet -import SplitUniq - -infixr 9 `thenSM` -\end{code} - -%************************************************************************ -%* * -\subsubsection[CallInstances]{@CallInstances@ data type} -%* * -%************************************************************************ - -\begin{code} -type FreeVarsSet = UniqSet Id -type FreeTyVarsSet = UniqSet TyVar - -data CallInstance - = CallInstance - Id -- This Id; *new* ie *cloned* id - [Maybe UniType] -- Specialised at these types (*new*, cloned) - -- Nothing => no specialisation on this type arg - -- is required (flag dependent). - [PlainCoreArg] -- And these dictionaries; all ValArgs - FreeVarsSet -- Free vars of the dict-args in terms of *new* ids - (Maybe SpecInfo) -- For specialisation with explicit SpecId -\end{code} - -\begin{code} -pprCI :: CallInstance -> Pretty -pprCI (CallInstance id spec_tys dicts _ maybe_specinfo) - = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id]) - 4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]), - case maybe_specinfo of - Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts]) - Just (SpecInfo _ _ spec_id) - -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id] - ]) - -isUnboxedCI :: CallInstance -> Bool -isUnboxedCI (CallInstance _ spec_tys _ _ _) - = any isUnboxedDataType (catMaybes spec_tys) - -isExplicitCI :: CallInstance -> Bool -isExplicitCI (CallInstance _ _ _ _ (Just _)) - = True -isExplicitCI (CallInstance _ _ _ _ Nothing) - = False -\end{code} - -Comparisons are based on the {\em types}, ignoring the dictionary args: - -\begin{code} - -cmpCI :: CallInstance -> CallInstance -> TAG_ -cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) - = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } - -cmpCI_tys :: CallInstance -> CallInstance -> TAG_ -cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _) - = cmpUniTypeMaybeList tys1 tys2 - -eqCI_tys :: CallInstance -> CallInstance -> Bool -eqCI_tys c1 c2 - = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False } - -isCIofTheseIds :: [Id] -> CallInstance -> Bool -isCIofTheseIds ids (CallInstance ci_id _ _ _ _) - = any (eqId ci_id) ids - -singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails -singleCI id tys dicts - = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing)) - emptyBag [] emptyUniqSet 0 0 - where - fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts]) - -explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails -explicitCI id tys specinfo - = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0 - where - call_inst = CallInstance id tys dicts fv_set (Just specinfo) - dicts = panic "Specialise:explicitCI:dicts" - fv_set = singletonUniqSet 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 (getIdUniType 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:" - -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"]) - -- 4 (ppAboves (map pprCI cis_here_list))) - (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs 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* CoRec. - -- We leave it to the simplifier will sort it all out ... - -dumpCIs cis top_lev floating inst_cis bound_ids full_ids - = (if not (isEmptyBag cis_of_bound_id) && - not (isEmptyBag cis_of_bound_id_without_inst_cis) - then - pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++ - " (may be a non-HM recursive call)\n") - (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"]) - 4 (ppAboves [ppStr "Dumping CIs:", - ppAboves (map pprCI (bagToList cis_of_bound_id)), - ppStr "Instantiating CIs:", - ppAboves (map pprCI inst_cis)])) - else id) ( - if top_lev || floating then - cis_not_bound_id - else - (if not (isEmptyBag cis_dump_unboxed) - then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n" - (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"]) - 4 (ppAboves (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 _) - = or [i `elementOfUniqSet` fv_set | i <- 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 UniType] -- Applied to these specialising types - -cmpTyConI :: TyConInstance -> TyConInstance -> TAG_ -cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) - = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } - -cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_ -cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) - = cmpUniTypeMaybeList tys1 tys2 - -singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails -singleTyConI ty_con spec_tys - = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0 - -isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool -isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con - -isLocalSpecTyConI :: Bool -> TyConInstance -> Bool -isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con - -getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails) -getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs 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. - -A @DictBindDetails@ contains bindings for dictionaries *only*. - -\begin{code} -data DictBindDetails - = DictBindDetails - [Id] -- Main binders, originally visible in scope of binding (cloned) - PlainCoreBinding -- Fully processed - FreeVarsSet -- Free in binding group (cloned) - FreeTyVarsSet -- Free in binding group -\end{code} - -\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 [] emptyUniqSet 0 0 - -unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2) - = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2) - (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2) - -- The append here is really redundant, since the bindings don't - -- scope over each other. ToDo. - -unionUDList = foldr unionUDs emptyUDs - -singleFvUDs (CoVarAtom v) | not (isImportedId v) - = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0 -singleFvUDs other - = emptyUDs - -singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet 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 - -> ([PlainCoreBinding], -- 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* CoRec. - -- 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 - || or [i `elementOfUniqSet` db_fvs | i <- bound_ids] - || or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars] - = let -- Ha! Dump it! - (dbinds_here, dbs_outer, full_bound_ids, full_fvs) - = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` 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 - -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids - UsageDetails) -- The above bindings removed, and - -- any call-instances which mention the ids dumped too - -dumpUDs (UsageDetails cis tycon_cis dbs fvs 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 `minusUniqSet` (mkUniqSet full_bound_ids) - in - (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i) -\end{code} - -\begin{code} -addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails -- Dict binding and RHS usage - -> 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 = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders)) -\end{code} - -%************************************************************************ -%* * -\subsection[Misc]{Miscellaneous junk} -%* * -%************************************************************************ - -\begin{code} -mkCallInstance :: Id - -> Id - -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)] - -> 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) - = 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 - = getSwitchCheckerSM `thenSM` \ sw_chkr -> - let - spec_overloading = sw_chkr SpecialiseOverloaded - spec_unboxed = sw_chkr SpecialiseUnboxed - spec_all = sw_chkr SpecialiseAll - - (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, ppr 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 ((TypeArg ty,_,_):args) - = case take_type_args tyvars class_tyvar_pairs args of - Nothing -> Nothing - Just (tys, dicts, others) -> Just (ty:tys, dicts, others) -take_type_args (_:tyvars) class_tyvar_pairs [] - = Nothing -take_type_args [] class_tyvar_pairs args - = case take_dict_args class_tyvar_pairs args of - Nothing -> Nothing - Just (dicts, others) -> Just ([], dicts, others) - -take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args) - = case take_dict_args class_tyvar_pairs args of - Nothing -> Nothing - Just (dicts, others) -> Just (dict:dicts, others) -take_dict_args (_:class_tyvar_pairs) [] - = Nothing -take_dict_args [] args - = Just ([], args) -\end{code} - -\begin{code} -mkCall :: Id - -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)] - -> SpecM (Bool, PlainCoreExpr) - -mkCall new_id args - | maybeToBool (isSuperDictSelId_maybe new_id) - && any isUnboxedDataType ty_args - -- No specialisations for super-dict selectors - -- Specialise unboxed calls to SuperDictSelIds by extracting - -- the super class dictionary directly form the super class - -- NB: This should be dead code since all uses of this dictionary should - -- have been specialised. We only do this to keep 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, CoVar 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 isUnboxedDataType (getIdUniType 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 - (CoVar unlift_spec_id)) - else - pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n" - (ppCat [ppr PprDebug new_id, - ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args), - ppStr "==>", - ppr PprDebug spec_id]) - else - let - (vals_left, _, unlifts_left) = unzip3 args_left - applied_tys = mkCoTyApps (CoVar spec_id) tys_left - applied_vals = applyToArgs applied_tys vals_left - in - returnSM (True, applyBindUnlifts unlifts_left applied_vals) - ) - where - (tys_and_vals, _, unlifts) = unzip3 args - unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar 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 ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args - get args = ([], args) - - - -- toss_dicts chucks away dict args, checking that they ain't types! - toss_dicts 0 args = args - toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args - -\end{code} - -\begin{code} -checkUnspecOK :: Id -> [UniType] -> a -> a -checkUnspecOK check_id tys - = if isLocallyDefined check_id && any isUnboxedDataType tys - then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" - (ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendUniType PprDebug) tys)]) - else id - -checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a -checkSpecOK check_id tys spec_id tys_left - = if any isUnboxedDataType tys_left - then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" - (ppAboves [ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendUniType PprDebug) tys)], - ppCat [ppr PprDebug spec_id, - ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]]) - else id -\end{code} - -\begin{code} -mkTyConInstance :: Id - -> [UniType] - -> SpecM UsageDetails -mkTyConInstance con tys - = recordTyConInst con tys `thenSM` \ record_inst -> - case record_inst of - Nothing -- No TyCon instance - -> -- pprTrace "NoTyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", - -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)]) - (returnSM (singleConUDs con)) - - Just spec_tys -- Record TyCon instance - -> -- pprTrace "TyConInst:" - -- (ppCat [ppr PprDebug tycon, ppStr "at", - -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys), - -- ppBesides [ppStr "(", - -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys], - -- ppStr ")"]]) - (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con)) - where - tycon = getDataConTyCon con -\end{code} - -\begin{code} -recordTyConInst :: Id - -> [UniType] - -> SpecM (Maybe [Maybe UniType]) - -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?: " - -- (ppAboves [ppStr (if spec_exists then "True" else "False"), - -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)]) - (if (not spec_exists && do_tycon_spec) - then returnSM (Just spec_tys) - else returnSM Nothing) -\end{code} - diff --git a/ghc/compiler/specialise/SpecMonad.lhs b/ghc/compiler/specialise/SpecMonad.lhs deleted file mode 100644 index 24e8d6a..0000000 --- a/ghc/compiler/specialise/SpecMonad.lhs +++ /dev/null @@ -1,320 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 -% -\section[SpecMonad]{Monad for the Specialiser} - -\begin{code} -#include "HsVersions.h" - -module SpecMonad where - -import PlainCore -import SpecTyFuns - -IMPORT_Trace -import Outputable -- ToDo: these may be removable... -import Pretty - -import AbsUniType -import Bag -import CmdLineOpts ( GlobalSwitch(..) ) -import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) -import IdEnv -import Id -import IdInfo -import InstEnv ( lookupClassInstAtSimpleType ) -import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) ) -import TyVarEnv -- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) ) -import Util -import UniqSet -import SplitUniq - -infixr 9 `thenSM` -\end{code} - -%************************************************************************ -%* * -\subsection[cloning-binders]{The Specialising IdEnv and CloneInfo} -%* * -%************************************************************************ - -@SpecIdEnv@ maps old Ids to their new "clone". There are three cases: - -1) (NoLift CoLitAtom l) : an Id which is bound to a literal - -2) (NoLift CoLitAtom l) : an Id bound to a "new" Id - The new Id is a possibly-type-specialised clone of the original - -3) Lifted lifted_id unlifted_id : - - This indicates that the original Id has been specialised to an - unboxed value which must be lifted (see "Unboxed bindings" above) - @unlifted_id@ is the unboxed clone of the original Id - @lifted_id@ is a *lifted* version of the original Id - - When you lookup Ids which are Lifted, you have to insert a case - expression to un-lift the value (done with @bindUnlift@) - - You also have to insert a case to lift the value in the binding - (done with @liftExpr@) - - -\begin{code} -type SpecIdEnv = IdEnv CloneInfo - -data CloneInfo - = NoLift PlainCoreAtom -- refers to cloned id or literal - - | Lifted Id -- lifted, cloned id - Id -- unlifted, cloned id - -\end{code} - -%************************************************************************ -%* * -\subsection[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 SpecM result - = (GlobalSwitch -> Bool) - -> TypeEnv - -> SpecIdEnv - -> SplitUniqSupply - -> result - -initSM m sw_chker uniqs - = m sw_chker nullTyVarEnv nullIdEnv uniqs - -returnSM :: a -> SpecM a -thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b -fixSM :: (a -> SpecM a) -> SpecM a - -thenSM m k sw_chkr tvenv idenv us - = case splitUniqSupply us of { (s1, s2) -> - case (m sw_chkr tvenv idenv s1) of { r -> - k r sw_chkr tvenv idenv s2 }} - -returnSM r sw_chkr tvenv idenv us = r - -fixSM k sw_chkr tvenv idenv us - = r - where - r = k r sw_chkr tvenv idenv us -- Recursive in r! -\end{code} - - -\begin{code} -getSwitchCheckerSM sw_chkr tvenv idenv us = sw_chkr -\end{code} - -The only interesting bit is figuring out the type of the SpecId! - -\begin{code} -newSpecIds :: [Id] -- The id of which to make a specialised version - -> [Maybe UniType] -- Specialise to these types - -> Int -- No of dicts to specialise - -> SpecM [Id] - -newSpecIds new_ids maybe_tys dicts_to_ignore sw_chkr tvenv idenv us - = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id) - | (id,uniq) <- new_ids `zip` uniqs ] - where - uniqs = getSUniques (length new_ids) us - spec_id_ty id = specialiseTy (getIdUniType id) maybe_tys dicts_to_ignore - -newTyVars :: Int -> SpecM [TyVar] -newTyVars n sw_chkr tvenv idenv us - = map mkPolySysTyVar uniqs - where - uniqs = getSUniques n us -\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 sw_chkr tvenv idenv us - = let - uniqs = getSUniques (length old_ids) us - in - unzip (zipWith clone_it old_ids uniqs) - where - clone_it old_id uniq - = (new_id, NoLift (CoVarAtom new_id)) - where - new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq) - -cloneLetBinders :: Bool -- Top level ? - -> Bool -- Recursice - -> [Id] -- Old binders - -> SpecM ([Id], [CloneInfo]) -- New ones - -cloneLetBinders top_lev is_rec old_ids sw_chkr tvenv idenv us - = let - uniqs = getSUniques (2 * length old_ids) us - in - unzip (clone_them old_ids uniqs) - where - clone_them [] [] = [] - - clone_them (old_id:olds) (u1:u2:uniqs) - | top_lev - = (old_id, - NoLift (CoVarAtom 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 (see TopLevId in Id.lhs) - -- (b) we don't have to be paranoid about name capture - -- (c) the thing is polymorphic so no need to subst - - | otherwise - = if (is_rec && isUnboxedDataType new_ty && not (isUnboxedDataType old_ty)) - then (lifted_id, - Lifted lifted_id unlifted_id) : clone_rest - else (new_id, - NoLift (CoVarAtom new_id)) : clone_rest - - where - clone_rest = clone_them olds uniqs - - new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1) - new_ty = getIdUniType new_id - old_ty = getIdUniType old_id - - (lifted_id, unlifted_id) = mkLiftedId new_id u2 - - -cloneTyVarSM :: TyVar -> SpecM TyVar - -cloneTyVarSM old_tyvar sw_chkr tvenv idenv us - = let - uniq = getSUnique us - in - cloneTyVar old_tyvar uniq -- new_tyvar - -bindId :: Id -> CloneInfo -> SpecM thing -> SpecM thing - -bindId id val specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (addOneToIdEnv idenv id val) us - -bindIds :: [Id] -> [CloneInfo] -> SpecM thing -> SpecM thing - -bindIds olds news specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (growIdEnvList idenv (zip olds news)) us - -bindSpecIds :: [Id] -- Old - -> [(CloneInfo)] -- New - -> [[Maybe SpecInfo]] -- Corresponding specialisations - -- Each sub-list corresponds to a different type, - -- and contains one Maybe spec_info for each id - -> SpecM thing - -> SpecM thing - -bindSpecIds olds clones spec_infos specm sw_chkr tvenv idenv us - = specm sw_chkr tvenv (growIdEnvList idenv old_to_clone) us - where - old_to_clone = mk_old_to_clone olds clones spec_infos - - -- The important thing here is that we are *lazy* in spec_infos - mk_old_to_clone [] [] _ = [] - mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos - = (old, add_spec_info clone) : - mk_old_to_clone rest_olds rest_clones spec_infos_rest - where - add_spec_info (NoLift (CoVarAtom new)) - = NoLift (CoVarAtom (new `addIdSpecialisation` - (mkSpecEnv spec_infos_this_id))) - add_spec_info lifted - = lifted -- no specialised instances for unboxed lifted values - - spec_infos_this_id = catMaybes (map head spec_infos) - spec_infos_rest = map tail spec_infos - - -bindTyVar :: TyVar -> UniType -> SpecM thing -> SpecM thing - -bindTyVar tyvar ty specm sw_chkr tvenv idenv us - = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us -\end{code} - -\begin{code} -lookupId :: Id -> SpecM CloneInfo - -lookupId id sw_chkr tvenv idenv us - = case lookupIdEnv idenv id of - Nothing -> NoLift (CoVarAtom id) - Just info -> info -\end{code} - -\begin{code} -specTy :: UniType -> SpecM UniType -- Apply the current type envt to the type - -specTy ty sw_chkr tvenv idenv us - = applyTypeEnvToTy tvenv ty -\end{code} - -\begin{code} -liftId :: Id -> SpecM (Id, Id) -liftId id sw_chkr tvenv idenv us - = let - uniq = getSUnique us - in - mkLiftedId id uniq -\end{code} - -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}