{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Foreign.Marshal.Pool
-- Copyright   :  (c) Sven Panne 2002-2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  sven.panne@aedion.de
-- Stability   :  provisional
-- Portability :  portable
--
-- This module contains support for pooled memory management. Under this scheme,
-- (re-)allocations belong to a given pool, and everything in a pool is
-- deallocated when the pool itself is deallocated. This is useful when
-- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation
-- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'
-- and 'free' are too awkward.
--
--------------------------------------------------------------------------------

module Foreign.Marshal.Pool (
   -- * Pool management
   Pool,
   newPool,
   freePool,
   withPool,

   -- * (Re-)Allocation within a pool
   pooledMalloc,
   pooledMallocBytes,

   pooledRealloc,
   pooledReallocBytes,

   pooledMallocArray,
   pooledMallocArray0,

   pooledReallocArray,
   pooledReallocArray0,

   -- * Combined allocation and marshalling
   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) )

--------------------------------------------------------------------------------

-- To avoid non-H2010 stuff like existentially quantified data constructors, we
-- simply use pointers to () below. Not very nice, but...

-- | A memory pool.

newtype Pool = Pool (IORef [Ptr ()])

-- | Allocate a fresh memory pool.

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 [])

-- | Deallocate a memory pool and everything which has been allocated in the
-- pool itself.

freePool :: Pool -> IO ()
freePool :: Pool -> IO ()
freePool (Pool 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 (p :: Ptr a
p:ps :: [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

-- | Execute an action with a fresh memory pool, which gets automatically
-- deallocated (including its contents) after the action has finished.

withPool :: (Pool -> IO b) -> IO b
withPool :: (Pool -> IO b) -> IO b
withPool act :: Pool -> IO b
act =   -- ATTENTION: cut-n-paste from Control.Exception below!
   ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (\restore :: 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
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)

--------------------------------------------------------------------------------

-- | Allocate space for storable type in the given pool. The size of the area
-- allocated is determined by the 'sizeOf' method from the instance of
-- 'Storable' for the appropriate type.

pooledMalloc :: forall a . Storable a => Pool -> IO (Ptr a)
pooledMalloc :: Pool -> IO (Ptr a)
pooledMalloc pool :: 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))

-- | Allocate the given number of bytes of storage in the pool.

pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
pooledMallocBytes (Pool pool :: IORef [Ptr ()]
pool) size :: 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)

-- | Adjust the storage area for an element in the pool to the given size of
-- the required type.

pooledRealloc :: forall a . Storable a => Pool -> Ptr a -> IO (Ptr a)
pooledRealloc :: Pool -> Ptr a -> IO (Ptr a)
pooledRealloc pool :: Pool
pool ptr :: 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))

-- | Adjust the storage area for an element in the pool to the given size.

pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes (Pool pool :: IORef [Ptr ()]
pool) ptr :: Ptr a
ptr size :: 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`)) (\_ -> "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)

-- | Allocate storage for the given number of elements of a storable type in the
-- pool.

pooledMallocArray :: forall a . Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray :: Pool -> Int -> IO (Ptr a)
pooledMallocArray pool :: Pool
pool size :: 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))

-- | Allocate storage for the given number of elements of a storable type in the
-- pool, but leave room for an extra element to signal the end of the array.

pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray0 :: Pool -> Int -> IO (Ptr a)
pooledMallocArray0 pool :: Pool
pool size :: 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
+ 1)

-- | Adjust the size of an array in the given pool.

pooledReallocArray :: forall a . Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray pool :: Pool
pool ptr :: Ptr a
ptr size :: 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))

-- | Adjust the size of an array with an end marker in the given pool.

pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray0 :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray0 pool :: Pool
pool ptr :: Ptr a
ptr size :: 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
+ 1)

--------------------------------------------------------------------------------

-- | Allocate storage for a value in the given pool and marshal the value into
-- this storage.

pooledNew :: Storable a => Pool -> a -> IO (Ptr a)
pooledNew :: Pool -> a -> IO (Ptr a)
pooledNew pool :: Pool
pool val :: 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

-- | Allocate consecutive storage for a list of values in the given pool and
-- marshal these values into it.

pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)
pooledNewArray :: Pool -> [a] -> IO (Ptr a)
pooledNewArray pool :: Pool
pool vals :: [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

-- | Allocate consecutive storage for a list of values in the given pool and
-- marshal these values into it, terminating the end with the given marker.

pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
pooledNewArray0 :: Pool -> a -> [a] -> IO (Ptr a)
pooledNewArray0 pool :: Pool
pool marker :: a
marker vals :: [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