Commit 21c60059 authored by panne's avatar panne
Browse files

[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.
parent d37c0740
......@@ -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}
%************************************************************************
......
......@@ -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
......@@ -343,6 +347,13 @@ 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}
floatTy = mkTyConTy floatTyCon
......@@ -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
......
-----------------------------------------------------------------------------
-- $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)
......
% -----------------------------------------------------------------------------
% $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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment