X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=GHC%2FForeignPtr.hs;h=bb74f0b1d652b6b410fd9d5e017bd8d022443f30;hb=4b26136ab82fb1ff12e49477c4833a9586d368c5;hp=ea512e4a70b92a172fd757c0b7acd815e67bc8ae;hpb=e7b22a27c59776513e3038ea717fd66fa5772770;p=haskell-directory.git

diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs
index ea512e4..bb74f0b 100644
--- a/GHC/ForeignPtr.hs
+++ b/GHC/ForeignPtr.hs
@@ -20,7 +20,9 @@ module GHC.ForeignPtr
 	FinalizerPtr,
 	newForeignPtr_,
 	mallocForeignPtr,
+	mallocPlainForeignPtr,
 	mallocForeignPtrBytes,
+	mallocPlainForeignPtrBytes,
 	addForeignPtrFinalizer,	
 	touchForeignPtr,
 	unsafeForeignPtrToPtr,
@@ -31,15 +33,17 @@ module GHC.ForeignPtr
   ) where
 
 import Control.Monad 	( sequence_ )
-import Foreign.Ptr
 import Foreign.Storable
+import Numeric		( showHex )
 
+import GHC.Show
+import GHC.Num
+import GHC.List  	( null, replicate, length )
 import GHC.Base
 import GHC.IOBase
 import GHC.STRef	( STRef(..) )
-import GHC.Ptr		( Ptr(..) )
+import GHC.Ptr		( Ptr(..), FunPtr, castFunPtrToPtr )
 import GHC.Err
-import GHC.Show
 
 -- |The type 'ForeignPtr' represents references to objects that are
 -- maintained in a foreign language, i.e., that are not part of the
@@ -68,14 +72,10 @@ data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents
 	-- object, because that ensures that whatever the finalizer is
 	-- attached to is kept alive.
 
