From: panne Date: Fri, 13 Apr 2001 21:37:43 +0000 (+0000) Subject: [project @ 2001-04-13 21:37:42 by panne] X-Git-Tag: Approximately_9120_patches~2157 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=21c60059fff93a95ab5bcec60dd4f2edb8f7b23f;p=ghc-hetmet.git [project @ 2001-04-13 21:37:42 by panne] First steps toward a better typing of f.e.d. and friends: Make FunPtr a fully-fledged data type, not a renaming for Ptr. This is necessary, because the FFI "looks through" newtypes, which we don't want in this case. --- diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index ba20d43..cf0d3bf 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -482,6 +482,9 @@ addrDataConName = dataQual aDDR_Name SLIT("A#") addrDataConKey ptrTyConName = tcQual pREL_PTR_Name SLIT("Ptr") ptrTyConKey ptrDataConName = dataQual pREL_PTR_Name SLIT("Ptr") ptrDataConKey +funPtrTyConName = tcQual pREL_PTR_Name SLIT("FunPtr") funPtrTyConKey +funPtrDataConName = dataQual pREL_PTR_Name SLIT("FunPtr") funPtrDataConKey + -- Byte array types byteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("ByteArray") byteArrayTyConKey mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") mutableByteArrayTyConKey @@ -736,16 +739,17 @@ typeConKey = mkPreludeTyConUnique 69 threadIdPrimTyConKey = mkPreludeTyConUnique 70 bcoPrimTyConKey = mkPreludeTyConUnique 71 ptrTyConKey = mkPreludeTyConUnique 72 +funPtrTyConKey = mkPreludeTyConUnique 73 -- Usage type constructors -usageConKey = mkPreludeTyConUnique 73 -usOnceTyConKey = mkPreludeTyConUnique 74 -usManyTyConKey = mkPreludeTyConUnique 75 +usageConKey = mkPreludeTyConUnique 74 +usOnceTyConKey = mkPreludeTyConUnique 75 +usManyTyConKey = mkPreludeTyConUnique 76 -- Generic Type Constructors -crossTyConKey = mkPreludeTyConUnique 76 -plusTyConKey = mkPreludeTyConUnique 77 -genUnitTyConKey = mkPreludeTyConUnique 78 +crossTyConKey = mkPreludeTyConUnique 77 +plusTyConKey = mkPreludeTyConUnique 78 +genUnitTyConKey = mkPreludeTyConUnique 79 \end{code} %************************************************************************ @@ -774,12 +778,13 @@ trueDataConKey = mkPreludeDataConUnique 15 wordDataConKey = mkPreludeDataConUnique 16 ioDataConKey = mkPreludeDataConUnique 17 ptrDataConKey = mkPreludeDataConUnique 18 +funPtrDataConKey = mkPreludeDataConUnique 19 -- Generic data constructors -crossDataConKey = mkPreludeDataConUnique 19 -inlDataConKey = mkPreludeDataConUnique 20 -inrDataConKey = mkPreludeDataConUnique 21 -genUnitDataConKey = mkPreludeDataConUnique 22 +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index f67ee06..b0ebb94 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -19,6 +19,9 @@ module TysWiredIn ( ptrDataCon, ptrTy, ptrTyCon, + funPtrDataCon, + funPtrTy, + funPtrTyCon, boolTy, boolTyCon, charDataCon, @@ -136,6 +139,7 @@ wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons data_tycons = genericTyCons ++ [ addrTyCon , ptrTyCon + , funPtrTyCon , boolTyCon , charTyCon , doubleTyCon @@ -344,6 +348,13 @@ 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} floatTy = mkTyConTy floatTyCon floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] @@ -452,19 +463,19 @@ isFFIExportResultTy :: Type -> Bool isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty isFFIDynArgumentTy :: Type -> Bool --- The argument type of a foreign import dynamic must be Ptr, Addr, +-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr, -- or a newtype of either. -isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == addrTyCon) +isFFIDynArgumentTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) isFFIDynResultTy :: Type -> Bool --- The result type of a foreign export dynamic must be Ptr, Addr, +-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr, -- or a newtype of either. -isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == addrTyCon) +isFFIDynResultTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) isFFILabelTy :: Type -> Bool --- The type of a foreign label must be Ptr, Addr, +-- The type of a foreign label must be Ptr, FunPtr, Addr, -- or a newtype of either. -isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == addrTyCon) +isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- look through newtypes @@ -533,7 +544,7 @@ boxedMarshalableTyCon tc , wordTyConKey, word8TyConKey, word16TyConKey , word32TyConKey, word64TyConKey , floatTyConKey, doubleTyConKey - , addrTyConKey, ptrTyConKey + , addrTyConKey, ptrTyConKey, funPtrTyConKey , charTyConKey, foreignObjTyConKey , foreignPtrTyConKey , stablePtrTyConKey diff --git a/ghc/lib/std/PrelPtr.lhs b/ghc/lib/std/PrelPtr.lhs index 00a277a..e81e960 100644 --- a/ghc/lib/std/PrelPtr.lhs +++ b/ghc/lib/std/PrelPtr.lhs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: PrelPtr.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $ +-- $Id: PrelPtr.lhs,v 1.2 2001/04/13 21:37:43 panne Exp $ -- -- (c) 2000 -- @@ -41,19 +41,19 @@ instance CReturnable (Ptr a) ------------------------------------------------------------------------ -- Function pointers for the default calling convention. -newtype FunPtr a = FunPtr (Ptr a) deriving (Eq, Ord) +data FunPtr a = FunPtr Addr# deriving (Eq, Ord) nullFunPtr :: FunPtr a -nullFunPtr = FunPtr nullPtr +nullFunPtr = FunPtr (int2Addr# 0#) castFunPtr :: FunPtr a -> FunPtr b -castFunPtr (FunPtr a) = FunPtr (castPtr a) +castFunPtr (FunPtr addr) = FunPtr addr castFunPtrToPtr :: FunPtr a -> Ptr b -castFunPtrToPtr (FunPtr a) = castPtr a +castFunPtrToPtr (FunPtr addr) = Ptr addr castPtrToFunPtr :: Ptr a -> FunPtr b -castPtrToFunPtr a = FunPtr (castPtr a) +castPtrToFunPtr (Ptr addr) = FunPtr addr instance CCallable (FunPtr a) instance CReturnable (FunPtr a) diff --git a/ghc/lib/std/PrelStorable.lhs b/ghc/lib/std/PrelStorable.lhs index 0786954..7f38256 100644 --- a/ghc/lib/std/PrelStorable.lhs +++ b/ghc/lib/std/PrelStorable.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelStorable.lhs,v 1.4 2001/03/13 21:21:27 qrczak Exp $ +% $Id: PrelStorable.lhs,v 1.5 2001/04/13 21:37:43 panne Exp $ % % (c) The FFI task force, 2000 % @@ -93,12 +93,6 @@ instance Storable Bool where peekElemOff p i = liftM (/= (0::CInt)) $ peekElemOff (castPtr p) i pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::CInt) -instance Storable (FunPtr a) where - sizeOf (FunPtr x) = sizeOf x - alignment (FunPtr x) = alignment x - peekElemOff p i = liftM FunPtr $ peekElemOff (castPtr p) i - pokeElemOff p i (FunPtr x) = pokeElemOff (castPtr p) i x - #define STORABLE(T,size,align,read,write) \ instance Storable (T) where { \ sizeOf _ = size; \ @@ -118,6 +112,9 @@ STORABLE(Word,SIZEOF_LONG,ALIGNMENT_LONG, STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, readPtrOffPtr,writePtrOffPtr) +STORABLE((FunPtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, + readFunPtrOffPtr,writeFunPtrOffPtr) + STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P, readStablePtrOffPtr,writeStablePtrOffPtr) @@ -189,6 +186,7 @@ readWideCharOffPtr :: Ptr Char -> Int -> IO Char readIntOffPtr :: Ptr Int -> Int -> IO Int readWordOffPtr :: Ptr Word -> Int -> IO Word readPtrOffPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a) +readFunPtrOffPtr :: Ptr (FunPtr a) -> Int -> IO (FunPtr a) readFloatOffPtr :: Ptr Float -> Int -> IO Float readDoubleOffPtr :: Ptr Double -> Int -> IO Double readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a) @@ -209,6 +207,8 @@ readWordOffPtr (Ptr a) (I# i) = IO $ \s -> case readWordOffAddr# a i s of (# s2, x #) -> (# s2, W# x #) readPtrOffPtr (Ptr a) (I# i) = IO $ \s -> case readAddrOffAddr# a i s of (# s2, x #) -> (# s2, Ptr x #) +readFunPtrOffPtr (Ptr a) (I# i) + = IO $ \s -> case readAddrOffAddr# a i s of (# s2, x #) -> (# s2, FunPtr x #) readFloatOffPtr (Ptr a) (I# i) = IO $ \s -> case readFloatOffAddr# a i s of (# s2, x #) -> (# s2, F# x #) readDoubleOffPtr (Ptr a) (I# i) @@ -236,6 +236,7 @@ writeWideCharOffPtr :: Ptr Char -> Int -> Char -> IO () writeIntOffPtr :: Ptr Int -> Int -> Int -> IO () writeWordOffPtr :: Ptr Word -> Int -> Word -> IO () writePtrOffPtr :: Ptr (Ptr a) -> Int -> Ptr a -> IO () +writeFunPtrOffPtr :: Ptr (FunPtr a) -> Int -> FunPtr a -> IO () writeFloatOffPtr :: Ptr Float -> Int -> Float -> IO () writeDoubleOffPtr :: Ptr Double -> Int -> Double -> IO () writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO () @@ -256,6 +257,8 @@ writeWordOffPtr (Ptr a) (I# i) (W# x) = IO $ \s -> case writeWordOffAddr# a i x s of s2 -> (# s2, () #) writePtrOffPtr (Ptr a) (I# i) (Ptr x) = IO $ \s -> case writeAddrOffAddr# a i x s of s2 -> (# s2, () #) +writeFunPtrOffPtr (Ptr a) (I# i) (FunPtr x) + = IO $ \s -> case writeAddrOffAddr# a i x s of s2 -> (# s2, () #) writeFloatOffPtr (Ptr a) (I# i) (F# x) = IO $ \s -> case writeFloatOffAddr# a i x s of s2 -> (# s2, () #) writeDoubleOffPtr (Ptr a) (I# i) (D# x)