[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)