X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=753ad4ffdf9ef74455a1a92299b3733c96fca8cb;hb=49ac6c398f2915de9eadff3cd2631bc31f806ec8;hp=44b0c2afd25bb262f4d86d3c6b62b5174b1f1f91;hpb=98643c2d5bd08ec71edd555e8989e530de6f5921;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 44b0c2a..753ad4f 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -73,6 +73,7 @@ module TcType ( isFFILabelTy, -- :: Type -> Bool isFFIDotnetTy, -- :: DynFlags -> Type -> Bool isFFIDotnetObjTy, -- :: Type -> Bool + isFFITy, -- :: Type -> Bool toDNType, -- :: Type -> DNType @@ -85,8 +86,8 @@ module TcType ( -- Rexported from Type Kind, -- Stuff to do with kinds is insensitive to pre/post Tc unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, - superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, - isTypeKind, isAnyTypeKind, + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isArgTypeKind, isSubKind, defaultKind, Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, @@ -100,16 +101,17 @@ module TcType ( tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, - typeKind, eqKind, + typeKind, - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta - ) where + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, -#include "HsVersions.h" + pprKind, pprParendKind, + pprType, pprParendType, + pprPred, pprTheta, pprThetaArrow, pprClassPred + ) where -import {-# SOURCE #-} PprType( pprType ) --- PprType imports TcType so that it can print intelligently +#include "HsVersions.h" -- friends: import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend @@ -117,11 +119,13 @@ import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, Kind, Type, PredType(..), - ThetaType, unliftedTypeKind, + ThetaType, unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, + isLiftedTypeKind, isUnliftedTypeKind, + isOpenTypeKind, mkArrowKinds, mkForAllTy, mkForAllTys, - defaultKind, isTypeKind, isAnyTypeKind, - mkFunTy, mkFunTys, zipFunTys, isTyVarTy, + defaultKind, isArgTypeKind, isOpenTypeKind, + mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, @@ -131,16 +135,17 @@ import Type ( -- Re-exports tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, - tidyOpenTyVars, eqKind, - hasMoreBoxityInfo, liftedBoxity, - superBoxity, typeKind, superKind, repType + tidyOpenTyVars, + isSubKind, + typeKind, repType, + pprKind, pprParendKind, + pprType, pprParendType, + pprPred, pprTheta, pprThetaArrow, pprClassPred ) import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) import Class ( Class ) -import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) -import ForeignCall ( Safety, playSafe - , DNType(..) - ) +import Var ( TyVar, tyVarKind, tcTyVarDetails ) +import ForeignCall ( Safety, playSafe, DNType(..) ) import VarEnv import VarSet @@ -196,9 +201,6 @@ tau ::= tyvar -- provided it expands to the required form. \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 @@ -210,7 +212,8 @@ type TcThetaType = ThetaType type TcSigmaType = TcType type TcRhoType = TcType type TcTauType = TcType -type TcKind = TcType + +type TcKind = Kind \end{code} @@ -226,11 +229,12 @@ 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 TcTyVar = TyVar -- Used only during type inference + data TyVarDetails = 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 @@ -242,30 +246,26 @@ data TyVarDetails | InstTv -- Ditto, but instance decl | PatSigTv -- Scoped type variable, introduced by a pattern - -- type signature - -- \ x::a -> e + -- type signature \ x::a -> e | VanillaTv -- Everything else isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible -isUserTyVar tv = case mutTyVarDetails tv of +isUserTyVar tv = case tcTyVarDetails tv of VanillaTv -> False other -> True isSkolemTyVar :: TcTyVar -> Bool -isSkolemTyVar tv = case mutTyVarDetails tv of +isSkolemTyVar tv = case tcTyVarDetails tv of SigTv -> True ClsTv -> True InstTv -> True oteher -> False -tyVarBindingInfo :: TyVar -> SDoc -- Used in checkSigTyVars +tyVarBindingInfo :: TcTyVar -> SDoc -- Used in checkSigTyVars tyVarBindingInfo tv - | isMutTyVar tv - = sep [ptext SLIT("is bound by the") <+> details (mutTyVarDetails tv), + = sep [ptext SLIT("is bound by the") <+> details (tcTyVarDetails tv), ptext SLIT("at") <+> ppr (getSrcLoc tv)] - | otherwise - = empty where details SigTv = ptext SLIT("type signature") details ClsTv = ptext SLIT("class declaration") @@ -274,6 +274,9 @@ tyVarBindingInfo tv details VanillaTv = ptext SLIT("//vanilla//") -- Ditto \end{code} +\begin{code} +type TcTyVarSet = TyVarSet +\end{code} %************************************************************************ %* * @@ -768,6 +771,10 @@ restricted set of types as arguments and results (the restricting factor being the ) \begin{code} +isFFITy :: Type -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +isFFITy ty = checkRepTyCon legalFFITyCon ty + isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty @@ -907,6 +914,11 @@ legalOutgoingTyCon dflags safety tc | otherwise = marshalableTyCon dflags tc +legalFFITyCon :: TyCon -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +legalFFITyCon tc + = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon + marshalableTyCon dflags tc = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc) || boxedMarshalableTyCon tc @@ -1039,7 +1051,7 @@ uVarX tv1 ty2 k subst@(tmpls, env) uTysX ty1 ty2 k subst Nothing -- Not already bound - | typeKind ty2 `eqKind` tyVarKind tv1 + | typeKind ty2 == tyVarKind tv1 && occur_check_ok ty2 -> -- No kind mismatch nor occur check k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) @@ -1109,7 +1121,7 @@ match (TyVarTy v) ty tmpls k senv | v `elemVarSet` tmpls = -- v is a template variable case lookupSubstEnv senv v of - Nothing | typeKind ty `eqKind` tyVarKind v + Nothing | typeKind ty == 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