X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecEnv.lhs;h=544002f918519bdf0f3aba138c56ed604786a869;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=af66c9b6ed3af9c7596b54c33f7475cb93670ebe;hpb=e1fc52f6868619bbeafaced910c50a304db5e0f9;p=ghc-hetmet.git diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index af66c9b..544002f 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -1,20 +1,24 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[SpecEnv]{Specialisation info about an @Id@} \begin{code} module SpecEnv ( SpecEnv, - emptySpecEnv, isEmptySpecEnv, specEnvValues, + emptySpecEnv, isEmptySpecEnv, + specEnvValues, specEnvToList, specEnvFromList, addToSpecEnv, lookupSpecEnv, substSpecEnv ) where #include "HsVersions.h" -import Type ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars ) -import TyVar ( TyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList ) -import Unify ( Subst, unifyTyListsX ) +import Var ( TyVar ) +import VarEnv +import VarSet +import Type ( Type, GenType, fullSubstTy, substTyVar ) +import Unify ( unifyTyListsX, matchTys ) +import Outputable import Maybes import Util ( assertPanic ) \end{code} @@ -28,17 +32,25 @@ import Util ( assertPanic ) %************************************************************************ \begin{code} -type TemplateType = GenType Bool - -- The Bool is True for template type variables; - -- that is, ones that can be bound - data SpecEnv value = EmptySE - | SpecEnv [([TemplateType], value)] + | SpecEnv [([TyVar], -- Really a set, but invariably small, + -- so kept as a list + [Type], + value)] specEnvValues :: SpecEnv value -> [value] specEnvValues EmptySE = [] -specEnvValues (SpecEnv alist) = map snd alist +specEnvValues (SpecEnv alist) = [val | (_,_,val) <- alist] + +specEnvToList :: SpecEnv value -> [([TyVar], [Type], value)] +specEnvToList EmptySE = [] +specEnvToList (SpecEnv alist) = alist + +specEnvFromList :: [([TyVar], [Type], value)] -> SpecEnv value + -- Assumes the list is in appropriate order +specEnvFromList [] = EmptySE +specEnvFromList alist = SpecEnv alist \end{code} In some SpecEnvs overlap is prohibited; that is, no pair of templates unify. @@ -73,17 +85,18 @@ The thing we are looking up can have an arbitrary "flexi" part. \begin{code} -lookupSpecEnv :: SpecEnv value -- The envt +lookupSpecEnv :: SDoc -- For error report + -> SpecEnv value -- The envt -> [GenType flexi] -- Key -> Maybe (TyVarEnv (GenType flexi), value) -lookupSpecEnv EmptySE key = Nothing -lookupSpecEnv (SpecEnv alist) key +lookupSpecEnv doc EmptySE key = Nothing +lookupSpecEnv doc (SpecEnv alist) key = find alist where find [] = Nothing - find ((tpl, val) : rest) - = case matchTys tpl key of + find ((tpl_tyvars, tpl, val) : rest) + = case matchTys tpl_tyvars tpl key of Nothing -> find rest Just (subst, leftovers) -> ASSERT( null leftovers ) Just (subst, val) @@ -100,52 +113,61 @@ True => overlap is permitted, but only if one template matches the other; addToSpecEnv :: Bool -- True <=> overlap permitted -> SpecEnv value -- Envt -> [TyVar] -> [Type] -> value -- New item - -> MaybeErr (SpecEnv value) -- Success... - ([TemplateType], value) -- Failure: Offending overlap + -> MaybeErr (SpecEnv value) -- Success... + ([Type], value) -- Failure: Offending overlap -addToSpecEnv overlap_ok spec_env tvs tys value +addToSpecEnv overlap_ok spec_env ins_tvs ins_tys value = case spec_env of EmptySE -> returnMaB (SpecEnv [ins_item]) SpecEnv alist -> insert alist `thenMaB` \ alist' -> returnMaB (SpecEnv alist') where - ins_item = (ins_tys, value) - ins_tys = map (applyToTyVars mk_tv) tys - - mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs)) - -- tvs identifies the template variables + ins_item = (ins_tvs, ins_tys, value) insert [] = returnMaB [ins_item] - insert alist@(cur_item@(cur_tys, _) : rest) - | unifiable && not overlap_ok = failMaB cur_item - | unifiable && ins_item_more_specific = returnMaB (ins_item : alist) - | unifiable && not cur_item_more_specific = failMaB cur_item - | otherwise = -- Less specific, or not unifiable... carry on - insert rest `thenMaB` \ rest' -> - returnMaB (cur_item : rest') + insert alist@(cur_item@(tpl_tvs, tpl_tys, val) : rest) + + -- FAIL if: + -- (a) they are the same, or + -- (b) they unify, and any sort of overlap is prohibited, + -- (c) they unify but neither is more specific than t'other + | identical + || (unifiable && not overlap_ok) + || (unifiable && not (ins_item_more_specific || cur_item_more_specific)) + = failMaB (tpl_tys, val) + + -- New item is an instance of current item, so drop it here + | ins_item_more_specific = returnMaB (ins_item : alist) + + -- Otherwise carry on + | otherwise = insert rest `thenMaB` \ rest' -> + returnMaB (cur_item : rest') where - unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys) - ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys) - cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys) + unifiable = maybeToBool (unifyTyListsX (ins_tvs ++ tpl_tvs) tpl_tys ins_tys) + ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys) + cur_item_more_specific = maybeToBool (matchTys ins_tvs ins_tys tpl_tys) + identical = ins_item_more_specific && cur_item_more_specific \end{code} Finally, during simplification we must apply the current substitution to the SpecEnv. \begin{code} -substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val -substSpecEnv ty_env val_fn EmptySE = EmptySE -substSpecEnv ty_env val_fn (SpecEnv alist) - = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist] +substSpecEnv :: TyVarEnv Type -> IdOrTyVarSet + -> (TyVarEnv Type -> IdOrTyVarSet -> val -> val) + -> SpecEnv val -> SpecEnv val +substSpecEnv ty_subst in_scope val_fn EmptySE = EmptySE +substSpecEnv ty_subst in_scope val_fn (SpecEnv alist) + = SpecEnv (map subst alist) where - ty_fn = applyToTyVars tyvar_fn - - -- Apply the substitution; but if we ever substitute - -- we need to convert a Type to a TemplateType - tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv - | otherwise = case lookupTyVarEnv ty_env tv of - Nothing -> mkTyVarTy tv - Just ty -> applyToTyVars set_non_tpl ty - - set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False) + subst (tpl_tyvars, tpl_tys, val) + = (tpl_tyvars', + map (fullSubstTy ty_subst' in_scope') tpl_tys, + val_fn ty_subst' in_scope' val) + where + (ty_subst', in_scope', tpl_tyvars') = go ty_subst in_scope [] tpl_tyvars + + go s i acc [] = (s, i, reverse acc) + go s i acc (tv:tvs) = case substTyVar s i tv of + (s', i', tv') -> go s' i' (tv' : acc) tvs \end{code}