From b8875f2f7f596482228645b9751f8f9c592a84c5 Mon Sep 17 00:00:00 2001 From: simonm Date: Tue, 26 Mar 1996 17:10:45 +0000 Subject: [PATCH] [project @ 1996-03-26 17:10:41 by simonm] Split Specialise.lhs into SpecMonad.lhs SpecMisc.lhs Specialise.lhs To reduce heap-size requirements for compiling this module. --- ghc/compiler/specialise/SpecMisc.lhs | 693 +++++++++++++++++++++++++++++++++ ghc/compiler/specialise/SpecMonad.lhs | 320 +++++++++++++++ 2 files changed, 1013 insertions(+) create mode 100644 ghc/compiler/specialise/SpecMisc.lhs create mode 100644 ghc/compiler/specialise/SpecMonad.lhs diff --git a/ghc/compiler/specialise/SpecMisc.lhs b/ghc/compiler/specialise/SpecMisc.lhs new file mode 100644 index 0000000..09b727e --- /dev/null +++ b/ghc/compiler/specialise/SpecMisc.lhs @@ -0,0 +1,693 @@ +% +% (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 new file mode 100644 index 0000000..24e8d6a --- /dev/null +++ b/ghc/compiler/specialise/SpecMonad.lhs @@ -0,0 +1,320 @@ +% +% (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} -- 1.7.10.4