X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=7fa651ae8ec9538f4b61acf91ae94f639fb44cdf;hb=4c46b43215295868b332c40ba0d63520e6433536;hp=d3b87ffdcc38b6f33d5e46dc2045f03c4ffc38c0;hpb=b783b8644d142d12c832e261ba60bc81c19c3a12;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d3b87ff..7fa651a 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -63,15 +63,15 @@ module Type ( seqType, seqTypes, -- Type substitutions - TvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTvSubst, - mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst, + TvSubstEnv, emptyTvSubstEnv, -- Representation widely visible + TvSubst(..), emptyTvSubst, -- Representation visible to a few friends + mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, - extendTvSubst, extendTvSubstList, isInScope, + extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, -- Performing substitution on types - substTy, substTys, substTyWith, substTheta, substTyVar, - deShadowTy, + substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr, + deShadowTy, -- Pretty-printing pprType, pprParendType, pprTyThingCategory, @@ -101,7 +101,7 @@ import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, ) -- others -import CmdLineOpts ( opt_DictsStrict ) +import StaticFlags ( opt_DictsStrict ) import SrcLoc ( noSrcLoc ) import Unique ( Uniquable(..) ) import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual ) @@ -994,7 +994,7 @@ instance Ord PredType where { compare = tcCmpPred } \begin{code} data TvSubst = TvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- The substitution itself; guaranteed idempotent + TvSubstEnv -- The substitution itself -- See Note [Apply Once] {- ---------------------------------------------------------- @@ -1025,11 +1025,29 @@ type TvSubstEnv = TyVarEnv Type -- in the middle of matching, and unification (see Types.Unify) -- So you have to look at the context to know if it's idempotent or -- apply-once or whatever +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +composeTvSubst :: InScopeSet -> TvSubstEnv -> TvSubstEnv -> TvSubstEnv +-- (compose env1 env2)(x) is env1(env2(x)); i.e. apply env2 then env1 +-- It assumes that both are idempotent +-- Typically, env1 is the refinement to a base substitution env2 +composeTvSubst in_scope env1 env2 + = env1 `plusVarEnv` mapVarEnv (substTy subst1) env2 + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TvSubst in_scope env1 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv isEmptyTvSubst :: TvSubst -> Bool isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env +mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst +mkTvSubst = TvSubst + getTvSubstEnv :: TvSubst -> TvSubstEnv getTvSubstEnv (TvSubst _ env) = env @@ -1039,6 +1057,9 @@ getTvInScope (TvSubst in_scope _) = in_scope isInScope :: Var -> TvSubst -> Bool isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope +notElemTvSubst :: TyVar -> TvSubst -> Bool +notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env) + setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env @@ -1052,16 +1073,15 @@ extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst extendTvSubstList (TvSubst in_scope env) tvs tys = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) --- mkTvSubst and zipTvSubst generate the in-scope set from +-- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from -- the types given; but it's just a thunk so with a bit of luck -- it'll never be evaluated -mkTvSubst :: TvSubstEnv -> TvSubst -mkTvSubst env - = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env +mkOpenTvSubst :: TvSubstEnv -> TvSubst +mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env -zipTvSubst :: [TyVar] -> [Type] -> TvSubst -zipTvSubst tyvars tys +zipOpenTvSubst :: [TyVar] -> [Type] -> TvSubst +zipOpenTvSubst tyvars tys = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) -- mkTopTvSubst is called when doing top-level substitutions. @@ -1114,7 +1134,7 @@ instance Outputable TvSubst where \begin{code} substTyWith :: [TyVar] -> [Type] -> Type -> Type -substTyWith tvs tys = substTy (zipTvSubst tvs tys) +substTyWith tvs tys = substTy (zipOpenTvSubst tvs tys) substTy :: TvSubst -> Type -> Type substTy subst ty | isEmptyTvSubst subst = ty @@ -1138,13 +1158,10 @@ substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) -- Note that the in_scope set is poked only if we hit a forall -- so it may often never be fully computed -subst_ty subst@(TvSubst in_scope env) ty +subst_ty subst ty = go ty where - go ty@(TyVarTy tv) = case (lookupVarEnv env tv) of - Nothing -> ty - Just ty' -> ty' -- See Note [Apply Once] - + go (TyVarTy tv) = substTyVar subst tv go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args @@ -1158,11 +1175,17 @@ subst_ty subst@(TvSubst in_scope env) ty -- The mkAppTy smart constructor is important -- we might be replacing (a Int), represented with App -- by [Int], represented with TyConApp - go (ForAllTy tv ty) = case substTyVar subst tv of + go (ForAllTy tv ty) = case substTyVarBndr subst tv of (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) -substTyVar :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVar subst@(TvSubst in_scope env) old_var +substTyVar :: TvSubst -> TyVar -> Type +substTyVar (TvSubst in_scope env) tv + = case (lookupVarEnv env tv) of + Nothing -> TyVarTy tv + Just ty' -> ty' -- See Note [Apply Once] + +substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVarBndr subst@(TvSubst in_scope env) old_var | old_var == new_var -- No need to clone -- But we *must* zap any current substitution for the variable. -- For example: @@ -1171,7 +1194,8 @@ substTyVar subst@(TvSubst in_scope env) old_var -- -- The new_id isn't cloned, but it may have a different type -- etc, so we must return it, not the old id - = (TvSubst (in_scope `extendInScopeSet` new_var) (delVarEnv env old_var), + = (TvSubst (in_scope `extendInScopeSet` new_var) + (delVarEnv env old_var), new_var) | otherwise -- The new binder is in scope so @@ -1179,11 +1203,10 @@ substTyVar subst@(TvSubst in_scope env) old_var -- Extending the substitution to do this renaming also -- has the (correct) effect of discarding any existing -- substitution for that variable - = (TvSubst (in_scope `extendInScopeSet` new_var) (extendVarEnv env old_var (TyVarTy new_var)), + = (TvSubst (in_scope `extendInScopeSet` new_var) + (extendVarEnv env old_var (TyVarTy new_var)), new_var) where new_var = uniqAway in_scope old_var -- The uniqAway part makes sure the new variable is not already in scope \end{code} - -