(original) (raw)

{-# LANGUAGE Unsafe #-} {-# LANGUAGE NoImplicitPrelude , BangPatterns , MagicHash , UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE StandaloneDeriving #-}

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

import Foreign.Storable import Data.Foldable ( sequence_ )

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

data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents

data Finalizers = NoFinalizers | CFinalizers (Weak# ()) | HaskellFinalizers [IO ()]

data ForeignPtrContents = PlainForeignPtr !(IORef Finalizers) | MallocPtr (MutableByteArray# RealWorld) !(IORef Finalizers) | 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 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0" | otherwise = do r <- newIORef NoFinalizers IO $ [s](#local-6989586621679257202) -> 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 = errorWithoutStackTrace "mallocForeignPtrBytes: size must be >= 0" mallocForeignPtrBytes (I# size) = do r <- newIORef NoFinalizers IO $ [s](#local-6989586621679257208) -> 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 = errorWithoutStackTrace "mallocForeignPtrAlignedBytes: size must be >= 0" mallocForeignPtrAlignedBytes (I# size) (I# align) = do r <- newIORef NoFinalizers IO $ [s](#local-6989586621679257216) -> 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 = errorWithoutStackTrace "mallocForeignPtr: size must be >= 0" | otherwise = IO $ [s](#local-6989586621679257224) -> 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 = errorWithoutStackTrace "mallocPlainForeignPtrBytes: size must be >= 0" mallocPlainForeignPtrBytes (I# size) = IO $ [s](#local-6989586621679257229) -> 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 = errorWithoutStackTrace "mallocPlainForeignPtrAlignedBytes: size must be >= 0" mallocPlainForeignPtrAlignedBytes (I# size) (I# align) = IO $ [s](#local-6989586621679257236) -> 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 -> insertCFinalizer r fp 0# nullAddr# p () MallocPtr _ r -> insertCFinalizer r fp 0# nullAddr# p c _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"

addForeignPtrFinalizerEnv :: FinalizerEnvPtr env a -> Ptr env -> ForeignPtr a -> IO ()

addForeignPtrFinalizerEnv (FunPtr fp) (Ptr ep) (ForeignPtr p c) = case c of PlainForeignPtr r -> insertCFinalizer r fp 1# ep p () MallocPtr _ r -> insertCFinalizer r fp 1# ep p c _ -> errorWithoutStackTrace "GHC.ForeignPtr: attempt to add a finalizer to a plain pointer"

addForeignPtrConcFinalizer :: ForeignPtr a -> IO () -> IO ()

addForeignPtrConcFinalizer (ForeignPtr _ c) finalizer = addForeignPtrConcFinalizer_ c finalizer

addForeignPtrConcFinalizer_ :: ForeignPtrContents -> IO () -> IO () addForeignPtrConcFinalizer_ (PlainForeignPtr r) finalizer = do noFinalizers <- insertHaskellFinalizer r finalizer if noFinalizers then IO $ [s](#local-6989586621679257255) -> case r of { IORef (STRef r#) -> case mkWeak# r# () (unIO $ foreignPtrFinalizer r) s of { (# s1, _ #) -> (# s1, () #) }} else return () addForeignPtrConcFinalizer_ f@(MallocPtr fo r) finalizer = do noFinalizers <- insertHaskellFinalizer r finalizer if noFinalizers then IO $ [s](#local-6989586621679257264) -> case mkWeak# fo () finalizer' s of (# s1, _ #) -> (# s1, () #) else return () where finalizer' :: State# RealWorld -> (# State# RealWorld, () #) finalizer' = unIO (foreignPtrFinalizer r >> touch f)

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

insertHaskellFinalizer :: IORef Finalizers -> IO () -> IO Bool insertHaskellFinalizer r f = do wasEmpty <- atomicModifyIORef r $ [finalizers](#local-6989586621679257268) -> case finalizers of NoFinalizers -> (HaskellFinalizers [f], True) HaskellFinalizers fs -> (HaskellFinalizers (f:fs), False) _ -> noMixingError return wasEmpty

data MyWeak = MyWeak (Weak# ())

insertCFinalizer :: IORef Finalizers -> Addr# -> Int# -> Addr# -> Addr# -> value -> IO () insertCFinalizer r fp flag ep p val = do MyWeak w <- ensureCFinalizerWeak r val IO $ [s](#local-6989586621679257278) -> case addCFinalizerToWeak# fp p flag ep w s of (# s1, 1# #) -> (# s1, () #)

  (# [s1](#local-6989586621679257280), _ #) -> [unIO](GHC.Base.html#unIO) ([insertCFinalizer](GHC.ForeignPtr.html#insertCFinalizer) [r](#local-6989586621679257271) [fp](#local-6989586621679257272) [flag](#local-6989586621679257273) [ep](#local-6989586621679257274) [p](#local-6989586621679257275) [val](#local-6989586621679257276)) [s1](#local-6989586621679257280)

ensureCFinalizerWeak :: IORef Finalizers -> value -> IO MyWeak ensureCFinalizerWeak ref@(IORef (STRef r#)) value = do fin <- readIORef ref case fin of CFinalizers weak -> return (MyWeak weak) HaskellFinalizers{} -> noMixingError NoFinalizers -> IO $ [s](#local-6989586621679257290) -> case mkWeakNoFinalizer# r# (unsafeCoerce# value) s of { (# s1, w #) ->

      case atomicModifyMutVar# [r#](#local-6989586621679257282) ([update](#local-6989586621679257284) [w](#local-6989586621679257292)) [s1](#local-6989586621679257291) of
          { (# [s2](#local-6989586621679257293), ([weak](#local-6989586621679257294), [needKill](#local-6989586621679257295) ) #) ->
      if [needKill](#local-6989586621679257295)
        then case finalizeWeak# [w](#local-6989586621679257292) [s2](#local-6989586621679257293) of { (# [s3](#local-6989586621679257296), _, _ #) ->
          (# [s3](#local-6989586621679257296), [weak](#local-6989586621679257294) #) }
        else (# [s2](#local-6989586621679257293), [weak](#local-6989586621679257294) #) }}

where update _ fin@(CFinalizers w) = (fin, (MyWeak w, True)) update w NoFinalizers = (CFinalizers w, (MyWeak w, False)) update _ _ = noMixingError

noMixingError :: a noMixingError = errorWithoutStackTrace $ "GHC.ForeignPtr: attempt to mix Haskell and C finalizers " ++ "in the same ForeignPtr"

foreignPtrFinalizer :: IORef Finalizers -> IO () foreignPtrFinalizer r = do fs <- atomicModifyIORef r $ [fs](#local-6989586621679257298) -> (NoFinalizers, fs) case fs of NoFinalizers -> return () CFinalizers w -> IO $ [s](#local-6989586621679257301) -> case finalizeWeak# w s of (# s1, 1#, f #) -> f s1 (# s1, _, _ #) -> (# s1, () #) HaskellFinalizers actions -> sequence_ actions

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](#local-6989586621679257310) -> case touch# r s of s' -> (# s', () #)

unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a

unsafeForeignPtrToPtr (ForeignPtr fo _) = Ptr fo

castForeignPtr :: ForeignPtr a -> ForeignPtr b

castForeignPtr = coerce

plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b

plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c

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 _ -> errorWithoutStackTrace "finalizeForeignPtr PlainPtr"