module GHC.ForeignPtr
(
ForeignPtr(..),
FinalizerPtr,
FinalizerEnvPtr,
newForeignPtr_,
mallocForeignPtr,
mallocPlainForeignPtr,
mallocForeignPtrBytes,
mallocPlainForeignPtrBytes,
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) #)
}
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#) #)
}
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) <- readIORef r; 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) = do
(ftype, finalizers) <- readIORef refFinalizers
sequence_ finalizers
writeIORef refFinalizers (ftype, [])
where
refFinalizers = case foreignPtr of
(PlainForeignPtr ref) -> ref
(MallocPtr _ ref) -> ref
PlainPtr _ ->
error "finalizeForeignPtr PlainPtr"
RetroSearch is an open source project built by @garambo | Open a GitHub Issue
Search and Browse the WWW like it's 1997 | Search results from DuckDuckGo
HTML:
3.2
| Encoding:
UTF-8
| Version:
0.7.4