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

--------------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.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
-- 'GHC.Internal.Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation
-- is not flexible enough, but explicit uses of 'GHC.Internal.Foreign.Marshal.Alloc.malloc'
-- and 'free' are too awkward.
--
--------------------------------------------------------------------------------

module GHC.Internal.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.Internal.Base              ( Int, Monad(..) )
import GHC.Internal.Err               ( undefined )
import GHC.Internal.Exception         ( throw )
import GHC.Internal.IO                ( IO, mask, catchAny )
import GHC.Internal.List              ( length )
import GHC.Internal.Num               ( Num(..) )
import GHC.Internal.Real              ( fromIntegral )

import GHC.Internal.Foreign.C.Types       ( CSize(..) )
import GHC.Internal.Foreign.Marshal.Array ( pokeArray, pokeArray0 )
import GHC.Internal.Foreign.Marshal.Utils ( moveBytes )
import GHC.Internal.Foreign.Ptr           ( Ptr )
import GHC.Internal.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 (Ptr ())

-- | Allocate a fresh memory pool.

newPool :: IO Pool
newPool :: IO Pool
newPool = IO Pool
c_newArena

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

freePool :: Pool -> IO ()
freePool :: Pool -> IO ()
freePool = Pool -> IO ()
c_arenaFree

-- | 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 :: forall b. (Pool -> IO b) -> IO b
withPool Pool -> IO b
act =   -- ATTENTION: cut-n-paste from GHC.Internal.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 (\forall a. IO a -> IO a
restore -> do
      pool <- IO Pool
newPool
      val <- catchAny
                (restore (act pool))
                (\e
e -> do Pool -> IO ()
freePool Pool
pool; e -> IO b
forall a e. (?callStack::CallStack, Exception e) => e -> a
throw e
e)
      freePool pool
      return 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 :: 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. (?callStack::CallStack) => a
undefined :: a))

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

pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
pooledMallocBytes :: forall a. Pool -> Int -> IO (Ptr a)
pooledMallocBytes Pool
pool Int
size = Pool -> CSize -> IO (Ptr a)
forall a. Pool -> CSize -> IO (Ptr a)
c_arenaAlloc Pool
pool (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)

-- | 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 :: 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. (?callStack::CallStack) => a
undefined :: a))

-- | Adjust the storage area for an element in the pool to the given size. Note
-- that the previously allocated space is still retained in the same 'Pool' and
-- will only be freed when the entire 'Pool' is freed.

pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes :: forall a. Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes Pool
pool Ptr a
ptr Int
size = do
   newPtr <- Pool -> Int -> IO (Ptr a)
forall a. Pool -> Int -> IO (Ptr a)
pooledMallocBytes Pool
pool Int
size
   moveBytes newPtr ptr size
   return 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 :: 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. (?callStack::CallStack) => 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 :: 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)

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

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. (?callStack::CallStack) => 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 :: 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)

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

-- | 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 :: forall a. Storable a => Pool -> a -> IO (Ptr a)
pooledNew Pool
pool a
val = do
   ptr <- Pool -> IO (Ptr a)
forall a. Storable a => Pool -> IO (Ptr a)
pooledMalloc Pool
pool
   poke ptr val
   return 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 :: forall a. Storable a => Pool -> [a] -> IO (Ptr a)
pooledNewArray Pool
pool [a]
vals = do
   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)
   pokeArray ptr vals
   return 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 :: forall a. Storable a => Pool -> a -> [a] -> IO (Ptr a)
pooledNewArray0 Pool
pool a
marker [a]
vals = do
   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)
   pokeArray0 marker ptr vals
   return ptr

foreign import ccall unsafe "newArena" c_newArena :: IO Pool

foreign import ccall unsafe "arenaAlloc" c_arenaAlloc :: Pool -> CSize -> IO (Ptr a)

foreign import ccall unsafe "arenaFree" c_arenaFree :: Pool -> IO ()