X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FTysWiredIn.lhs;h=f67ee0676d3700216e2521030f7b0f4636eed278;hb=eb29a057feb42c082896ff9a28831a12aec0b9ee;hp=c63d3e193caab25ed775ff173cef3e1c0dbb10e6;hpb=c271b64780a6504e7ccd4cc422dfc90678ea966f;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index c63d3e1..f67ee06 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -16,6 +16,9 @@ module TysWiredIn ( addrDataCon, addrTy, addrTyCon, + ptrDataCon, + ptrTy, + ptrTyCon, boolTy, boolTyCon, charDataCon, @@ -69,14 +72,15 @@ 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 -> Bool -> Type -> Bool + isFFIImportResultTy, -- :: DynFlags -> Type -> Bool + isFFIExportResultTy, -- :: Type -> Bool + isFFIExternalTy, -- :: Type -> Bool + isFFIDynArgumentTy, -- :: Type -> Bool + isFFIDynResultTy, -- :: Type -> Bool + isFFILabelTy, -- :: Type -> Bool + isAddrTy, -- :: Type -> Bool + isForeignPtrTy -- :: Type -> Bool ) where @@ -105,9 +109,9 @@ import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons, import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, - mkArrowKinds, boxedTypeKind, unboxedTypeKind, + mkArrowKinds, liftedTypeKind, unliftedTypeKind, splitTyConApp_maybe, repType, - TauType, ClassContext ) + TauType, ThetaType ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) import PrelNames import CmdLineOpts @@ -131,6 +135,7 @@ wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons data_tycons = genericTyCons ++ [ addrTyCon + , ptrTyCon , boolTyCon , charTyCon , doubleTyCon @@ -175,10 +180,24 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons 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. @@ -231,8 +250,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 @@ -246,18 +265,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)) @@ -283,7 +290,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' @@ -330,6 +337,13 @@ isAddrTy = isTyCon addrTyConKey \end{code} \begin{code} +ptrTy = mkTyConTy ptrTyCon + +ptrTyCon = pcNonRecDataTyCon ptrTyConName alpha_tyvar [(True,False)] [ptrDataCon] +ptrDataCon = pcDataCon ptrDataConName alpha_tyvar [] [addrPrimTy] ptrTyCon +\end{code} + +\begin{code} floatTy = mkTyConTy floatTyCon floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] @@ -372,6 +386,19 @@ isForeignObjTy :: Type -> Bool isForeignObjTy = isTyCon foreignObjTyConKey \end{code} +\begin{code} +foreignPtrTyCon + = pcNonRecDataTyCon foreignPtrTyConName + alpha_tyvar [(True,False)] [foreignPtrDataCon] + where + foreignPtrDataCon + = pcDataCon foreignPtrDataConName + alpha_tyvar [] [foreignObjPrimTy] foreignPtrTyCon + +isForeignPtrTy :: Type -> Bool +isForeignPtrTy = isTyCon foreignPtrTyConKey +\end{code} + %************************************************************************ %* * \subsection[TysWiredIn-Integer]{@Integer@ and its related ``pairing'' types} @@ -415,29 +442,29 @@ isFFIArgumentTy dflags is_safe ty isFFIExternalTy :: Type -> Bool -- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalIncomingTyCon ty +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty + +isFFIImportResultTy :: DynFlags -> Type -> Bool +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) 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 +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, Addr, +-- or a newtype of either. +isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || 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, Addr, +-- or a newtype of either. +isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || 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, Addr, +-- or a newtype of either. +isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == addrTyCon) checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- look through newtypes @@ -457,19 +484,35 @@ 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 +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 -> Bool -> 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 @@ -485,10 +528,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 + , charTyConKey, foreignObjTyConKey + , foreignPtrTyConKey , stablePtrTyConKey , byteArrayTyConKey, mutableByteArrayTyConKey , boolTyConKey @@ -674,8 +721,3 @@ genUnitTyCon = pcNonRecDataTyCon genUnitTyConName [] [] [genUnitDataCon] genUnitDataCon :: DataCon genUnitDataCon = pcDataCon genUnitDataConName [] [] [] genUnitTyCon \end{code} - - - - -