X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=9635d41b3891f08767934c5a5ecb88d6447d0aa7;hb=f5fbd41ca7f30e0f8db3f7b280a044d5af138428;hp=531709af92ec7f293d47188b0043345a88857aba;hpb=c92ddc55847b34d45f188f7c62092d69915a7a7d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 531709a..9635d41 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -16,13 +16,17 @@ is the principal client. \begin{code} module TcType ( -------------------------------- + -- TyThing + TyThing(..), -- instance NamedThing + + -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcKind, -------------------------------- -- TyVarDetails - TyVarDetails(..), isUserTyVar, isSkolemTyVar, isHoleTyVar, + TyVarDetails(..), isUserTyVar, isSkolemTyVar, tyVarBindingInfo, -------------------------------- @@ -35,7 +39,7 @@ module TcType ( tcSplitForAllTys, tcSplitPhiTy, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitSigmaTy, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy, tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar, --------------------------------- @@ -50,15 +54,15 @@ module TcType ( --------------------------------- -- Misc type manipulators - deNoteType, - namesOfType, namesOfDFunHead, + deNoteType, classNamesOfTheta, + tyClsNamesOfType, tyClsNamesOfDFunHead, getDFunTyKey, --------------------------------- -- Predicate types - PredType, getClassPredTys_maybe, getClassPredTys, + getClassPredTys_maybe, getClassPredTys, isPredTy, isClassPred, isTyVarClassPred, predHasFDs, - mkDictTy, tcSplitPredTy_maybe, predTyUnique, + mkDictTy, tcSplitPredTy_maybe, isDictTy, tcSplitDFunTy, predTyUnique, mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, @@ -71,6 +75,10 @@ module TcType ( isFFIDynArgumentTy, -- :: Type -> Bool isFFIDynResultTy, -- :: Type -> Bool isFFILabelTy, -- :: Type -> Bool + isFFIDotnetTy, -- :: DynFlags -> Type -> Bool + isFFIDotnetObjTy, -- :: Type -> Bool + + toDNType, -- :: Type -> DNType --------------------------------- -- Unifier and matcher @@ -96,7 +104,7 @@ module TcType ( tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, - typeKind, eqKind, eqUsage, + typeKind, eqKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta ) where @@ -105,28 +113,39 @@ module TcType ( import {-# SOURCE #-} PprType( pprType ) +-- PprType imports TcType so that it can print intelligently -- friends: 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, + 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 + mkTyConApp, mkGenTyConApp, mkAppTy, + mkAppTys, mkSynTy, applyTy, applyTys, + mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, + mkPredTys, isUnLiftedType, + isUnboxedTupleType, isPrimitiveType, + splitTyConApp_maybe, + tidyTopType, tidyType, tidyPred, tidyTypes, + tidyFreeTyVars, tidyOpenType, tidyOpenTypes, + tidyTyVarBndr, tidyOpenTyVar, + tidyOpenTyVars, eqKind, + hasMoreBoxityInfo, liftedBoxity, + superBoxity, typeKind, superKind, repType ) -import TyCon ( TyCon, isUnLiftedTyCon ) +import DataCon ( DataCon ) +import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) import Class ( classHasFDs, Class ) -import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) -import ForeignCall ( Safety, playSafe ) +import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails ) +import ForeignCall ( Safety, playSafe + , DNType(..) + ) import VarEnv import VarSet @@ -136,11 +155,11 @@ import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) import OccName ( OccName, mkDictOcc ) import NameSet import PrelNames -- Lots (e.g. in isFFIArgumentTy) -import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon ) +import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) import BasicTypes ( IPName(..), ipNameName ) import Unique ( Unique, Uniquable(..) ) import SrcLoc ( SrcLoc ) -import Util ( cmpList, thenCmp, equalLength ) +import Util ( cmpList, thenCmp, equalLength, snocView ) import Maybes ( maybeToBool, expectJust ) import Outputable \end{code} @@ -148,6 +167,26 @@ import Outputable %************************************************************************ %* * + TyThing +%* * +%************************************************************************ + +\begin{code} +data TyThing = AnId Id + | ADataCon DataCon + | ATyCon TyCon + | AClass Class + +instance NamedThing TyThing where + getName (AnId id) = getName id + getName (ATyCon tc) = getName tc + getName (AClass cl) = getName cl + getName (ADataCon dc) = getName dc +\end{code} + + +%************************************************************************ +%* * \subsection{Types} %* * %************************************************************************ @@ -220,12 +259,7 @@ why Var.lhs shouldn't actually have the definition, but it "belongs" here. \begin{code} 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, + = 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. -- @@ -257,14 +291,6 @@ isSkolemTyVar tv = case mutTyVarDetails tv of 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 @@ -277,7 +303,6 @@ tyVarBindingInfo tv 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} @@ -404,21 +429,26 @@ tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) 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 (SourceTy (NType tc tys)) = tc_split_app tc tys - --- Don't forget that newtype! +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 tcSplitAppTy_maybe other = Nothing -tc_split_app tc [] = Nothing -tc_split_app tc tys = split tys [] - where - split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) - split (ty:tys) acc = split tys (ty:acc) +tc_split_app tc tys = case snocView tys of + Just (tys',ty') -> Just (TyConApp tc tys', ty') + Nothing -> Nothing tcSplitAppTy ty = case tcSplitAppTy_maybe ty of Just stuff -> stuff Nothing -> pprPanic "tcSplitAppTy" (pprType ty) +tcSplitAppTys :: Type -> (Type, [Type]) +tcSplitAppTys ty + = go ty [] + where + go ty args = case tcSplitAppTy_maybe ty of + Just (ty', arg) -> go ty' (arg:args) + Nothing -> (ty,args) + tcGetTyVar_maybe :: Type -> Maybe TyVar tcGetTyVar_maybe (TyVarTy tv) = Just tv tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t @@ -436,8 +466,7 @@ The type of a method for class C is always of the form: where sig_ty is the type given by the method's signature, and thus in general is a ForallTy. At the point that splitMethodTy is called, it is expected that the outer Forall has already been stripped off. splitMethodTy then -returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or -Usages stripped off. +returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off. \begin{code} tcSplitMethodTy :: Type -> (PredType, Type) @@ -736,34 +765,38 @@ 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 -This is used in the front end of the compiler +Find the free tycons and classes of a type. This is used in the front +end of the compiler. \begin{code} -namesOfType :: Type -> NameSet -namesOfType (TyVarTy tv) = unitNameSet (getName tv) -namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` namesOfTypes tys -namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1 -namesOfType (NoteTy other_note ty2) = namesOfType ty2 -namesOfType (SourceTy (IParam n ty)) = namesOfType ty -namesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` namesOfTypes tys -namesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` namesOfTypes tys -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 - -namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys - -namesOfDFunHead :: Type -> NameSet +tyClsNamesOfType :: Type -> NameSet +tyClsNamesOfType (TyVarTy tv) = emptyNameSet +tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1 +tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2 +tyClsNamesOfType (SourceTy (IParam n ty)) = tyClsNamesOfType ty +tyClsNamesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res +tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg +tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty + +tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys + +tyClsNamesOfDFunHead :: Type -> NameSet -- Find the free type constructors and classes -- of the head of the dfun instance type -- The 'dfun_head_type' is because of -- instance Foo a => Baz T where ... -- The decl is an orphan if Baz and T are both not locally defined, -- even if Foo *is* locally defined -namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of - (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty) - (map getName tvs) +tyClsNamesOfDFunHead dfun_ty + = case tcSplitSigmaTy dfun_ty of + (tvs,_,head_ty) -> tyClsNamesOfType head_ty + +classNamesOfTheta :: ThetaType -> [Name] +-- Looks just for ClassP things; maybe it should check +classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ] \end{code} @@ -797,26 +830,87 @@ 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) +isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey] 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) +isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey] 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) +isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey] + +isFFIDotnetTy :: DynFlags -> Type -> Bool +isFFIDotnetTy dflags ty + = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) && + (legalFIResultTyCon dflags tc || + isFFIDotnetObjTy ty || isStringTy ty)) ty + +-- Support String as an argument or result from a .NET FFI call. +isStringTy ty = + case tcSplitTyConApp_maybe (repType ty) of + Just (tc, [arg_ty]) + | tc == listTyCon -> + case tcSplitTyConApp_maybe (repType arg_ty) of + Just (cc,[]) -> cc == charTyCon + _ -> False + _ -> False + +-- Support String as an argument or result from a .NET FFI call. +isFFIDotnetObjTy ty = + let + (_, t_ty) = tcSplitForAllTys ty + in + case tcSplitTyConApp_maybe (repType t_ty) of + Just (tc, [arg_ty]) | getName tc == objectTyConName -> True + _ -> False + +toDNType :: Type -> DNType +toDNType ty + | isStringTy ty = DNString + | isFFIDotnetObjTy ty = DNObject + | Just (tc,argTys) <- tcSplitTyConApp_maybe ty = + case lookup (getUnique tc) dn_assoc of + Just x -> x + Nothing + | tc `hasKey` ioTyConKey -> toDNType (head argTys) + | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc) + where + dn_assoc :: [ (Unique, DNType) ] + dn_assoc = [ (unitTyConKey, DNUnit) + , (intTyConKey, DNInt) + , (int8TyConKey, DNInt8) + , (int16TyConKey, DNInt16) + , (int32TyConKey, DNInt32) + , (int64TyConKey, DNInt64) + , (wordTyConKey, DNInt) + , (word8TyConKey, DNWord8) + , (word16TyConKey, DNWord16) + , (word32TyConKey, DNWord32) + , (word64TyConKey, DNWord64) + , (floatTyConKey, DNFloat) + , (doubleTyConKey, DNDouble) + , (addrTyConKey, DNPtr) + , (ptrTyConKey, DNPtr) + , (funPtrTyConKey, DNPtr) + , (charTyConKey, DNChar) + , (boolTyConKey, DNBool) + ] checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- Look through newtypes -- Non-recursive ones are transparent to splitTyConApp, - -- but recursive ones aren't; hence the splitNewType_maybe + -- but recursive ones aren't checkRepTyCon check_tc ty - | Just ty' <- splitNewType_maybe ty = checkRepTyCon check_tc ty' - | Just (tc,_) <- splitTyConApp_maybe ty = check_tc tc - | otherwise = False + | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc + | otherwise = False + +checkRepTyConKey :: [Unique] -> Type -> Bool +-- Like checkRepTyCon, but just looks at the TyCon key +checkRepTyConKey keys + = checkRepTyCon (\tc -> tyConUnique tc `elem` keys) \end{code} ---------------------------------------------- @@ -829,7 +923,7 @@ legalFEArgTyCon :: TyCon -> Bool -- bytearrays from a _ccall_ / foreign declaration -- (or be passed them as arguments in foreign exported functions). legalFEArgTyCon tc - | getUnique tc `elem` [ byteArrayTyConKey, mutableByteArrayTyConKey ] + | isByteArrayLikeTyCon tc = 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 @@ -838,22 +932,20 @@ legalFEArgTyCon tc legalFIResultTyCon :: DynFlags -> TyCon -> Bool legalFIResultTyCon dflags tc - | getUnique tc `elem` - [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False - | tc == unitTyCon = True - | otherwise = marshalableTyCon dflags tc + | isByteArrayLikeTyCon tc = 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 + | isByteArrayLikeTyCon tc = 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] + | playSafe safety && isByteArrayLikeTyCon tc = False | otherwise = marshalableTyCon dflags tc @@ -874,6 +966,10 @@ boxedMarshalableTyCon tc , byteArrayTyConKey, mutableByteArrayTyConKey , boolTyConKey ] + +isByteArrayLikeTyCon :: TyCon -> Bool +isByteArrayLikeTyCon tc = + getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] \end{code}