Use explicit language extensions & remove extension fields from base.cabal
[ghc.git] / libraries / base / GHC / ForeignPtr.hs
index 603a8f3..2e737f0 100644 (file)
@@ -1,4 +1,11 @@
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , BangPatterns
+           , MagicHash
+           , UnboxedTuples
+  #-}
+{-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.ForeignPtr
 -- #hide
 module GHC.ForeignPtr
   (
-       ForeignPtr(..),
-       FinalizerPtr,
-       newForeignPtr_,
-       mallocForeignPtr,
-       mallocPlainForeignPtr,
-       mallocForeignPtrBytes,
-       mallocPlainForeignPtrBytes,
-       addForeignPtrFinalizer, 
-       touchForeignPtr,
-       unsafeForeignPtrToPtr,
-       castForeignPtr,
-       newConcForeignPtr,
-       addForeignPtrConcFinalizer,
-       finalizeForeignPtr
+        ForeignPtr(..),
+        FinalizerPtr,
+        FinalizerEnvPtr,
+        newForeignPtr_,
+        mallocForeignPtr,
+        mallocPlainForeignPtr,
+        mallocForeignPtrBytes,
+        mallocPlainForeignPtrBytes,
+        addForeignPtrFinalizer,
+        addForeignPtrFinalizerEnv,
+        touchForeignPtr,
+        unsafeForeignPtrToPtr,
+        castForeignPtr,
+        newConcForeignPtr,
+        addForeignPtrConcFinalizer,
+        finalizeForeignPtr
   ) where
 
-import Control.Monad   ( sequence_ )
+import Control.Monad    ( sequence_ )
 import Foreign.Storable
-import Numeric         ( showHex )
+import Data.Typeable
 
 import GHC.Show
-import GHC.Num
-import GHC.List        ( null, replicate, length )
+import GHC.List         ( null )
 import GHC.Base
-import GHC.IOBase
-import GHC.STRef       ( STRef(..) )
-import GHC.Ptr         ( Ptr(..), FunPtr, castFunPtrToPtr )
+import GHC.IORef
+import GHC.STRef        ( STRef(..) )
+import GHC.Ptr          ( Ptr(..), FunPtr(..) )
 import GHC.Err
 
+#include "Typeable.h"
+
 -- |The type 'ForeignPtr' represents references to objects that are
 -- maintained in a foreign language, i.e., that are not part of the
 -- data structures usually managed by the Haskell storage manager.
@@ -62,19 +72,27 @@ import GHC.Err
 -- class 'Storable'.
 --
 data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents
-       -- we cache the Addr# in the ForeignPtr object, but attach
-       -- the finalizer to the IORef (or the MutableByteArray# in
-       -- the case of a MallocPtr).  The aim of the representation
-       -- is to make withForeignPtr efficient; in fact, withForeignPtr
-       -- should be just as efficient as unpacking a Ptr, and multiple
-       -- withForeignPtrs can share an unpacked ForeignPtr.  Note
-       -- that touchForeignPtr only has to touch the ForeignPtrContents
-       -- object, because that ensures that whatever the finalizer is
-       -- attached to is kept alive.
+        -- we cache the Addr# in the ForeignPtr object, but attach
+        -- the finalizer to the IORef (or the MutableByteArray# in
+        -- the case of a MallocPtr).  The aim of the representation
+        -- is to make withForeignPtr efficient; in fact, withForeignPtr
+        -- should be just as efficient as unpacking a Ptr, and multiple
+        -- withForeignPtrs can share an unpacked ForeignPtr.  Note
+        -- that touchForeignPtr only has to touch the ForeignPtrContents
+        -- object, because that ensures that whatever the finalizer is
+        -- attached to is kept alive.
+
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+
+data Finalizers
+  = NoFinalizers
+  | CFinalizers
+  | HaskellFinalizers
+    deriving Eq
 
 data ForeignPtrContents
-  = PlainForeignPtr !(IORef [IO ()])
-  | MallocPtr      (MutableByteArray# RealWorld) !(IORef [IO ()])
+  = PlainForeignPtr !(IORef (Finalizers, [IO ()]))
+  | MallocPtr      (MutableByteArray# RealWorld) !(IORef (Finalizers, [IO ()]))
   | PlainPtr       (MutableByteArray# RealWorld)
 
 instance Eq (ForeignPtr a) where
@@ -86,28 +104,13 @@ 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
+-- |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.
 -- 
-type FinalizerPtr a = FunPtr (Ptr a -> IO ())
+type FinalizerPtr a        = FunPtr (Ptr a -> IO ())
+type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())
 
 newConcForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
 --
@@ -152,24 +155,29 @@ mallocForeignPtr :: Storable a => IO (ForeignPtr a)
 -- 
 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#))
-                             (MallocPtr mbarr# r) #)
+        doMalloc a
+          | I# size < 0 = error "mallocForeignPtr: size must be >= 0"
+          | otherwise = do
+          r <- newIORef (NoFinalizers, [])
+          IO $ \s ->
+            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
+             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
+                               (MallocPtr mbarr# r) #)
             }
-           where (I# size) = sizeOf a
+            where !(I# size)  = sizeOf a
+                  !(I# align) = alignment a
 
 -- | This function is 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 size | size < 0 =
+  error "mallocForeignPtrBytes: size must be >= 0"
 mallocForeignPtrBytes (I# size) = do 
-  r <- newIORef []
+  r <- newIORef (NoFinalizers, [])
   IO $ \s ->
-     case newPinnedByteArray# size s      of { (# s, mbarr# #) ->
-       (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
-                       (MallocPtr mbarr# r) #)
+     case newPinnedByteArray# size s      of { (# s', mbarr# #) ->
+       (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
+                         (MallocPtr mbarr# r) #)
      }
 
 -- | Allocate some memory and return a 'ForeignPtr' to it.  The memory
@@ -188,31 +196,68 @@ mallocForeignPtrBytes (I# size) = do
 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#) #)
+        doMalloc a
+          | I# size < 0 = error "mallocForeignPtr: size must be >= 0"
+          | otherwise = IO $ \s ->
+            case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) ->
+             (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
+                               (PlainPtr mbarr#) #)
             }
-            where (I# size) = sizeOf a
+            where !(I# size)  = sizeOf a
+                  !(I# align) = alignment 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 size | size < 0 =
+  error "mallocPlainForeignPtrBytes: size must be >= 0"
 mallocPlainForeignPtrBytes (I# size) = IO $ \s ->
-    case newPinnedByteArray# size s      of { (# s, mbarr# #) ->
-       (# s, ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#))
-                        (PlainPtr mbarr#) #)
+    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
 -- object which have already been registered.
-addForeignPtrFinalizer finalizer fptr = 
-  addForeignPtrConcFinalizer fptr 
-       (mkFinalizer finalizer (unsafeForeignPtrToPtr fptr))
+addForeignPtrFinalizer (FunPtr fp) (ForeignPtr p c) = case c of
+  PlainForeignPtr r -> f r >> return ()
+  MallocPtr     _ r -> f r >> return ()
+  _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
+ where
+    f r =
+      noMixing CFinalizers r $
+        IO $ \s ->
+          case r of { IORef (STRef r#) ->
+          case mkWeakForeignEnv# r# () fp p 0# nullAddr# s of { (# s1, w #) ->
+          (# s1, finalizeForeign w #) }}
+
+addForeignPtrFinalizerEnv ::
+  FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()
+-- ^ Like 'addForeignPtrFinalizerEnv' but allows the finalizer to be
+-- passed an additional environment parameter to be passed to the
+-- finalizer.  The environment passed to the finalizer is fixed by the
+-- second argument to 'addForeignPtrFinalizerEnv'
+addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of
+  PlainForeignPtr r -> f r >> return ()
+  MallocPtr     _ r -> f r >> return ()
+  _ -> error "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"
+ where
+    f r =
+      noMixing CFinalizers r $
+        IO $ \s ->
+          case r of { IORef (STRef r#) ->
+          case mkWeakForeignEnv# r# () fp p 1# ep s of { (# s1, w #) ->
+          (# s1, finalizeForeign w #) }}
+
+finalizeForeign :: Weak# () -> IO ()
+finalizeForeign w = IO $ \s ->
+  case finalizeWeak# w s of
+    (# s1, 0#, _ #) -> (# s1, () #)
+    (# s1, _ , f #) -> f s1
 
 addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()
 -- ^This function adds a finalizer to the given @ForeignPtr@.  The
@@ -229,41 +274,49 @@ addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()
 -- are finalized objects, so a finalizer should not refer to a 'Handle'
 -- (including @stdout@, @stdin@ or @stderr@).
 --
-addForeignPtrConcFinalizer (ForeignPtr a c) finalizer = 
+addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer = 
   addForeignPtrConcFinalizer_ c finalizer
 
-addForeignPtrConcFinalizer_ f@(PlainForeignPtr r) finalizer = do
-  fs <- readIORef r
-  writeIORef r (finalizer : fs)
-  if (null fs)
+addForeignPtrConcFinalizer_ :: ForeignPtrContents -> IO () -> IO ()
+addForeignPtrConcFinalizer_ (PlainForeignPtr r) finalizer = do
+  noFinalizers <- noMixing HaskellFinalizers r (return finalizer)
+  if noFinalizers
      then IO $ \s ->
-             case r of { IORef (STRef r#) ->
-             case mkWeak# r# () (foreignPtrFinalizer r) s of {  (# s1, w #) ->
-             (# s1, () #) }}
+              case r of { IORef (STRef r#) ->
+              case mkWeak# r# () (foreignPtrFinalizer r) s of {  (# s1, _ #) ->
+              (# s1, () #) }}
      else return ()
-addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do 
-  fs <- readIORef r
-  writeIORef r (finalizer : fs)
-  if (null fs)
+addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do
+  noFinalizers <- noMixing HaskellFinalizers r (return finalizer)
+  if noFinalizers
      then  IO $ \s -> 
-              case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of
-                 (# s1, w #) -> (# s1, () #)
+               case mkWeak# fo () (do foreignPtrFinalizer r; touch f) s of
+                  (# s1, _ #) -> (# 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 ()
+noMixing ::
+  Finalizers -> IORef (Finalizers, [IO ()]) -> IO (IO ()) -> IO Bool
+noMixing ftype0 r mkF = do
+  (ftype, fs) <- readIORef r
+  if ftype /= NoFinalizers && ftype /= ftype0
+     then error ("GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++
+                 "in the same ForeignPtr")
+     else do
+       f <- mkF
+       writeIORef r (ftype0, f : fs)
+       return (null fs)
 
-foreignPtrFinalizer :: IORef [IO ()] -> IO ()
-foreignPtrFinalizer r = do fs <- readIORef r; sequence_ fs
+foreignPtrFinalizer :: IORef (Finalizers, [IO ()]) -> IO ()
+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) =  do
-  r <- newIORef []
+  r <- newIORef (NoFinalizers, [])
   return (ForeignPtr obj (PlainForeignPtr r))
 
 touchForeignPtr :: ForeignPtr a -> IO ()
@@ -291,9 +344,10 @@ touchForeignPtr :: ForeignPtr a -> IO ()
 -- result in artificial deadlock.  Another alternative is to use
 -- explicit reference counting.
 --
-touchForeignPtr (ForeignPtr fo r) = touch r
+touchForeignPtr (ForeignPtr _ r) = touch r
 
-touch r = IO $ \s -> case touch# r s of s -> (# s, () #)
+touch :: ForeignPtrContents -> IO ()
+touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)
 
 unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a
 -- ^This function extracts the pointer component of a foreign
@@ -308,9 +362,9 @@ unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a
 -- To avoid subtle coding errors, hand written marshalling code
 -- should preferably use 'Foreign.ForeignPtr.withForeignPtr' rather
 -- than combinations of 'unsafeForeignPtrToPtr' and
--- 'touchForeignPtr'.  However, the later routines
+-- 'touchForeignPtr'.  However, the latter routines
 -- are occasionally preferred in tool generated marshalling code.
-unsafeForeignPtrToPtr (ForeignPtr fo r) = Ptr fo
+unsafeForeignPtrToPtr (ForeignPtr fo _) = Ptr fo
 
 castForeignPtr :: ForeignPtr a -> ForeignPtr b
 -- ^This function casts a 'ForeignPtr'
@@ -322,11 +376,13 @@ castForeignPtr f = unsafeCoerce# f
 finalizeForeignPtr :: ForeignPtr a -> IO ()
 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
+        (ftype, finalizers) <- readIORef refFinalizers
+        sequence_ finalizers
+        writeIORef refFinalizers (ftype, [])
+        where
+                refFinalizers = case foreignPtr of
+                        (PlainForeignPtr ref) -> ref
+                        (MallocPtr     _ ref) -> ref
+                        PlainPtr _            ->
+                            error "finalizeForeignPtr PlainPtr"