X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FTysWiredIn.lhs;h=ca4f9509a92652f1340a0f6415e85ff74cd9f371;hb=ea138284b7343bb1810cfbd0284a608dc57f7d46;hp=cd2c6eb950f6d8de309fe2a9ecf63f3bdcfbc6f8;hpb=f23ba2b294429ccbdeb80f0344ec08f6abf61bb7;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index cd2c6eb..ca4f950 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -16,6 +16,12 @@ module TysWiredIn ( addrDataCon, addrTy, addrTyCon, + ptrDataCon, + ptrTy, + ptrTyCon, + funPtrDataCon, + funPtrTy, + funPtrTyCon, boolTy, boolTyCon, charDataCon, @@ -24,24 +30,20 @@ module TysWiredIn ( consDataCon, doubleDataCon, doubleTy, - isDoubleTy, doubleTyCon, falseDataCon, falseDataConId, floatDataCon, floatTy, - isFloatTy, floatTyCon, intDataCon, intTy, intTyCon, - isIntTy, integerTy, integerTyCon, smallIntegerDataCon, largeIntegerDataCon, - isIntegerTy, listTyCon, @@ -69,15 +71,13 @@ module TysWiredIn ( wordTy, wordTyCon, - isFFIArgumentTy, -- :: Bool -> Type -> Bool - isFFIResultTy, -- :: Type -> Bool - isFFIExternalTy, -- :: Type -> Bool - isFFIDynArgumentTy, -- :: Type -> Bool - isFFIDynResultTy, -- :: Type -> Bool - isFFILabelTy, -- :: Type -> Bool - isAddrTy, -- :: Type -> Bool - isForeignObjTy -- :: Type -> Bool - + isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool + isFFIImportResultTy, -- :: DynFlags -> Type -> Bool + isFFIExportResultTy, -- :: Type -> Bool + isFFIExternalTy, -- :: Type -> Bool + isFFIDynArgumentTy, -- :: Type -> Bool + isFFIDynResultTy, -- :: Type -> Bool + isFFILabelTy, -- :: Type -> Bool ) where #include "HsVersions.h" @@ -90,24 +90,25 @@ import PrelNames import TysPrim -- others: +import ForeignCall ( Safety, playSafe ) import Constants ( mAX_TUPLE_SIZE ) import Module ( mkPrelModule ) import Name ( Name, nameRdrName, nameUnique, nameOccName, nameModule, mkWiredInName ) import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) import RdrName ( rdrNameOcc ) -import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId ) +import DataCon ( DataCon, mkDataCon, dataConId ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons, mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, - mkArrowKinds, boxedTypeKind, unboxedTypeKind, - splitTyConApp_maybe, repType, - TauType, ClassContext ) + mkArrowKinds, liftedTypeKind, unliftedTypeKind, + splitTyConApp_maybe, + TauType, ThetaType ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) import PrelNames import CmdLineOpts @@ -131,6 +132,8 @@ wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons data_tycons = genericTyCons ++ [ addrTyCon + , ptrTyCon + , funPtrTyCon , boolTyCon , charTyCon , doubleTyCon @@ -145,8 +148,8 @@ genericTyCons :: [TyCon] genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ] -tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ] -unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ] +tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..mAX_TUPLE_SIZE] ] +unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ] \end{code} @@ -168,16 +171,31 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons [] -- No context argvrcs cons - (length cons) + (length cons) + [] -- No record selectors new_or_data is_rec gen_info mod = nameModule name - kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind + kind = mkArrowKinds (map tyVarKind tyvars) liftedTypeKind gen_info = mk_tc_gen_info mod (nameUnique name) name tycon -pcDataCon :: Name -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon +-- We generate names for the generic to/from Ids by incrementing +-- the TyCon unique. So each Prelude tycon needs 3 slots, one +-- for itself and two more for the generic Ids. +mk_tc_gen_info mod tc_uniq tc_name tycon + = mkTyConGenInfo tycon [name1, name2] + where + tc_occ_name = nameOccName tc_name + occ_name1 = mkGenOcc1 tc_occ_name + occ_name2 = mkGenOcc2 tc_occ_name + fn1_key = incrUnique tc_uniq + fn2_key = incrUnique fn1_key + name1 = mkWiredInName mod occ_name1 fn1_key + name2 = mkWiredInName mod occ_name2 fn2_key + +pcDataCon :: Name -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon -- The unique is the first of two free uniques; -- the first is used for the datacon itself and the worker; -- the second is used for the wrapper. @@ -230,8 +248,8 @@ mk_tuple boxity arity = (tycon, tuple_con) tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info tc_name = mkWiredInName mod (mkOccFS tcName name_str) tc_uniq tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind - res_kind | isBoxed boxity = boxedTypeKind - | otherwise = unboxedTypeKind + res_kind | isBoxed boxity = liftedTypeKind + | otherwise = unliftedTypeKind tyvars | isBoxed boxity = take arity alphaTyVars | otherwise = take arity openAlphaTyVars @@ -245,18 +263,6 @@ mk_tuple boxity arity = (tycon, tuple_con) mod = mkPrelModule mod_name gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon -mk_tc_gen_info mod tc_uniq tc_name tycon - = gen_info - where - tc_occ_name = nameOccName tc_name - occ_name1 = mkGenOcc1 tc_occ_name - occ_name2 = mkGenOcc2 tc_occ_name - fn1_key = incrUnique tc_uniq - fn2_key = incrUnique fn1_key - name1 = mkWiredInName mod occ_name1 fn1_key - name2 = mkWiredInName mod occ_name2 fn2_key - gen_info = mkTyConGenInfo tycon name1 name2 - unitTyCon = tupleTyCon Boxed 0 unitDataConId = dataConId (head (tyConDataCons unitTyCon)) @@ -282,7 +288,7 @@ unboxedPairDataCon = tupleCon Unboxed 2 -- -- data Void = -- No constructors! -- --- ) It's boxed; there is only one value of this +-- ) It's lifted; there is only one value of this -- type, namely "void", whose semantics is just bottom. -- -- Haskell 98 drops the definition of a Void type, so we just 'simulate' @@ -305,13 +311,9 @@ intTy = mkTyConTy intTyCon intTyCon = pcNonRecDataTyCon intTyConName [] [] [intDataCon] intDataCon = pcDataCon intDataConName [] [] [intPrimTy] intTyCon - -isIntTy :: Type -> Bool -isIntTy = isTyCon intTyConKey \end{code} \begin{code} - wordTy = mkTyConTy wordTyCon wordTyCon = pcNonRecDataTyCon wordTyConName [] [] [wordDataCon] @@ -323,9 +325,20 @@ addrTy = mkTyConTy addrTyCon addrTyCon = pcNonRecDataTyCon addrTyConName [] [] [addrDataCon] addrDataCon = pcDataCon addrDataConName [] [] [addrPrimTy] addrTyCon +\end{code} + +\begin{code} +ptrTy = mkTyConTy ptrTyCon -isAddrTy :: Type -> Bool -isAddrTy = isTyCon addrTyConKey +ptrTyCon = pcNonRecDataTyCon ptrTyConName alpha_tyvar [(True,False)] [ptrDataCon] +ptrDataCon = pcDataCon ptrDataConName alpha_tyvar [] [addrPrimTy] ptrTyCon +\end{code} + +\begin{code} +funPtrTy = mkTyConTy funPtrTyCon + +funPtrTyCon = pcNonRecDataTyCon funPtrTyConName alpha_tyvar [(True,False)] [funPtrDataCon] +funPtrDataCon = pcDataCon funPtrDataConName alpha_tyvar [] [addrPrimTy] funPtrTyCon \end{code} \begin{code} @@ -333,17 +346,11 @@ floatTy = mkTyConTy floatTyCon floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] floatDataCon = pcDataCon floatDataConName [] [] [floatPrimTy] floatTyCon - -isFloatTy :: Type -> Bool -isFloatTy = isTyCon floatTyConKey \end{code} \begin{code} doubleTy = mkTyConTy doubleTyCon -isDoubleTy :: Type -> Bool -isDoubleTy = isTyCon doubleTyConKey - doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon] doubleDataCon = pcDataCon doubleDataConName [] [] [doublePrimTy] doubleTyCon \end{code} @@ -366,9 +373,16 @@ foreignObjTyCon foreignObjDataCon = pcDataCon foreignObjDataConName [] [] [foreignObjPrimTy] foreignObjTyCon +\end{code} -isForeignObjTy :: Type -> Bool -isForeignObjTy = isTyCon foreignObjTyConKey +\begin{code} +foreignPtrTyCon + = pcNonRecDataTyCon foreignPtrTyConName + alpha_tyvar [(True,False)] [foreignPtrDataCon] + where + foreignPtrDataCon + = pcDataCon foreignPtrDataConName + alpha_tyvar [] [foreignObjPrimTy] foreignPtrTyCon \end{code} %************************************************************************ @@ -389,10 +403,6 @@ smallIntegerDataCon = pcDataCon smallIntegerDataConName [] [] [intPrimTy] integerTyCon largeIntegerDataCon = pcDataCon largeIntegerDataConName [] [] [intPrimTy, byteArrayPrimTy] integerTyCon - - -isIntegerTy :: Type -> Bool -isIntegerTy = isTyCon integerTyConKey \end{code} @@ -407,48 +417,42 @@ restricted set of types as arguments and results (the restricting factor being the ) \begin{code} -isFFIArgumentTy :: DynFlags -> Bool -> Type -> Bool +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool -- Checks for valid argument type for a 'foreign import' -isFFIArgumentTy dflags is_safe ty - = checkRepTyCon (legalOutgoingTyCon dflags is_safe) ty +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 legalIncomingTyCon ty +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty -isFFIResultTy :: Type -> Bool --- Types that are allowed as a result of a 'foreign import' or of a 'foreign export' --- Maybe we should distinguish between import and export, but --- here we just choose the more restrictive 'incoming' predicate --- But we allow () as well -isFFIResultTy ty = checkRepTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) 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 either Addr, or --- a newtype of Addr. -isFFIDynArgumentTy = checkRepTyCon (== addrTyCon) +-- 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 either Addr, or --- a newtype of Addr. -isFFIDynResultTy = checkRepTyCon (== addrTyCon) +-- 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 either Addr, or --- a newtype of Addr. -isFFILabelTy = checkRepTyCon (== addrTyCon) +-- 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 -checkRepTyCon check_tc ty = checkTyCon check_tc (repType ty) - -checkTyCon :: (TyCon -> Bool) -> Type -> Bool -checkTyCon check_tc ty = case splitTyConApp_maybe ty of + -- Look through newtypes +checkRepTyCon check_tc ty = case splitTyConApp_maybe ty of Just (tycon, _) -> check_tc tycon Nothing -> False - -isTyCon :: Unique -> Type -> Bool -isTyCon uniq ty = checkTyCon (\tc -> uniq == getUnique tc) ty \end{code} ---------------------------------------------- @@ -456,25 +460,39 @@ These chaps do the work; they are not exported ---------------------------------------------- \begin{code} -legalIncomingTyCon :: TyCon -> Bool +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). -legalIncomingTyCon tc - | getUnique tc `elem` [ foreignObjTyConKey, byteArrayTyConKey, - mutableByteArrayTyConKey ] +legalFEArgTyCon tc + | getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey, + 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 -legalOutgoingTyCon :: DynFlags -> Bool -> TyCon -> Bool +legalFIResultTyCon :: DynFlags -> TyCon -> Bool +legalFIResultTyCon dflags tc + | getUnique tc `elem` + [ foreignObjTyConKey, foreignPtrTyConKey, + byteArrayTyConKey, mutableByteArrayTyConKey ] = False + | tc == unitTyCon = True + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Bool +legalFEResultTyCon tc + | getUnique tc `elem` + [ foreignObjTyConKey, foreignPtrTyConKey, + byteArrayTyConKey, mutableByteArrayTyConKey ] = False + | tc == unitTyCon = True + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool -- Checks validity of types going from Haskell -> external world --- The boolean is true for a 'safe' call (when we don't want to --- pass Haskell pointers to the world) -legalOutgoingTyCon dflags be_safe tc - | be_safe && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] +legalOutgoingTyCon dflags safety tc + | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey] = False | otherwise = marshalableTyCon dflags tc @@ -484,10 +502,14 @@ marshalableTyCon dflags tc || boxedMarshalableTyCon tc boxedMarshalableTyCon tc - = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey - , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey + = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey , floatTyConKey, doubleTyConKey - , addrTyConKey, charTyConKey, foreignObjTyConKey + , addrTyConKey, ptrTyConKey, funPtrTyConKey + , charTyConKey, foreignObjTyConKey + , foreignPtrTyConKey , stablePtrTyConKey , byteArrayTyConKey, mutableByteArrayTyConKey , boolTyConKey @@ -673,8 +695,3 @@ genUnitTyCon = pcNonRecDataTyCon genUnitTyConName [] [] [genUnitDataCon] genUnitDataCon :: DataCon genUnitDataCon = pcDataCon genUnitDataConName [] [] [] genUnitTyCon \end{code} - - - - -