X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=GHC%2FForeignPtr.hs;h=603a8f3f1cc6f528aecb9ca453bf17e9e8f2b82f;hb=b53fd4a2af7c7b22b54875de8b0befc8fb6518a2;hp=971276379a3664723d4c60b197f130f198b08129;hpb=85c40b892e70030f8e41ba56dd7ac735d91fe1fa;p=haskell-directory.git

diff --git a/GHC/ForeignPtr.hs b/GHC/ForeignPtr.hs
index 9712763..603a8f3 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,16 +33,17 @@ module GHC.ForeignPtr
   ) where
 
 import Control.Monad 	( sequence_ )
-import Foreign.Ptr
 import Foreign.Storable
+import Numeric		( showHex )
 
-import GHC.List  	( null )
+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
@@ -69,9 +72,10 @@ data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents
 	-- object, because that ensures that whatever the finalizer is
 	-- attached to is kept alive.
 
-data ForeignPtrContents 
+data ForeignPtrContents
   = PlainForeignPtr !(IORef [IO ()])
-  | MallocPtr (MutableByteArray# RealWorld) !(IORef [IO ()])
+  | MallocPtr      (MutableByteArray# RealWorld) !(IORef [IO ()])
+  | PlainPtr       (MutableByteArray# RealWorld)
 
 instance Eq (ForeignPtr a) where
     p == q  =  unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q
@@ -82,6 +86,23 @@ instance Ord (ForeignPtr a) where
 instance Show (ForeignPtr a) where
     showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)
 
+#include "MachDeps.h"
+
+#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
+instance Show (Ptr a) where
+   showsPrec p (Ptr a) rs = pad_out (showHex (word2Integer(int2Word#(addr2Int# a))) "") rs
+     where
+        -- want 0s prefixed to pad it out to a fixed length.
+       pad_out ls rs = 
+	  '0':'x':(replicate (2*SIZEOF_HSPTR - length ls) '0') ++ ls ++ rs
+       -- word2Integer :: Word# -> Integer (stolen from Word.lhs)
+       word2Integer w = case word2Integer# w of
+			(# s, d #) -> J# s d
+
+instance Show (FunPtr a) where
+   showsPrec p = showsPrec p . castFunPtrToPtr
+#endif
+
 -- |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.
@@ -121,6 +142,14 @@ 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
@@ -143,6 +172,40 @@ mallocForeignPtrBytes (I# size) = do
 		        (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 ()
 -- ^This function adds a finalizer to the given foreign object.  The
 -- finalizer will run /before/ all other finalizers for the same
@@ -187,6 +250,9 @@ addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do
 		  (# s1, w #) -> (# s1, () #)
      else return ()
 
+addForeignPtrConcFinalizer_ _ _ =
+  error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"
+
 foreign import ccall "dynamic" 
   mkFinalizer :: FinalizerPtr a -> Ptr a -> IO ()
 
@@ -254,6 +320,7 @@ castForeignPtr f = unsafeCoerce# f
 -- | Causes the finalizers associated with a foreign pointer to be run
 -- immediately.
 finalizeForeignPtr :: ForeignPtr a -> IO ()
+finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () -- no effect
 finalizeForeignPtr (ForeignPtr _ foreignPtr) = do
 	finalizers <- readIORef refFinalizers
 	sequence_ finalizers
@@ -261,4 +328,5 @@ finalizeForeignPtr (ForeignPtr _ foreignPtr) = do
 	where
 		refFinalizers = case foreignPtr of
 			(PlainForeignPtr ref) -> ref
-			(MallocPtr  _ ref) -> ref
+			(MallocPtr     _ ref) -> ref
+