-data ForeignPtrContents 
-  = PlainNoFinalizer
-  | PlainWithFinalizer     !(IORef [IO ()])
-  | MallocPtrNoFinalizer   (MutableByteArray# RealWorld)
-  | MallocPtrWithFinalizer (MutableByteArray# RealWorld) !(IORef [IO ()])
-  -- we optimise the no-finalizer case, which is especially common
-  -- with a MallocPtr.  mallocForeignPtr doesn't have to create an
-  -- IORef, or set up a weak pointer.
+data ForeignPtrContents
+  = PlainForeignPtr !(IORef [IO ()])
+  | MallocPtr      (MutableByteArray# RealWorld) !(IORef [IO ()])
+  | PlainPtr       (MutableByteArray# RealWorld)
 
 instance Eq (ForeignPtr a) where
     p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q
@@ -86,6 +86,7 @@ instance Ord (ForeignPtr a) where
 instance Show (ForeignPtr a) where
     showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)
 
+
 -- |A Finalizer is represented as a pointer to a foreign function that, at
 -- finalisation time, gets as an argument a plain pointer variant of the
 -- foreign pointer that the finalizer is associated with.
@@ -125,13 +126,22 @@ mallocForeignPtr :: Storable a => IO (ForeignPtr a)
 -- although it may be implemented differently internally: you may not
 -- assume that the memory returned by 'mallocForeignPtr' has been
 -- allocated with 'Foreign.Marshal.Alloc.malloc'.
+--
+-- GHC notes: 'mallocForeignPtr' has a heavily optimised
+-- implementation in GHC.  It uses pinned memory in the garbage
+-- collected heap, so the 'ForeignPtr' does not require a finalizer to
+-- free the memory.  Use of 'mallocForeignPtr' and associated
+-- functions is strongly recommended in preference to 'newForeignPtr'
+-- with a finalizer.
+-- 
 mallocForeignPtr = doMalloc undefined
   where doMalloc :: Storable b => b -> IO (ForeignPtr b)
         doMalloc a = do
+  	  r <- newIORef []
 	  IO $ \s ->
 	    case newPinnedByteArray# size s of { (# s, mbarr# #) ->
 	     (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
-		     	      (MallocPtrNoFinalizer mbarr#) #)
+		     	      (MallocPtr mbarr# r) #)
             }
 	    where (I# size) = sizeOf a
 
@@ -139,10 +149,45 @@ mallocForeignPtr = doMalloc undefined
 -- size of the memory required is given explicitly as a number of bytes.
 mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
 mallocForeignPtrBytes (I# size) = do 
+  r <- newIORef []
   IO $ \s ->
      case newPinnedByteArray# size s      of { (# s, mbarr# #) ->
        (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
-		        (MallocPtrNoFinalizer mbarr#) #)
+		        (MallocPtr mbarr# r) #)
+     }
+
+-- | Allocate some memory and return a 'ForeignPtr' to it.  The memory
+-- will be released automatically when the 'ForeignPtr' is discarded.
+--
+-- GHC notes: 'mallocPlainForeignPtr' has a heavily optimised
+-- implementation in GHC.  It uses pinned memory in the garbage
+-- collected heap, as for mallocForeignPtr. Unlike mallocForeignPtr, a
+-- ForeignPtr created with mallocPlainForeignPtr carries no finalizers.
+-- It is not possible to add a finalizer to a ForeignPtr created with
+-- mallocPlainForeignPtr. This is useful for ForeignPtrs that will live
+-- only inside Haskell (such as those created for packed strings).
+-- Attempts to add a finalizer to a ForeignPtr created this way, or to
+-- finalize such a pointer, will throw an exception.
+-- 
+mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a)
+mallocPlainForeignPtr = doMalloc undefined
+  where doMalloc :: Storable b => b -> IO (ForeignPtr b)
+        doMalloc a = IO $ \s ->
+            case newPinnedByteArray# size s of { (# s, mbarr# #) ->
+             (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
+                              (PlainPtr mbarr#) #)
+            }
+            where (I# size) = sizeOf a
+
+-- | This function is similar to 'mallocForeignPtrBytes', except that
+-- the internally an optimised ForeignPtr representation with no
+-- finalizer is used. Attempts to add a finalizer will cause an
+-- exception to be thrown.
+mallocPlainForeignPtrBytes :: Int -> IO (ForeignPtr a)
+mallocPlainForeignPtrBytes (I# size) = IO $ \s ->
+    case newPinnedByteArray# size s      of { (# s, mbarr# #) ->
+       (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
+                        (PlainPtr mbarr#) #)
      }
 
 addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()
@@ -171,26 +216,26 @@ addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()
 addForeignPtrConcFinalizer (ForeignPtr a c) finalizer = 
   addForeignPtrConcFinalizer_ c finalizer
 
-addForeignPtrConcFinalizer_ PlainNoFinalizer finalizer = do
-  r <- newIORef []
-  IO $ \s ->  case r of { IORef (STRef r#) ->
+addForeignPtrConcFinalizer_ f@(PlainForeignPtr r) finalizer = do
+  fs <- readIORef r
+  writeIORef r (finalizer : fs)
+  if (null fs)
+     then IO $ \s ->
+	      case r of { IORef (STRef r#) ->
 	      case mkWeak# r# () (foreignPtrFinalizer r) s of {  (# s1, w #) ->
 	      (# s1, () #) }}
-  addForeignPtrConcFinalizer_ (PlainWithFinalizer r) finalizer
-
-addForeignPtrConcFinalizer_ f@(PlainWithFinalizer r) finalizer = do
+     else return ()
+addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do 
   fs <- readIORef r
   writeIORef r (finalizer : fs)
-
-addForeignPtrConcFinalizer_ f@(MallocPtrNoFinalizer fo) finalizer = do
-  r <- newIORef []
-  IO $ \s -> case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of
+  if (null fs)
+     then  IO $ \s -> 
+	       case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of
 		  (# s1, w #) -> (# s1, () #)
-  addForeignPtrConcFinalizer_ (MallocPtrWithFinalizer fo r) finalizer
+     else return ()
 
-addForeignPtrConcFinalizer_ f@(MallocPtrWithFinalizer fo r) finalizer = do 
-  fs <- readIORef r
-  writeIORef r (finalizer : fs)
+addForeignPtrConcFinalizer_ _ _ =
+  error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"
 
 foreign import ccall "dynamic" 
   mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()
@@ -201,7 +246,9 @@ foreignPtrFinalizer r = do fs <- readIORef r; sequence_ fs
 newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)
 -- ^Turns a plain memory reference into a foreign pointer that may be
 -- associated with finalizers by using 'addForeignPtrFinalizer'.
-newForeignPtr_ (Ptr obj) = return (ForeignPtr obj PlainNoFinalizer)
+newForeignPtr_ (Ptr obj) =  do
+  r <- newIORef []
+  return (ForeignPtr obj (PlainForeignPtr r))
 
 touchForeignPtr :: ForeignPtr a -> IO ()
 -- ^This function ensures that the foreign object in
@@ -257,14 +304,13 @@ castForeignPtr f = unsafeCoerce# f
 -- | Causes the finalizers associated with a foreign pointer to be run
 -- immediately.
 finalizeForeignPtr :: ForeignPtr a -> IO ()
-finalizeForeignPtr (ForeignPtr _ contents) = do
-  case contents of
-    PlainNoFinalizer           -> return ()
-    PlainWithFinalizer r       -> runFinalizers r
-    MallocPtrNoFinalizer _     -> return ()
-    MallocPtrWithFinalizer _ r -> runFinalizers r
- where
-   runFinalizers r = do 
-     fs <- readIORef r
-     sequence_ fs
-     writeIORef r []
+finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect
+finalizeForeignPtr (ForeignPtr _ foreignPtr) = do
+	finalizers <- readIORef refFinalizers
+	sequence_ finalizers
+	writeIORef refFinalizers []
+	where
+		refFinalizers = case foreignPtr of
+			(PlainForeignPtr ref) -> ref
+			(MallocPtr     _ ref) -> ref
+