[project @ 2003-02-18 20:15:15 by panne]

[ghc-base.git] / Foreign / ForeignPtr.hs

diff --git a/Foreign/ForeignPtr.hs b/Foreign/ForeignPtr.hs
index 0d49fbf..01969de 100644 (file)
--- a/Foreign/ForeignPtr.hs
+++ b/Foreign/ForeignPtr.hs
@@ -18,28 +18,58 @@
 module Foreign.ForeignPtr
         ( 
        -- * Finalised data pointers
-         ForeignPtr,            -- abstract, instance of: Eq
+         ForeignPtr             -- abstract, instance of: Eq, Ord, Show
         , newForeignPtr          -- :: Ptr a -> IO () -> IO (ForeignPtr a)
         , addForeignPtrFinalizer -- :: ForeignPtr a -> IO () -> IO ()
        , withForeignPtr         -- :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
        , foreignPtrToPtr        -- :: ForeignPtr a -> Ptr a
        , touchForeignPtr        -- :: ForeignPtr a -> IO ()
        , castForeignPtr         -- :: ForeignPtr a -> ForeignPtr b
+
+#ifndef __NHC__
+       , mallocForeignPtr      --  :: Storable a => IO (ForeignPtr a)
+       , mallocForeignPtrBytes --  :: Int -> IO (ForeignPtr a)
+       , mallocForeignPtrArray --  :: Storable a => Int -> IO (ForeignPtr a)
+       , mallocForeignPtrArray0 -- :: Storable a => Int -> IO (ForeignPtr a)
+#endif
         ) 
        where
 
+#ifndef __NHC__
 import Foreign.Ptr
+import Foreign.Storable
 import Data.Dynamic
+#endif
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
 import GHC.IOBase
 import GHC.Num
+import GHC.Ptr ( Ptr(..) )
 import GHC.Err
+import GHC.Show
+#endif
+
+#ifdef __NHC__
+import NHC.FFI
+  ( ForeignPtr
+  , newForeignPtr
+  , addForeignPtrFinalizer
+  , withForeignPtr
+  , foreignPtrToPtr
+  , touchForeignPtr
+  , castForeignPtr
+  )
 #endif
 
+#ifdef __HUGS__
+import Hugs.ForeignPtr
+#endif
+
+#ifndef __NHC__
 #include "Dynamic.h"
 INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+#endif
 
 #ifdef __GLASGOW_HASKELL__
 -- |The type 'ForeignPtr' represents references to objects that are
@@ -58,16 +88,19 @@ INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
 -- type argument of 'ForeignPtr' should normally be an instance of
 -- class 'Storable'.
 --
-data ForeignPtr a = ForeignPtr ForeignObj#
+data ForeignPtr a 
+  = ForeignPtr ForeignObj#
+  | MallocPtr  (MutableByteArray# RealWorld)
 
-instance CCallable (ForeignPtr a)
+instance Eq (ForeignPtr a) where 
+    p == q  =  foreignPtrToPtr p == foreignPtrToPtr q
 
-eqForeignPtr  :: ForeignPtr a -> ForeignPtr a -> Bool
-eqForeignPtr (ForeignPtr fo1#) (ForeignPtr fo2#) = eqForeignObj# fo1# fo2#
+instance Ord (ForeignPtr a) where 
+    compare p q  =  compare (foreignPtrToPtr p) (foreignPtrToPtr q)
+
+instance Show (ForeignPtr a) where
+    showsPrec p f = showsPrec p (foreignPtrToPtr f)
 
-instance Eq (ForeignPtr a) where 
-    p == q = eqForeignPtr p q
-    p /= q = not (eqForeignPtr p q)
 
 newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
 -- ^Turns a plain memory reference into a foreign object
@@ -84,12 +117,42 @@ newForeignPtr p finalizer
        addForeignPtrFinalizer fObj finalizer
        return fObj
 
+-- | allocates some memory and returns a ForeignPtr to it.  The memory
+-- will be released automatically when the ForeignPtr is discarded.
+--
+-- @mallocForeignPtr@ is equivalent to
+--
+-- >    do { p <- malloc; newForeignPtr p free }
+-- 
+-- although it may be implemented differently internally.  You may not
+-- assume that the memory returned by 'mallocForeignPtr' has been
+-- allocated with C's @malloc()@.
+
+mallocForeignPtr :: Storable a => IO (ForeignPtr a)
+mallocForeignPtr = doMalloc undefined
+  where doMalloc :: Storable a => a -> IO (ForeignPtr a)
+        doMalloc a = IO $ \s ->
+         case newPinnedByteArray# size s of { (# s, mbarr# #) ->
+          (# s, MallocPtr mbarr# #)
+          }
+         where (I# size) = sizeOf a
+
+-- | similar to 'mallocForeignPtr', except that the size of the memory required
+-- is given explicitly as a number of bytes.
+mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
+mallocForeignPtrBytes (I# size) = IO $ \s ->
+  case newPinnedByteArray# size s      of { (# s, mbarr# #) ->
+   (# s, MallocPtr mbarr# #)
+  }
+
 addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO ()
 -- ^This function adds another finaliser to the given
 -- foreign object.  No guarantees are made on the order in
 -- which multiple finalisers for a single object are run.
 addForeignPtrFinalizer (ForeignPtr fo) finalizer = 
   IO $ \s -> case mkWeak# fo () finalizer s of { (# s1, w #) -> (# s1, () #) }
+addForeignPtrFinalizer (MallocPtr fo) finalizer = 
+  IO $ \s -> case mkWeak# fo () finalizer s of { (# s1, w #) -> (# s1, () #) }
 
 mkForeignPtr :: Ptr a -> IO (ForeignPtr a) {- not exported -}
 mkForeignPtr (Ptr obj) =  IO ( \ s# ->
@@ -117,6 +180,8 @@ touchForeignPtr :: ForeignPtr a -> IO ()
 -- until the interior pointer is no longer referenced.
 touchForeignPtr (ForeignPtr fo) 
    = IO $ \s -> case touch# fo s of s -> (# s, () #)
+touchForeignPtr (MallocPtr fo) 
+   = IO $ \s -> case touch# fo s of s -> (# s, () #)
 
 withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
 -- ^This is a way to look at the pointer living inside a
@@ -159,10 +224,22 @@ foreignPtrToPtr :: ForeignPtr a -> Ptr a
 -- 'touchForeignPtr'.  However, the later routines
 -- are occasionally preferred in tool generated marshalling code.
 foreignPtrToPtr (ForeignPtr fo) = Ptr (foreignObjToAddr# fo)
+foreignPtrToPtr (MallocPtr  fo) = Ptr (byteArrayContents# (unsafeCoerce# fo))
 
 castForeignPtr :: ForeignPtr a -> ForeignPtr b
 -- ^This function casts a 'ForeignPtr'
 -- parameterised by one type into another type.
 castForeignPtr (ForeignPtr a) = ForeignPtr a
+castForeignPtr (MallocPtr  a) = MallocPtr  a
 #endif
 
+#ifndef __NHC__
+mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a)
+mallocForeignPtrArray  = doMalloc undefined
+  where
+    doMalloc            :: Storable a => a -> Int -> IO (ForeignPtr a)
+    doMalloc dummy size  = mallocForeignPtrBytes (size * sizeOf dummy)
+
+mallocForeignPtrArray0      :: Storable a => Int -> IO (ForeignPtr a)
+mallocForeignPtrArray0 size  = mallocForeignPtrArray (size + 1)
+#endif