{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables #-}
module Foreign.Marshal.Pool (
Pool,
newPool,
freePool,
withPool,
pooledMalloc,
pooledMallocBytes,
pooledRealloc,
pooledReallocBytes,
pooledMallocArray,
pooledMallocArray0,
pooledReallocArray,
pooledReallocArray0,
pooledNew,
pooledNewArray,
pooledNewArray0
) where
import GHC.Base ( Int, Monad(..), (.), liftM, not )
import GHC.Err ( undefined )
import GHC.Exception ( throw )
import GHC.IO ( IO, mask, catchAny )
import GHC.IORef ( IORef, newIORef, readIORef, writeIORef )
import GHC.List ( elem, length )
import GHC.Num ( Num(..) )
import Data.OldList ( delete )
import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free )
import Foreign.Marshal.Array ( pokeArray, pokeArray0 )
import Foreign.Marshal.Error ( throwIf )
import Foreign.Ptr ( Ptr, castPtr )
import Foreign.Storable ( Storable(sizeOf, poke) )
newtype Pool = Pool (IORef [Ptr ()])
newPool :: IO Pool
newPool :: IO Pool
newPool = (IORef [Ptr ()] -> Pool) -> IO (IORef [Ptr ()]) -> IO Pool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM IORef [Ptr ()] -> Pool
Pool ([Ptr ()] -> IO (IORef [Ptr ()])
forall a. a -> IO (IORef a)
newIORef [])
freePool :: Pool -> IO ()
freePool :: Pool -> IO ()
freePool (Pool IORef [Ptr ()]
pool) = IORef [Ptr ()] -> IO [Ptr ()]
forall a. IORef a -> IO a
readIORef IORef [Ptr ()]
pool IO [Ptr ()] -> ([Ptr ()] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Ptr ()] -> IO ()
forall {a}. [Ptr a] -> IO ()
freeAll
where freeAll :: [Ptr a] -> IO ()
freeAll [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
freeAll (Ptr a
p:[Ptr a]
ps) = Ptr a -> IO ()
forall a. Ptr a -> IO ()
free Ptr a
p IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Ptr a] -> IO ()
freeAll [Ptr a]
ps
withPool :: (Pool -> IO b) -> IO b
withPool :: forall b. (Pool -> IO b) -> IO b
withPool Pool -> IO b
act =
((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (\forall a. IO a -> IO a
restore -> do
Pool
pool <- IO Pool
newPool
b
val <- IO b -> (forall e. Exception e => e -> IO b) -> IO b
forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
catchAny
(IO b -> IO b
forall a. IO a -> IO a
restore (Pool -> IO b
act Pool
pool))
(\e
e -> do Pool -> IO ()
freePool Pool
pool; e -> IO b
forall a e. Exception e => e -> a
throw e
e)
Pool -> IO ()
freePool Pool
pool
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
val)
pooledMalloc :: forall a . Storable a => Pool -> IO (Ptr a)
pooledMalloc :: forall a. Storable a => Pool -> IO (Ptr a)
pooledMalloc Pool
pool = Pool -> Int -> IO (Ptr a)
forall a. Pool -> Int -> IO (Ptr a)
pooledMallocBytes Pool
pool (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))
pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
pooledMallocBytes :: forall a. Pool -> Int -> IO (Ptr a)
pooledMallocBytes (Pool IORef [Ptr ()]
pool) Int
size = do
Ptr ()
ptr <- Int -> IO (Ptr ())
forall a. Int -> IO (Ptr a)
mallocBytes Int
size
[Ptr ()]
ptrs <- IORef [Ptr ()] -> IO [Ptr ()]
forall a. IORef a -> IO a
readIORef IORef [Ptr ()]
pool
IORef [Ptr ()] -> [Ptr ()] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Ptr ()]
pool (Ptr ()
ptrPtr () -> [Ptr ()] -> [Ptr ()]
forall a. a -> [a] -> [a]
:[Ptr ()]
ptrs)
Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
ptr)
pooledRealloc :: forall a . Storable a => Pool -> Ptr a -> IO (Ptr a)
pooledRealloc :: forall a. Storable a => Pool -> Ptr a -> IO (Ptr a)
pooledRealloc Pool
pool Ptr a
ptr = Pool -> Ptr a -> Int -> IO (Ptr a)
forall a. Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes Pool
pool Ptr a
ptr (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))
pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes :: forall a. Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes (Pool IORef [Ptr ()]
pool) Ptr a
ptr Int
size = do
let cPtr :: Ptr b
cPtr = Ptr a -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr
[Ptr ()]
_ <- ([Ptr ()] -> Bool)
-> ([Ptr ()] -> String) -> IO [Ptr ()] -> IO [Ptr ()]
forall a. (a -> Bool) -> (a -> String) -> IO a -> IO a
throwIf (Bool -> Bool
not (Bool -> Bool) -> ([Ptr ()] -> Bool) -> [Ptr ()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr ()
forall {b}. Ptr b
cPtr Ptr () -> [Ptr ()] -> Bool
forall a. Eq a => a -> [a] -> Bool
`elem`)) (\[Ptr ()]
_ -> String
"pointer not in pool") (IORef [Ptr ()] -> IO [Ptr ()]
forall a. IORef a -> IO a
readIORef IORef [Ptr ()]
pool)
Ptr ()
newPtr <- Ptr () -> Int -> IO (Ptr ())
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr ()
forall {b}. Ptr b
cPtr Int
size
[Ptr ()]
ptrs <- IORef [Ptr ()] -> IO [Ptr ()]
forall a. IORef a -> IO a
readIORef IORef [Ptr ()]
pool
IORef [Ptr ()] -> [Ptr ()] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Ptr ()]
pool (Ptr ()
newPtr Ptr () -> [Ptr ()] -> [Ptr ()]
forall a. a -> [a] -> [a]
: Ptr () -> [Ptr ()] -> [Ptr ()]
forall a. Eq a => a -> [a] -> [a]
delete Ptr ()
forall {b}. Ptr b
cPtr [Ptr ()]
ptrs)
Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
newPtr)
pooledMallocArray :: forall a . Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray :: forall a. Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray Pool
pool Int
size =
Pool -> Int -> IO (Ptr a)
forall a. Pool -> Int -> IO (Ptr a)
pooledMallocBytes Pool
pool (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))
pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray0 :: forall a. Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray0 Pool
pool Int
size =
Pool -> Int -> IO (Ptr a)
forall a. Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray Pool
pool (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
pooledReallocArray :: forall a . Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray :: forall a. Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray Pool
pool Ptr a
ptr Int
size =
Pool -> Ptr a -> Int -> IO (Ptr a)
forall a. Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes Pool
pool Ptr a
ptr (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))
pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray0 :: forall a. Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray0 Pool
pool Ptr a
ptr Int
size =
Pool -> Ptr a -> Int -> IO (Ptr a)
forall a. Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray Pool
pool Ptr a
ptr (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
pooledNew :: Storable a => Pool -> a -> IO (Ptr a)
pooledNew :: forall a. Storable a => Pool -> a -> IO (Ptr a)
pooledNew Pool
pool a
val = do
Ptr a
ptr <- Pool -> IO (Ptr a)
forall a. Storable a => Pool -> IO (Ptr a)
pooledMalloc Pool
pool
Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
ptr a
val
Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr
pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)
pooledNewArray :: forall a. Storable a => Pool -> [a] -> IO (Ptr a)
pooledNewArray Pool
pool [a]
vals = do
Ptr a
ptr <- Pool -> Int -> IO (Ptr a)
forall a. Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray Pool
pool ([a] -> Int
forall a. [a] -> Int
length [a]
vals)
Ptr a -> [a] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr a
ptr [a]
vals
Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr
pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
pooledNewArray0 :: forall a. Storable a => Pool -> a -> [a] -> IO (Ptr a)
pooledNewArray0 Pool
pool a
marker [a]
vals = do
Ptr a
ptr <- Pool -> Int -> IO (Ptr a)
forall a. Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray0 Pool
pool ([a] -> Int
forall a. [a] -> Int
length [a]
vals)
a -> Ptr a -> [a] -> IO ()
forall a. Storable a => a -> Ptr a -> [a] -> IO ()
pokeArray0 a
marker Ptr a
ptr [a]
vals
Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr