1 {-# LANGUAGE CPP, NoImplicitPrelude #-}
3 --------------------------------------------------------------------------------
5 -- Module : Foreign.Marshal.Pool
6 -- Copyright : (c) Sven Panne 2002-2004
7 -- License : BSD-style (see the file libraries/base/LICENSE)
9 -- Maintainer : sven.panne@aedion.de
10 -- Stability : provisional
11 -- Portability : portable
13 -- This module contains support for pooled memory management. Under this scheme,
14 -- (re-)allocations belong to a given pool, and everything in a pool is
15 -- deallocated when the pool itself is deallocated. This is useful when
16 -- 'Foreign.Marshal.Alloc.alloca' with its implicit allocation and deallocation
17 -- is not flexible enough, but explicit uses of 'Foreign.Marshal.Alloc.malloc'
18 -- and 'free' are too awkward.
20 --------------------------------------------------------------------------------
22 module Foreign.Marshal.Pool (
25 newPool, -- :: IO Pool
26 freePool, -- :: Pool -> IO ()
27 withPool, -- :: (Pool -> IO b) -> IO b
29 -- * (Re-)Allocation within a pool
30 pooledMalloc, -- :: Storable a => Pool -> IO (Ptr a)
31 pooledMallocBytes, -- :: Pool -> Int -> IO (Ptr a)
33 pooledRealloc, -- :: Storable a => Pool -> Ptr a -> IO (Ptr a)
34 pooledReallocBytes, -- :: Pool -> Ptr a -> Int -> IO (Ptr a)
36 pooledMallocArray, -- :: Storable a => Pool -> Int -> IO (Ptr a)
37 pooledMallocArray0, -- :: Storable a => Pool -> Int -> IO (Ptr a)
39 pooledReallocArray, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
40 pooledReallocArray0, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
42 -- * Combined allocation and marshalling
43 pooledNew, -- :: Storable a => Pool -> a -> IO (Ptr a)
44 pooledNewArray, -- :: Storable a => Pool -> [a] -> IO (Ptr a)
45 pooledNewArray0 -- :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
48 #ifdef __GLASGOW_HASKELL__
49 import GHC.Base ( Int, Monad(..), (.), not )
50 import GHC.Err ( undefined )
51 import GHC.Exception ( throw )
52 import GHC.IO ( IO, mask, catchAny )
53 import GHC.IORef ( IORef, newIORef, readIORef, writeIORef )
54 import GHC.List ( elem, length )
55 import GHC.Num ( Num(..) )
57 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
61 import Control.Exception.Base ( bracket )
65 import Control.Monad ( liftM )
66 import Data.List ( delete )
67 import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free )
68 import Foreign.Marshal.Array ( pokeArray, pokeArray0 )
69 import Foreign.Marshal.Error ( throwIf )
70 import Foreign.Ptr ( Ptr, castPtr )
71 import Foreign.Storable ( Storable(sizeOf, poke) )
73 --------------------------------------------------------------------------------
75 -- To avoid non-H98 stuff like existentially quantified data constructors, we
76 -- simply use pointers to () below. Not very nice, but...
80 newtype Pool = Pool (IORef [Ptr ()])
82 -- | Allocate a fresh memory pool.
85 newPool = liftM Pool (newIORef [])
87 -- | Deallocate a memory pool and everything which has been allocated in the
90 freePool :: Pool -> IO ()
91 freePool (Pool pool) = readIORef pool >>= freeAll
92 where freeAll [] = return ()
93 freeAll (p:ps) = free p >> freeAll ps
95 -- | Execute an action with a fresh memory pool, which gets automatically
96 -- deallocated (including its contents) after the action has finished.
98 withPool :: (Pool -> IO b) -> IO b
99 #ifdef __GLASGOW_HASKELL__
100 withPool act = -- ATTENTION: cut-n-paste from Control.Exception below!
105 (\e -> do freePool pool; throw e)
109 withPool = bracket newPool freePool
112 --------------------------------------------------------------------------------
114 -- | Allocate space for storable type in the given pool. The size of the area
115 -- allocated is determined by the 'sizeOf' method from the instance of
116 -- 'Storable' for the appropriate type.
118 pooledMalloc :: Storable a => Pool -> IO (Ptr a)
119 pooledMalloc = pm undefined
121 pm :: Storable a' => a' -> Pool -> IO (Ptr a')
122 pm dummy pool = pooledMallocBytes pool (sizeOf dummy)
124 -- | Allocate the given number of bytes of storage in the pool.
126 pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
127 pooledMallocBytes (Pool pool) size = do
128 ptr <- mallocBytes size
129 ptrs <- readIORef pool
130 writeIORef pool (ptr:ptrs)
133 -- | Adjust the storage area for an element in the pool to the given size of
134 -- the required type.
136 pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a)
137 pooledRealloc = pr undefined
139 pr :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a')
140 pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy)
142 -- | Adjust the storage area for an element in the pool to the given size.
144 pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
145 pooledReallocBytes (Pool pool) ptr size = do
146 let cPtr = castPtr ptr
147 _ <- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)
148 newPtr <- reallocBytes cPtr size
149 ptrs <- readIORef pool
150 writeIORef pool (newPtr : delete cPtr ptrs)
151 return (castPtr newPtr)
153 -- | Allocate storage for the given number of elements of a storable type in the
156 pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a)
157 pooledMallocArray = pma undefined
159 pma :: Storable a' => a' -> Pool -> Int -> IO (Ptr a')
160 pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy)
162 -- | Allocate storage for the given number of elements of a storable type in the
163 -- pool, but leave room for an extra element to signal the end of the array.
165 pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)
166 pooledMallocArray0 pool size =
167 pooledMallocArray pool (size + 1)
169 -- | Adjust the size of an array in the given pool.
171 pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
172 pooledReallocArray = pra undefined
174 pra :: Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a')
175 pra dummy pool ptr size = pooledReallocBytes pool ptr (size * sizeOf dummy)
177 -- | Adjust the size of an array with an end marker in the given pool.
179 pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
180 pooledReallocArray0 pool ptr size =
181 pooledReallocArray pool ptr (size + 1)
183 --------------------------------------------------------------------------------
185 -- | Allocate storage for a value in the given pool and marshal the value into
188 pooledNew :: Storable a => Pool -> a -> IO (Ptr a)
189 pooledNew pool val = do
190 ptr <- pooledMalloc pool
194 -- | Allocate consecutive storage for a list of values in the given pool and
195 -- marshal these values into it.
197 pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)
198 pooledNewArray pool vals = do
199 ptr <- pooledMallocArray pool (length vals)
203 -- | Allocate consecutive storage for a list of values in the given pool and
204 -- marshal these values into it, terminating the end with the given marker.
206 pooledNewArray0 :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
207 pooledNewArray0 pool marker vals = do
208 ptr <- pooledMallocArray0 pool (length vals)
209 pokeArray0 marker ptr vals