%
-% (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}
-#include "HsVersions.h"
-
module SpecEnv (
- SYN_IE(SpecEnv), MatchEnv,
- nullSpecEnv, isNullSpecEnv,
- addOneToSpecEnv, lookupSpecEnv
+ SpecEnv,
+ emptySpecEnv, isEmptySpecEnv,
+ specEnvValues, specEnvToList, specEnvFromList,
+ addToSpecEnv, lookupSpecEnv, substSpecEnv
) where
-IMP_Ubiq()
-
-import MatchEnv
-import Type --( matchTys, isTyVarTy )
-import Usage ( SYN_IE(UVar) )
-import OccurAnal ( occurAnalyseGlobalExpr )
-import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(SimplifiableCoreExpr) )
-import Maybes ( MaybeErr(..) )
---import PprStyle--ToDo:rm
---import Util(pprTrace)--ToDo:rm
---import Outputable--ToDo:rm
---import PprType--ToDo:rm
---import Pretty--ToDo:rm
---import PprCore--ToDo:rm
---import Id--ToDo:rm
-import TyVar --ToDo:rm
---import Unique--ToDo:rm
---import IdInfo--ToDo:rm
---import PprEnv--ToDo:rm
+#include "HsVersions.h"
+
+import Var ( TyVar )
+import VarEnv
+import VarSet
+import Type ( Type, fullSubstTy, substTyVar )
+import Unify ( unifyTyListsX, matchTys )
+import Outputable
+import Maybes
\end{code}
-A @SpecEnv@ holds details of an @Id@'s specialisations. It should be
-a newtype (ToDo), but for 1.2 compatibility we make it a data type.
-It can't be a synonym because there's an IdInfo instance of it
-that doesn't work if it's (MatchEnv a b).
-Furthermore, making it a data type makes it easier to break the IdInfo loop.
+
+%************************************************************************
+%* *
+\section{SpecEnv}
+%* *
+%************************************************************************
\begin{code}
-data SpecEnv = SpecEnv (MatchEnv [Type] SimplifiableCoreExpr)
+data SpecEnv value
+ = EmptySE
+ | SpecEnv [([TyVar], -- Really a set, but invariably small,
+ -- so kept as a list
+ [Type],
+ value)]
+
+specEnvValues :: SpecEnv value -> [value]
+specEnvValues EmptySE = []
+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}
-For example, if \tr{f}'s @SpecEnv@ contains the mapping:
-\begin{verbatim}
- [List a, b] ===> (\d -> f' a b)
-\end{verbatim}
-then when we find an application of f to matching types, we simply replace
-it by the matching RHS:
-\begin{verbatim}
- f (List Int) Bool ===> (\d -> f' Int Bool)
-\end{verbatim}
-All the stuff about how many dictionaries to discard, and what types
-to apply the specialised function to, are handled by the fact that the
-SpecEnv contains a template for the result of the specialisation.
+In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
-There is one more exciting case, which is dealt with in exactly the same
-way. If the specialised value is unboxed then it is lifted at its
-definition site and unlifted at its uses. For example:
+In others, overlap is permitted, but only in such a way that one can make
+a unique choice when looking up. That is, overlap is only permitted if
+one template matches the other, or vice versa. So this is ok:
- pi :: forall a. Num a => a
+ [a] [Int]
-might have a specialisation
+but this is not
- [Int#] ===> (case pi' of Lift pi# -> pi#)
+ (Int,a) (b,Int)
-where pi' :: Lift Int# is the specialised version of pi.
+If overlap is permitted, the list is kept most specific first, so that
+the first lookup is the right choice.
+For now we just use association lists.
+
\begin{code}
-nullSpecEnv :: SpecEnv
-nullSpecEnv = SpecEnv nullMEnv
-
-isNullSpecEnv :: SpecEnv -> Bool
-isNullSpecEnv (SpecEnv env) = null (mEnvToList env)
-
-addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], SimplifiableCoreExpr)
-addOneToSpecEnv (SpecEnv env) tys rhs
- = --pprTrace "addOneToSpecEnv" (($$) (ppr PprDebug tys) (ppr PprDebug rhs)) $
- case (insertMEnv matchTys env tys (occurAnalyseGlobalExpr rhs)) of
- Succeeded menv -> Succeeded (SpecEnv menv)
- Failed err -> Failed err
-
-lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (SimplifiableCoreExpr, ([(TyVar,Type)], [Type]))
-lookupSpecEnv (SpecEnv env) tys
- | all isTyVarTy tys = Nothing -- Short cut: no specialisation for simple tyvars
- | otherwise = --pprTrace "lookupSpecEnv" (ppr PprDebug tys) $
- lookupMEnv matchTys env tys
+emptySpecEnv :: SpecEnv a
+emptySpecEnv = EmptySE
+
+isEmptySpecEnv EmptySE = True
+isEmptySpecEnv _ = False
\end{code}
+@lookupSpecEnv@ looks up in a @SpecEnv@, using a one-way match. Since the env is kept
+ordered, the first match must be the only one.
+The thing we are looking up can have an
+arbitrary "flexi" part.
+
+\begin{code}
+lookupSpecEnv :: SDoc -- For error report
+ -> SpecEnv value -- The envt
+ -> [Type] -- Key
+ -> Maybe (TyVarEnv Type, value)
+
+lookupSpecEnv doc EmptySE key = Nothing
+lookupSpecEnv doc (SpecEnv alist) key
+ = find alist
+ where
+ find [] = Nothing
+ 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)
+\end{code}
+@addToSpecEnv@ extends a @SpecEnv@, checking for overlaps.
+
+A boolean flag controls overlap reporting.
+
+True => overlap is permitted, but only if one template matches the other;
+ not if they unify but neither is
+
+\begin{code}
+addToSpecEnv :: Bool -- True <=> overlap permitted
+ -> SpecEnv value -- Envt
+ -> [TyVar] -> [Type] -> value -- New item
+ -> MaybeErr (SpecEnv value) -- Success...
+ ([Type], value) -- Failure: Offending overlap
+
+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_tvs, ins_tys, value)
+
+ insert [] = returnMaB [ins_item]
+ 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 (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 -> 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
+ 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}
projects / ghc-hetmet.git / blobdiff