X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=fd817956d23356001bbb09a08291ae30696a8a14;hb=cd290fc88d35d5a32c994664baa56a5eae250e9e;hp=2aa31ebb2728b6a8b72e335ffa38b8dc01784343;hpb=67ee8a93fc96a38c3f73468cb86d8421a11d2911;p=ghc-hetmet.git diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 2aa31eb..fd81795 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -1,8 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1998 % -\section[Type]{Type - public interface} +Type - public interface \begin{code} module Type ( @@ -12,7 +13,7 @@ module Type ( -- Kinds Kind, SimpleKind, KindVar, - kindFunResult, splitKindFunTys, + kindFunResult, splitKindFunTys, splitKindFunTysN, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, @@ -47,13 +48,14 @@ module Type ( splitTyConApp_maybe, splitTyConApp, splitNewTyConApp_maybe, splitNewTyConApp, - repType, typePrimRep, coreView, tcView, kindView, + repType, repType', typePrimRep, coreView, tcView, kindView, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, dropForAlls, -- Source types predTypeRep, mkPredTy, mkPredTys, + tyConOrigHead, pprSourceTyCon, -- Newtypes splitRecNewType_maybe, newTyConInstRhs, @@ -90,10 +92,10 @@ module Type ( -- Performing substitution on types substTy, substTys, substTyWith, substTheta, - substPred, substTyVar, substTyVarBndr, deShadowTy, lookupTyVar, + substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, -- Pretty-printing - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll, pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind ) where @@ -105,31 +107,22 @@ module Type ( import TypeRep -- friends: -import Var ( Var, TyVar, tyVarKind, tyVarName, - setTyVarName, setTyVarKind, mkWildCoVar ) +import Var import VarEnv import VarSet -import OccName ( tidyOccName ) -import Name ( NamedThing(..), tidyNameOcc ) -import Class ( Class, classTyCon ) -import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey, - ubxTupleKindTyConKey, argTypeKindTyConKey ) -import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, - isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs, - isAlgTyCon, tyConArity, isSuperKindTyCon, - tcExpandTyCon_maybe, coreExpandTyCon_maybe, - tyConKind, PrimRep(..), tyConPrimRep, tyConUnique, - isCoercionTyCon_maybe, isCoercionTyCon - ) +import Name +import Class +import PrelNames +import TyCon -- others -import StaticFlags ( opt_DictsStrict ) -import Util ( mapAccumL, seqList, lengthIs, snocView, thenCmp, isEqual, all2 ) +import StaticFlags +import Util import Outputable -import UniqSet ( sizeUniqSet ) -- Should come via VarSet -import Maybe ( isJust ) +import UniqSet + +import Data.Maybe ( isJust ) \end{code} @@ -418,7 +411,6 @@ splitNewTyConApp_maybe other = Nothing newTyConInstRhs :: TyCon -> [Type] -> Type newTyConInstRhs tycon tys = let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty - \end{code} @@ -448,7 +440,7 @@ repType looks through (b) synonyms (c) predicates (d) usage annotations - (e) all newtypes, including recursive ones + (e) all newtypes, including recursive ones, but not newtype families It's useful in the back end. \begin{code} @@ -457,7 +449,7 @@ repType :: Type -> Type repType ty | Just ty' <- coreView ty = repType ty' repType (ForAllTy _ ty) = repType ty repType (TyConApp tc tys) - | isNewTyCon tc = -- Recursive newtypes are opaque to coreView + | isClosedNewTyCon tc = -- Recursive newtypes are opaque to coreView -- but we must expand them here. Sure to -- be saturated because repType is only applied -- to types of kind * @@ -465,6 +457,16 @@ repType (TyConApp tc tys) repType (new_type_rep tc tys) repType ty = ty +-- repType' aims to be a more thorough version of repType +-- For now it simply looks through the TyConApp args too +repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined + | otherwise = go1 ty + where + go1 = go . repType + go (TyConApp tc tys) = mkTyConApp tc (map repType' tys) + go ty = ty + + -- new_type_rep doesn't ask any questions: -- it just expands newtype, whether recursive or not new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) @@ -600,6 +602,23 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -- Result might be a newtype application, but the consumer will -- look through that too if necessary predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) + +-- The original head is the tycon and its variables for a vanilla tycon and it +-- is the family tycon and its type indexes for a family instance. +tyConOrigHead :: TyCon -> (TyCon, [Type]) +tyConOrigHead tycon = case tyConFamInst_maybe tycon of + Nothing -> (tycon, mkTyVarTys (tyConTyVars tycon)) + Just famInst -> famInst + +-- Pretty prints a tycon, using the family instance in case of a +-- representation tycon. For example +-- e.g. data T [a] = ... +-- In that case we want to print `T [a]', where T is the family TyCon +pprSourceTyCon tycon + | Just (repTyCon, tys) <- tyConFamInst_maybe tycon + = ppr $ repTyCon `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon \end{code} @@ -616,7 +635,7 @@ splitRecNewType_maybe :: Type -> Maybe Type -- Only applied to types of kind *, hence the newtype is always saturated splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty' splitRecNewType_maybe (TyConApp tc tys) - | isNewTyCon tc + | isClosedNewTyCon tc = ASSERT( tys `lengthIs` tyConArity tc ) -- splitRecNewType_maybe only be applied -- to *types* (of kind *) ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView @@ -1023,13 +1042,19 @@ cmpTypesX env ty [] = GT ------------- cmpPredX :: RnEnv2 -> PredType -> PredType -> Ordering cmpPredX env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` cmpTypeX env ty1 ty2 - -- Compare types as well as names for implicit parameters - -- This comparison is used exclusively (I think) for the - -- finite map built in TcSimplify -cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` cmpTypesX env tys1 tys2 -cmpPredX env (IParam _ _) (ClassP _ _) = LT -cmpPredX env (ClassP _ _) (IParam _ _) = GT + -- Compare names only for implicit parameters + -- This comparison is used exclusively (I believe) + -- for the Avails finite map built in TcSimplify + -- If the types differ we keep them distinct so that we see + -- a distinct pair to run improvement on +cmpPredX env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTypesX env tys1 tys2) cmpPredX env (EqPred ty1 ty2) (EqPred ty1' ty2') = (cmpTypeX env ty1 ty1') `thenCmp` (cmpTypeX env ty2 ty2') + +-- Constructor order: IParam < ClassP < EqPred +cmpPredX env (IParam {}) _ = LT +cmpPredX env (ClassP {}) (IParam {}) = GT +cmpPredX env (ClassP {}) (EqPred {}) = LT +cmpPredX env (EqPred {}) _ = GT \end{code} PredTypes are used as a FM key in TcSimplify, @@ -1051,11 +1076,13 @@ instance Ord PredType where { compare = tcCmpPred } data TvSubst = TvSubst InScopeSet -- The in-scope type variables TvSubstEnv -- The substitution itself - -- See Note [Apply Once] + -- See Note [Apply Once] + -- and Note [Extending the TvSubstEnv] {- ---------------------------------------------------------- - Note [Apply Once] +Note [Apply Once] +~~~~~~~~~~~~~~~~~ We use TvSubsts to instantiate things, and we might instantiate forall a b. ty \with the types @@ -1072,6 +1099,38 @@ variations happen to; for example [a -> (a, b)]. A TvSubst is not idempotent, but, unlike the non-idempotent substitution we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following invariant should hold of a TvSubst + + The in-scope set is needed *only* to + guide the generation of fresh uniques + + In particular, the *kind* of the type variables in + the in-scope set is not relevant + +This invariant allows a short-cut when the TvSubstEnv is empty: +if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- +then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's type does change + +This invariant has several crucial consequences: + +* In substTyVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + + -------------------------------------------------------------- -} @@ -1100,6 +1159,7 @@ composeTvSubst in_scope env1 env2 emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv isEmptyTvSubst :: TvSubst -> Bool + -- See Note [Extending the TvSubstEnv] isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst @@ -1258,17 +1318,22 @@ subst_ty subst ty substTyVar :: TvSubst -> TyVar -> Type substTyVar subst@(TvSubst in_scope env) tv = case lookupTyVar subst tv of { - Nothing -> TyVarTy tv; + Nothing -> TyVarTy tv; Just ty -> ty -- See Note [Apply Once] } +substTyVars :: TvSubst -> [TyVar] -> [Type] +substTyVars subst tvs = map (substTyVar subst) tvs + lookupTyVar :: TvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TvSubst] lookupTyVar (TvSubst in_scope env) tv = lookupVarEnv env tv substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) substTyVarBndr subst@(TvSubst in_scope env) old_var = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) where + is_co_var = isCoVar old_var new_env | no_change = delVarEnv env old_var | otherwise = extendVarEnv env old_var (TyVarTy new_var) @@ -1276,6 +1341,7 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var no_change = new_var == old_var && not is_co_var -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TvSubst] -- -- In that case we don't need to extend the substitution -- to map old to new. But instead we must zap any @@ -1287,12 +1353,10 @@ substTyVarBndr subst@(TvSubst in_scope env) old_var -- The uniqAway part makes sure the new variable is not already in scope subst_old_var -- subst_old_var is old_var with the substitution applied to its kind - -- It's only worth doing the substitution for coercions, - -- becuase only they can have free type variables - | is_co_var = setTyVarKind old_var (substTy subst kind) + -- It's only worth doing the substitution for coercions, + -- becuase only they can have free type variables + | is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var)) | otherwise = old_var - kind = tyVarKind old_var - is_co_var = isCoercionKind kind \end{code} ---------------------------------------------------- @@ -1371,6 +1435,9 @@ kindFunResult k = funResultTy k splitKindFunTys :: Kind -> ([Kind],Kind) splitKindFunTys k = splitFunTys k +splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) +splitKindFunTysN k = splitFunTysN k + isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey @@ -1426,7 +1493,7 @@ isKind k = isSuperKind (typeKind k) isSubKind :: Kind -> Kind -> Bool -- (k1 `isSubKind` k2) checks that k1 <: k2 -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc1 +isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2')) = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2' @@ -1465,14 +1532,6 @@ defaultKind k | isSubArgTypeKind k = liftedTypeKind | otherwise = k -isCoercionKind :: Kind -> Bool --- All coercions are of form (ty1 :=: ty2) --- This function is here rather than in Coercion, --- because it's used by substTy -isCoercionKind k | Just k' <- kindView k = isCoercionKind k' -isCoercionKind (PredTy (EqPred {})) = True -isCoercionKind other = False - isEqPred :: PredType -> Bool isEqPred (EqPred _ _) = True isEqPred other = False