X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=531709af92ec7f293d47188b0043345a88857aba;hb=c92ddc55847b34d45f188f7c62092d69915a7a7d;hp=d6420b27b869ddbdc884caed618e121f7bb21851;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index d6420b2..531709a 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -17,16 +17,22 @@ is the principal client. module TcType ( -------------------------------- -- Types - TauType, RhoType, SigmaType, + TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, + TcTyVar, TcTyVarSet, TcKind, + + -------------------------------- + -- TyVarDetails + TyVarDetails(..), isUserTyVar, isSkolemTyVar, isHoleTyVar, + tyVarBindingInfo, -------------------------------- -- Builders - mkRhoTy, mkSigmaTy, + mkPhiTy, mkSigmaTy, -------------------------------- -- Splitters -- These are important because they do not look through newtypes - tcSplitForAllTys, tcSplitRhoTy, + tcSplitForAllTys, tcSplitPhiTy, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitSigmaTy, @@ -35,48 +41,63 @@ module TcType ( --------------------------------- -- Predicates. -- Again, newtypes are opaque - tcEqType, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, - isQualifiedTy, isOverloadedTy, isStrictType, isStrictPred, + tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, + isSigmaTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, - isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy, isPrimitiveType, + isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isTauTy, tcIsTyVarTy, tcIsForAllTy, + allDistinctTyVars, --------------------------------- -- Misc type manipulators - hoistForAllTys, deNoteType, + deNoteType, namesOfType, namesOfDFunHead, getDFunTyKey, --------------------------------- -- Predicate types - PredType, mkPredTy, mkPredTys, getClassPredTys_maybe, getClassPredTys, + PredType, getClassPredTys_maybe, getClassPredTys, isPredTy, isClassPred, isTyVarClassPred, predHasFDs, mkDictTy, tcSplitPredTy_maybe, predTyUnique, - isDictTy, tcSplitDFunTy, - mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName, + isDictTy, tcSplitDFunTy, predTyUnique, + mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, + + --------------------------------- + -- Foreign import and export + isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool + isFFIImportResultTy, -- :: DynFlags -> Type -> Bool + isFFIExportResultTy, -- :: Type -> Bool + isFFIExternalTy, -- :: Type -> Bool + isFFIDynArgumentTy, -- :: Type -> Bool + isFFIDynResultTy, -- :: Type -> Bool + isFFILabelTy, -- :: Type -> Bool --------------------------------- -- Unifier and matcher unifyTysX, unifyTyListsX, unifyExtendTysX, - allDistinctTyVars, matchTy, matchTys, match, -------------------------------- -- Rexported from Type - Kind, Type, SourceType(..), PredType, ThetaType, - unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, + Kind, -- Stuff to do with kinds is insensitive to pre/post Tc + unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, + superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, + isTypeKind, isAnyTypeKind, + + Type, SourceType(..), PredType, ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, - mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, - mkTyVarTy, mkTyVarTys, mkTyConTy, - predTyUnique, mkClassPred, + mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, + mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, + isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto + isPrimitiveType, isTyVarTy, + tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, - tidyTyVar, tidyTyVars, - eqKind, eqUsage, + tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, + typeKind, eqKind, eqUsage, - -- Reexported ??? tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta ) where @@ -86,48 +107,192 @@ module TcType ( import {-# SOURCE #-} PprType( pprType ) -- friends: -import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type -- Lots and lots -import TyCon ( TyCon, isPrimTyCon, tyConArity, isNewTyCon ) -import Class ( classTyCon, classHasFDs, Class ) -import Var ( TyVar, tyVarName, isTyVar, tyVarKind, mkTyVar ) +import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend + +import Type ( -- Re-exports + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, + Kind, Type, SourceType(..), PredType, ThetaType, + unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, + mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind, + mkFunTy, mkFunTys, zipFunTys, isTyVarTy, + mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, + mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, + isUnLiftedType, isUnboxedTupleType, isPrimitiveType, + splitNewType_maybe, splitTyConApp_maybe, + tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, + tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, eqKind, eqUsage, + hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind + ) +import TyCon ( TyCon, isUnLiftedTyCon ) +import Class ( classHasFDs, Class ) +import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) +import ForeignCall ( Safety, playSafe ) import VarEnv import VarSet -- others: -import CmdLineOpts ( opt_DictsStrict ) -import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName, - mkLocalName, mkDerivedTyConOcc - ) +import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) +import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) import OccName ( OccName, mkDictOcc ) import NameSet -import PrelNames ( floatTyConKey, doubleTyConKey, foreignPtrTyConKey, - integerTyConKey, intTyConKey, addrTyConKey, boolTyConKey ) -import Unique ( Unique, Uniquable(..), mkTupleTyConUnique ) -import SrcLoc ( SrcLoc, noSrcLoc ) -import Util ( nOfThem, cmpList, thenCmp ) +import PrelNames -- Lots (e.g. in isFFIArgumentTy) +import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon ) +import BasicTypes ( IPName(..), ipNameName ) +import Unique ( Unique, Uniquable(..) ) +import SrcLoc ( SrcLoc ) +import Util ( cmpList, thenCmp, equalLength ) import Maybes ( maybeToBool, expectJust ) -import BasicTypes ( Boxity(..) ) import Outputable \end{code} %************************************************************************ %* * -\subsection{Tau, sigma and rho} +\subsection{Types} +%* * +%************************************************************************ + +The type checker divides the generic Type world into the +following more structured beasts: + +sigma ::= forall tyvars. phi + -- A sigma type is a qualified type + -- + -- Note that even if 'tyvars' is empty, theta + -- may not be: e.g. (?x::Int) => Int + + -- Note that 'sigma' is in prenex form: + -- all the foralls are at the front. + -- A 'phi' type has no foralls to the right of + -- an arrow + +phi :: theta => rho + +rho ::= sigma -> rho + | tau + +-- A 'tau' type has no quantification anywhere +-- Note that the args of a type constructor must be taus +tau ::= tyvar + | tycon tau_1 .. tau_n + | tau_1 tau_2 + | tau_1 -> tau_2 + +-- In all cases, a (saturated) type synonym application is legal, +-- provided it expands to the required form. + + +\begin{code} +type SigmaType = Type +type RhoType = Type +type TauType = Type +\end{code} + +\begin{code} +type TcTyVar = TyVar -- Might be a mutable tyvar +type TcTyVarSet = TyVarSet + +type TcType = Type -- A TcType can have mutable type variables + -- Invariant on ForAllTy in TcTypes: + -- forall a. T + -- a cannot occur inside a MutTyVar in T; that is, + -- T is "flattened" before quantifying over a + +type TcPredType = PredType +type TcThetaType = ThetaType +type TcSigmaType = TcType +type TcRhoType = TcType +type TcTauType = TcType +type TcKind = TcType +\end{code} + + +%************************************************************************ +%* * +\subsection{TyVarDetails} %* * %************************************************************************ +TyVarDetails gives extra info about type variables, used during type +checking. It's attached to mutable type variables only. +It's knot-tied back to Var.lhs. There is no reason in principle +why Var.lhs shouldn't actually have the definition, but it "belongs" here. + \begin{code} -type SigmaType = Type -type RhoType = Type +data TyVarDetails + = HoleTv -- Used *only* by the type checker when passing in a type + -- variable that should be side-effected to the result type. + -- Always has kind openTypeKind. + -- Never appears in types + + | SigTv -- Introduced when instantiating a type signature, + -- prior to checking that the defn of a fn does + -- have the expected type. Should not be instantiated. + -- + -- f :: forall a. a -> a + -- f = e + -- When checking e, with expected type (a->a), we + -- should not instantiate a + + | ClsTv -- Scoped type variable introduced by a class decl + -- class C a where ... + + | InstTv -- Ditto, but instance decl + + | PatSigTv -- Scoped type variable, introduced by a pattern + -- type signature + -- \ x::a -> e + + | VanillaTv -- Everything else + +isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible +isUserTyVar tv = case mutTyVarDetails tv of + VanillaTv -> False + other -> True + +isSkolemTyVar :: TcTyVar -> Bool +isSkolemTyVar tv = case mutTyVarDetails tv of + SigTv -> True + ClsTv -> True + InstTv -> True + oteher -> False + +isHoleTyVar :: TcTyVar -> Bool +-- NB: the hole might be filled in by now, and this +-- function does not check for that +isHoleTyVar tv = ASSERT( isMutTyVar tv ) + case mutTyVarDetails tv of + HoleTv -> True + other -> False + +tyVarBindingInfo :: TyVar -> SDoc -- Used in checkSigTyVars +tyVarBindingInfo tv + | isMutTyVar tv + = sep [ptext SLIT("is bound by the") <+> details (mutTyVarDetails tv), + ptext SLIT("at") <+> ppr (getSrcLoc tv)] + | otherwise + = empty + where + details SigTv = ptext SLIT("type signature") + details ClsTv = ptext SLIT("class declaration") + details InstTv = ptext SLIT("instance declaration") + details PatSigTv = ptext SLIT("pattern type signature") + details HoleTv = ptext SLIT("//hole//") -- Should not happen + details VanillaTv = ptext SLIT("//vanilla//") -- Ditto +\end{code} -mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) -mkRhoTy :: [SourceType] -> Type -> Type -mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty ) - foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta +%************************************************************************ +%* * +\subsection{Tau, sigma and rho} +%* * +%************************************************************************ +\begin{code} +mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) + +mkPhiTy :: [SourceType] -> Type -> Type +mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta \end{code} @@ -139,9 +304,8 @@ isTauTy (TyVarTy v) = True isTauTy (TyConApp _ tys) = all isTauTy tys isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (SourceTy p) = isTauTy (sourceTypeRep p) +isTauTy (SourceTy p) = True -- Don't look through source types isTauTy (NoteTy _ ty) = isTauTy ty -isTauTy (UsageTy _ ty) = isTauTy ty isTauTy other = False \end{code} @@ -154,7 +318,6 @@ getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (NoteTy _ t) = getDFunTyKey t getDFunTyKey (FunTy arg _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (UsageTy _ t) = getDFunTyKey t getDFunTyKey (SourceTy (NType tc _)) = getOccName tc -- Newtypes are quite reasonable getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) -- SourceTy shouldn't happen @@ -181,26 +344,23 @@ tcSplitForAllTys ty = split ty ty [] where split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs - split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs split orig_ty t tvs = (reverse tvs, orig_ty) tcIsForAllTy (ForAllTy tv ty) = True tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty -tcIsForAllTy (UsageTy n ty) = tcIsForAllTy ty tcIsForAllTy t = False -tcSplitRhoTy :: Type -> ([PredType], Type) -tcSplitRhoTy ty = split ty ty [] +tcSplitPhiTy :: Type -> ([PredType], Type) +tcSplitPhiTy ty = split ty ty [] where split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of Just p -> split res res (p:ts) Nothing -> (reverse ts, orig_ty) split orig_ty (NoteTy n ty) ts = split orig_ty ty ts - split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts split orig_ty ty ts = (reverse ts, orig_ty) tcSplitSigmaTy ty = case tcSplitForAllTys ty of - (tvs, rho) -> case tcSplitRhoTy rho of + (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) tcTyConAppTyCon :: Type -> TyCon @@ -215,12 +375,11 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) --- Newtypes are opaque, so they may be split tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) +tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -tcSplitTyConApp_maybe (UsageTy _ ty) = tcSplitTyConApp_maybe ty tcSplitTyConApp_maybe (SourceTy (NType tc tys)) = Just (tc,tys) + -- Newtypes are opaque, so they may be split -- However, predicates are not treated -- as tycon applications by the type checker tcSplitTyConApp_maybe other = Nothing @@ -235,7 +394,6 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res) tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty -tcSplitFunTy_maybe (UsageTy _ ty) = tcSplitFunTy_maybe ty tcSplitFunTy_maybe other = Nothing tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg } @@ -243,10 +401,9 @@ tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res } tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2) +tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty -tcSplitAppTy_maybe (UsageTy _ ty) = tcSplitAppTy_maybe ty tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys --- Don't forget that newtype! tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys @@ -265,7 +422,6 @@ tcSplitAppTy ty = case tcSplitAppTy_maybe ty of tcGetTyVar_maybe :: Type -> Maybe TyVar tcGetTyVar_maybe (TyVarTy tv) = Just tv tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t -tcGetTyVar_maybe ty@(UsageTy _ _) = pprPanic "tcGetTyVar_maybe: UTy:" (pprType ty) tcGetTyVar_maybe other = Nothing tcGetTyVar :: String -> Type -> TyVar @@ -291,7 +447,6 @@ tcSplitMethodTy ty = split ty Just p -> (p, res) Nothing -> panic "splitMethodTy" split (NoteTy n ty) = split ty - split (UsageTy _ ty) = split ty split _ = panic "splitMethodTy" tcSplitDFunTy :: Type -> ([TyVar], [SourceType], Class, [Type]) @@ -302,6 +457,31 @@ tcSplitDFunTy ty (tvs, theta, clas, tys) }} \end{code} +(allDistinctTyVars tys tvs) = True + iff +all the types tys are type variables, +distinct from each other and from tvs. + +This is useful when checking that unification hasn't unified signature +type variables. For example, if the type sig is + f :: forall a b. a -> b -> b +we want to check that 'a' and 'b' havn't + (a) been unified with a non-tyvar type + (b) been unified with each other (all distinct) + (c) been unified with a variable free in the environment + +\begin{code} +allDistinctTyVars :: [Type] -> TyVarSet -> Bool + +allDistinctTyVars [] acc + = True +allDistinctTyVars (ty:tys) acc + = case tcGetTyVar_maybe ty of + Nothing -> False -- (a) + Just tv | tv `elemVarSet` acc -> False -- (b) or (c) + | otherwise -> allDistinctTyVars tys (acc `extendVarSet` tv) +\end{code} + %************************************************************************ %* * @@ -315,29 +495,21 @@ tcSplitDFunTy ty isPred :: SourceType -> Bool isPred (ClassP _ _) = True isPred (IParam _ _) = True -isPred (NType _ __) = False +isPred (NType _ _) = False isPredTy :: Type -> Bool isPredTy (NoteTy _ ty) = isPredTy ty -isPredTy (UsageTy _ ty) = isPredTy ty isPredTy (SourceTy sty) = isPred sty isPredTy _ = False tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty -tcSplitPredTy_maybe (UsageTy _ ty) = tcSplitPredTy_maybe ty tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p tcSplitPredTy_maybe other = Nothing - -mkPredTy :: PredType -> Type -mkPredTy pred = SourceTy pred - -mkPredTys :: ThetaType -> [Type] -mkPredTys preds = map SourceTy preds - + predTyUnique :: PredType -> Unique -predTyUnique (IParam n _) = getUnique n +predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (ClassP clas tys) = getUnique clas predHasFDs :: PredType -> Bool @@ -347,22 +519,21 @@ predHasFDs (IParam _ _) = True predHasFDs (ClassP cls _) = classHasFDs cls mkPredName :: Unique -> SrcLoc -> SourceType -> Name -mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc -mkPredName uniq loc (IParam name ty) = name +mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc +mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc \end{code} --------------------- Dictionary types --------------------------------- \begin{code} -mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - ClassP clas tys +mkClassPred clas tys = ClassP clas tys isClassPred :: SourceType -> Bool isClassPred (ClassP clas tys) = True isClassPred other = False -isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys +isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys isTyVarClassPred other = False getClassPredTys_maybe :: SourceType -> Maybe (Class, [Type]) @@ -373,13 +544,11 @@ getClassPredTys :: PredType -> (Class, [Type]) getClassPredTys (ClassP clas tys) = (clas, tys) mkDictTy :: Class -> [Type] -> Type -mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - mkPredTy (ClassP clas tys) +mkDictTy clas tys = mkPredTy (ClassP clas tys) isDictTy :: Type -> Bool isDictTy (SourceTy p) = isClassPred p isDictTy (NoteTy _ ty) = isDictTy ty -isDictTy (UsageTy _ ty) = isDictTy ty isDictTy other = False \end{code} @@ -390,7 +559,7 @@ isIPPred :: SourceType -> Bool isIPPred (IParam _ _) = True isIPPred other = False -inheritablePred :: PredType -> Bool +isInheritablePred :: PredType -> Bool -- Can be inherited by a context. For example, consider -- f x = let g y = (?v, y+x) -- in (g 3 with ?v = 8, @@ -399,12 +568,12 @@ inheritablePred :: PredType -> Bool -- g :: (?v :: a) => a -> a -- but it doesn't need to be quantified over the Num a dictionary -- which can be free in g's rhs, and shared by both calls to g -inheritablePred (ClassP _ _) = True -inheritablePred other = False +isInheritablePred (ClassP _ _) = True +isInheritablePred other = False -predMentionsIPs :: SourceType -> NameSet -> Bool -predMentionsIPs (IParam n _) ns = n `elemNameSet` ns -predMentionsIPs other ns = False +isLinearPred :: TcPredType -> Bool +isLinearPred (IParam (Linear n) _) = True +isLinearPred other = False \end{code} @@ -421,6 +590,9 @@ But ignoring usage types tcEqType :: Type -> Type -> Bool tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False } +tcEqTypes :: [Type] -> [Type] -> Bool +tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False } + tcEqPred :: PredType -> PredType -> Bool tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False } @@ -440,11 +612,9 @@ cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2) -- we in effect substitute tv2 for tv1 in t1 before continuing - -- Look through NoteTy and UsageTy + -- Look through NoteTy cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2 -cmpTy env (UsageTy _ ty1) ty2 = cmpTy env ty1 ty2 -cmpTy env ty1 (UsageTy _ ty2) = cmpTy env ty1 ty2 -- Deal with equal constructors cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of @@ -479,7 +649,7 @@ cmpTy env _ _ = LT \begin{code} cmpSourceTy :: TyVarEnv TyVar -> SourceType -> SourceType -> Ordering -cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) +cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy 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 @@ -508,35 +678,32 @@ instance Ord SourceType where { compare = tcCmpPred } %* * %************************************************************************ -isQualifiedTy returns true of any qualified type. It doesn't *necessarily* have +isSigmaTy returns true of any qualified type. It doesn't *necessarily* have any foralls. E.g. f :: (?x::Int) => Int -> Int \begin{code} -isQualifiedTy :: Type -> Bool -isQualifiedTy (ForAllTy tyvar ty) = True -isQualifiedTy (FunTy a b) = isPredTy a -isQualifiedTy (NoteTy n ty) = isQualifiedTy ty -isQualifiedTy (UsageTy _ ty) = isQualifiedTy ty -isQualifiedTy _ = False +isSigmaTy :: Type -> Bool +isSigmaTy (ForAllTy tyvar ty) = True +isSigmaTy (FunTy a b) = isPredTy a +isSigmaTy (NoteTy n ty) = isSigmaTy ty +isSigmaTy _ = False isOverloadedTy :: Type -> Bool isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty isOverloadedTy (FunTy a b) = isPredTy a isOverloadedTy (NoteTy n ty) = isOverloadedTy ty -isOverloadedTy (UsageTy _ ty) = isOverloadedTy ty isOverloadedTy _ = False \end{code} \begin{code} isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey -isForeignPtrTy = is_tc foreignPtrTyConKey isIntegerTy = is_tc integerTyConKey isIntTy = is_tc intTyConKey isAddrTy = is_tc addrTyConKey isBoolTy = is_tc boolTyConKey -isUnitTy = is_tc (mkTupleTyConUnique Boxed 0) +isUnitTy = is_tc unitTyConKey is_tc :: Unique -> Type -> Bool -- Newtypes are opaque to this @@ -545,36 +712,6 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of Nothing -> False \end{code} -\begin{code} -isPrimitiveType :: Type -> Bool --- Returns types that are opaque to Haskell. --- Most of these are unlifted, but now that we interact with .NET, we --- may have primtive (foreign-imported) types that are lifted -isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) - isPrimTyCon tc - other -> False -\end{code} - -@isStrictType@ computes whether an argument (or let RHS) should -be computed strictly or lazily, based only on its type - -\begin{code} -isStrictType :: Type -> Bool -isStrictType ty - | isUnLiftedType ty = True - | Just pred <- tcSplitPredTy_maybe ty = isStrictPred pred - | otherwise = False - -isStrictPred (ClassP clas _) = opt_DictsStrict - && not (isNewTyCon (classTyCon clas)) -isStrictPred pred = False - -- We may be strict in dictionary types, but only if it - -- has more than one component. - -- [Being strict in a single-component dictionary risks - -- poking the dictionary component, which is wrong.] -\end{code} - %************************************************************************ %* * @@ -583,24 +720,6 @@ isStrictPred pred = False %************************************************************************ \begin{code} -hoistForAllTys :: Type -> Type - -- Move all the foralls to the top - -- e.g. T -> forall a. a ==> forall a. T -> a - -- Careful: LOSES USAGE ANNOTATIONS! -hoistForAllTys ty - = case hoist ty of { (tvs, body) -> mkForAllTys tvs body } - where - hoist :: Type -> ([TyVar], Type) - hoist ty = case tcSplitFunTys ty of { (args, res) -> - case tcSplitForAllTys res of { - ([], body) -> ([], ty) ; - (tvs1, body1) -> case hoist body1 of { (tvs2,body2) -> - (tvs1 ++ tvs2, mkFunTys args body2) - }}} -\end{code} - - -\begin{code} deNoteType :: Type -> Type -- Remove synonyms, but not source types deNoteType ty@(TyVarTy tyvar) = ty @@ -610,12 +729,11 @@ deNoteType (NoteTy _ ty) = deNoteType ty deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) -deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty) deNoteSourceType :: SourceType -> SourceType -deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys) -deNoteSourceType (IParam n ty) = IParam n (deNoteType ty) -deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys) +deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys) +deNoteSourceType (IParam n ty) = IParam n (deNoteType ty) +deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys) \end{code} Find the free names of a type, including the type constructors and classes it mentions @@ -633,7 +751,6 @@ namesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar -namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys @@ -652,34 +769,112 @@ namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of %************************************************************************ %* * -\subsection{Unification with an explicit substitution} +\subsection[TysWiredIn-ext-type]{External types} %* * %************************************************************************ -(allDistinctTyVars tys tvs) = True - iff -all the types tys are type variables, -distinct from each other and from tvs. - -This is useful when checking that unification hasn't unified signature -type variables. For example, if the type sig is - f :: forall a b. a -> b -> b -we want to check that 'a' and 'b' havn't - (a) been unified with a non-tyvar type - (b) been unified with each other (all distinct) - (c) been unified with a variable free in the environment +The compiler's foreign function interface supports the passing of a +restricted set of types as arguments and results (the restricting factor +being the ) \begin{code} -allDistinctTyVars :: [Type] -> TyVarSet -> Bool +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool +-- Checks for valid argument type for a 'foreign import' +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + +isFFIExternalTy :: Type -> Bool +-- Types that are allowed as arguments of a 'foreign export' +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty + +isFFIImportResultTy :: DynFlags -> Type -> Bool +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) ty + +isFFIExportResultTy :: Type -> Bool +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty + +isFFIDynArgumentTy :: Type -> Bool +-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr, +-- or a newtype of either. +isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) + +isFFIDynResultTy :: Type -> Bool +-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr, +-- or a newtype of either. +isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) + +isFFILabelTy :: Type -> Bool +-- The type of a foreign label must be Ptr, FunPtr, Addr, +-- or a newtype of either. +isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) + +checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool + -- Look through newtypes + -- Non-recursive ones are transparent to splitTyConApp, + -- but recursive ones aren't; hence the splitNewType_maybe +checkRepTyCon check_tc ty + | Just ty' <- splitNewType_maybe ty = checkRepTyCon check_tc ty' + | Just (tc,_) <- splitTyConApp_maybe ty = check_tc tc + | otherwise = False +\end{code} -allDistinctTyVars [] acc - = True -allDistinctTyVars (ty:tys) acc - = case tcGetTyVar_maybe ty of - Nothing -> False -- (a) - Just tv | tv `elemVarSet` acc -> False -- (b) or (c) - | otherwise -> allDistinctTyVars tys (acc `extendVarSet` tv) -\end{code} +---------------------------------------------- +These chaps do the work; they are not exported +---------------------------------------------- + +\begin{code} +legalFEArgTyCon :: TyCon -> Bool +-- It's illegal to return foreign objects and (mutable) +-- bytearrays from a _ccall_ / foreign declaration +-- (or be passed them as arguments in foreign exported functions). +legalFEArgTyCon tc + | getUnique tc `elem` [ byteArrayTyConKey, mutableByteArrayTyConKey ] + = False + -- It's also illegal to make foreign exports that take unboxed + -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 + | otherwise + = boxedMarshalableTyCon tc + +legalFIResultTyCon :: DynFlags -> TyCon -> Bool +legalFIResultTyCon dflags tc + | getUnique tc `elem` + [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False + | tc == unitTyCon = True + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Bool +legalFEResultTyCon tc + | getUnique tc `elem` + [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False + | tc == unitTyCon = True + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool +-- Checks validity of types going from Haskell -> external world +legalOutgoingTyCon dflags safety tc + | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] + = False + | otherwise + = marshalableTyCon dflags tc + +marshalableTyCon dflags tc + = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc) + || boxedMarshalableTyCon tc + +boxedMarshalableTyCon tc + = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , addrTyConKey, ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , byteArrayTyConKey, mutableByteArrayTyConKey + , boolTyConKey + ] +\end{code} %************************************************************************ @@ -737,13 +932,21 @@ uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_) | tyvar2 `elemVarSet` tmpls = uVarX tyvar2 ty1 k subst + -- Predicates +uTysX (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) k subst + | n1 == n2 = uTysX t1 t2 k subst +uTysX (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) k subst + | c1 == c2 = uTyListsX tys1 tys2 k subst +uTysX (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) k subst + | tc1 == tc2 = uTyListsX tys1 tys2 k subst + -- Functions; just check the two parts uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst -- Type constructors must match uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst - | (con1 == con2 && length tys1 == length tys2) + | (con1 == con2 && equalLength tys1 tys2) = uTyListsX tys1 tys2 k subst -- Applications need a bit of care! @@ -766,10 +969,6 @@ uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)" uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)" #endif - -- Ignore usages -uTysX (UsageTy _ t1) t2 k subst = uTysX t1 t2 k subst -uTysX t1 (UsageTy _ t2) k subst = uTysX t1 t2 k subst - -- Anything else fails uTysX ty1 ty2 k subst = Nothing @@ -790,7 +989,6 @@ uVarX tv1 ty2 k subst@(tmpls, env) | typeKind ty2 `eqKind` tyVarKind tv1 && occur_check_ok ty2 -> -- No kind mismatch nor occur check - UASSERT( not (isUTy ty2) ) k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) | otherwise -> Nothing -- Fail if kind mis-match or occur check @@ -858,8 +1056,15 @@ match (TyVarTy v) ty tmpls k senv | v `elemVarSet` tmpls = -- v is a template variable case lookupSubstEnv senv v of - Nothing -> UASSERT( not (isUTy ty) ) - k (extendSubstEnv senv v (DoneTy ty)) + Nothing | typeKind ty `eqKind` tyVarKind v + -- We do a kind check, just as in the uVarX above + -- The kind check is needed to avoid bogus matches + -- of (a b) with (c d), where the kinds don't match + -- An occur check isn't needed when matching. + -> k (extendSubstEnv senv v (DoneTy ty)) + + | otherwise -> Nothing -- Fails + Just (DoneTy ty') | ty' `tcEqType` ty -> k senv -- Succeeds | otherwise -> Nothing -- Fails @@ -876,6 +1081,15 @@ match (TyVarTy v) ty tmpls k senv -- variable may not match the pattern (TyVarTy v') as one would -- expect, due to an intervening Note. KSW 2000-06. + -- Predicates +match (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) tmpls k senv + | n1 == n2 = match t1 t2 tmpls k senv +match (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) tmpls k senv + | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv +match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv + | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv + + -- Functions; just check the two parts match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv @@ -885,14 +1099,11 @@ match (AppTy fun1 arg1) ty2 tmpls k senv Nothing -> Nothing -- Fail match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv - | tc1 == tc2 = match_tc_app tys1 tys2 tmpls k senv + | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- Newtypes are opaque; other source types should not happen match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv - | tc1 == tc2 = match_tc_app tys1 tys2 tmpls k senv - -match (UsageTy _ ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv -match ty1 (UsageTy _ ty2) tmpls k senv = match ty1 ty2 tmpls k senv + | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- With type synonyms, we have to be careful for the exact -- same reasons as in the unifier. Please see the @@ -904,7 +1115,7 @@ match ty1 (NoteTy n2 ty2) tmpls k senv = match ty1 ty2 tmpls k senv -- Catch-all fails match _ _ _ _ _ = Nothing -match_tc_app tys1 tys2 tmpls k senv +match_list_exactly tys1 tys2 tmpls k senv = match_list tys1 tys2 tmpls k' senv where k' (senv', tys2') | null tys2' = k senv' -- Succeed