X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=cd4fe1447b0efc303e8939f4910217c509a2718a;hb=a7d8f43718b167689c0a4a4c23b33a325e0239f1;hp=025f86187be71ebe2e104c868a31a46762005821;hpb=957bf3756ffd56f5329a2aabe1022d6f996dd641;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 025f861..cd4fe14 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, -------------------------------- @@ -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 @@ -123,7 +131,7 @@ import Type ( -- Re-exports mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, isUnLiftedType, isUnboxedTupleType, isPrimitiveType, - splitNewType_maybe, splitTyConApp_maybe, + splitTyConApp_maybe, tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, @@ -131,10 +139,13 @@ import Type ( -- Re-exports hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind, repType ) +import DataCon ( DataCon ) import TyCon ( TyCon, isUnLiftedTyCon ) 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 @@ -144,7 +155,8 @@ 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 ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon, + charTyCon, listTyCon ) import BasicTypes ( IPName(..), ipNameName ) import Unique ( Unique, Uniquable(..) ) import SrcLoc ( SrcLoc ) @@ -156,6 +168,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} %* * %************************************************************************ @@ -228,12 +260,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. -- @@ -265,14 +292,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 @@ -285,7 +304,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} @@ -825,10 +843,67 @@ isFFILabelTy :: Type -> Bool -- or a newtype of either. isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) +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 (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc | otherwise = False @@ -844,7 +919,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 @@ -853,22 +928,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 @@ -889,6 +962,10 @@ boxedMarshalableTyCon tc , byteArrayTyConKey, mutableByteArrayTyConKey , boolTyConKey ] + +isByteArrayLikeTyCon :: TyCon -> Bool +isByteArrayLikeTyCon tc = + getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] \end{code}