GHC/ForeignPtr.hs (original) (raw)

module GHC.ForeignPtr ( ForeignPtr(..), ForeignPtrContents(..), FinalizerPtr, FinalizerEnvPtr, newForeignPtr_, mallocForeignPtr, mallocPlainForeignPtr, mallocForeignPtrBytes, mallocPlainForeignPtrBytes, mallocForeignPtrAlignedBytes, mallocPlainForeignPtrAlignedBytes, addForeignPtrFinalizer, addForeignPtrFinalizerEnv, touchForeignPtr, unsafeForeignPtrToPtr, castForeignPtr, newConcForeignPtr, addForeignPtrConcFinalizer, finalizeForeignPtr ) where

import Control.Monad ( sequence_ ) import Foreign.Storable import Data.Typeable

import GHC.Show import GHC.List ( null ) import GHC.Base import GHC.IORef import GHC.STRef ( STRef(..) ) import GHC.Ptr ( Ptr(..), FunPtr(..) ) import GHC.Err

#include "Typeable.h"

data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents

INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")

data Finalizers = NoFinalizers | CFinalizers | HaskellFinalizers deriving Eq

data ForeignPtrContents = PlainForeignPtr !(IORef (Finalizers, [IO ()])) | MallocPtr (MutableByteArray# RealWorld) !(IORef (Finalizers, [IO ()])) | PlainPtr (MutableByteArray# RealWorld)

instance Eq (ForeignPtr a) where p == q = unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q

instance Ord (ForeignPtr a) where compare p q = compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)

instance Show (ForeignPtr a) where showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)

type FinalizerPtr a = FunPtr (Ptr a -> IO ()) type FinalizerEnvPtr env a = FunPtr (Ptr env -> Ptr a -> IO ())

newConcForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)

newConcForeignPtr p finalizer = do fObj <- newForeignPtr_ p addForeignPtrConcFinalizer fObj finalizer return fObj

mallocForeignPtr :: Storable a => IO (ForeignPtr a)

mallocForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) 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 !(I# align) = alignment a

mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) mallocForeignPtrBytes size | size < 0 = error "mallocForeignPtrBytes: size must be >= 0" mallocForeignPtrBytes (I# size) = do r <- newIORef (NoFinalizers, []) IO $ \s -> case newPinnedByteArray# size s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (MallocPtr mbarr# r) #) }

mallocForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a) mallocForeignPtrAlignedBytes size _align | size < 0 = error "mallocForeignPtrAlignedBytes: size must be >= 0" mallocForeignPtrAlignedBytes (I# size) (I# align) = do r <- newIORef (NoFinalizers, []) IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (MallocPtr mbarr# r) #) }

mallocPlainForeignPtr :: Storable a => IO (ForeignPtr a) mallocPlainForeignPtr = doMalloc undefined where doMalloc :: Storable b => b -> IO (ForeignPtr b) 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 !(I# align) = alignment a

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#) #) }

mallocPlainForeignPtrAlignedBytes :: Int -> Int -> IO (ForeignPtr a) mallocPlainForeignPtrAlignedBytes size _align | size < 0 = error "mallocPlainForeignPtrAlignedBytes: size must be >= 0" mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ \s -> case newAlignedPinnedByteArray# size align s of { (# s', mbarr# #) -> (# s', ForeignPtr (byteArrayContents# (unsafeCoerce# mbarr#)) (PlainPtr mbarr#) #) }

addForeignPtrFinalizer :: FinalizerPtr a -> ForeignPtr a -> IO ()

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

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

addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer = addForeignPtrConcFinalizer_ c finalizer

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, _ #) -> (# s1, () #) }} else return () 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, _ #) -> (# s1, () #) else return ()

addForeignPtrConcFinalizer_ _ _ = error "GHC.ForeignPtr: attempt to add a finalizer to plain pointer"

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 (Finalizers, [IO ()]) -> IO () foreignPtrFinalizer r = do fs <- atomicModifyIORef r $ (f,fs) -> ((f,[]), fs) sequence_ fs

newForeignPtr_ :: Ptr a -> IO (ForeignPtr a)

newForeignPtr_ (Ptr obj) = do r <- newIORef (NoFinalizers, []) return (ForeignPtr obj (PlainForeignPtr r))

touchForeignPtr :: ForeignPtr a -> IO ()

touchForeignPtr (ForeignPtr _ r) = touch r

touch :: ForeignPtrContents -> IO () touch r = IO $ \s -> case touch# r s of s' -> (# s', () #)

unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a

unsafeForeignPtrToPtr (ForeignPtr fo _) = Ptr fo

castForeignPtr :: ForeignPtr a -> ForeignPtr b

castForeignPtr f = unsafeCoerce# f

finalizeForeignPtr :: ForeignPtr a -> IO () finalizeForeignPtr (ForeignPtr _ (PlainPtr _)) = return () finalizeForeignPtr (ForeignPtr _ foreignPtr) = foreignPtrFinalizer refFinalizers where refFinalizers = case foreignPtr of (PlainForeignPtr ref) -> ref (MallocPtr _ ref) -> ref PlainPtr _ -> error "finalizeForeignPtr PlainPtr"