ed94e464fb9680e161059e7c17b48e318626b9e7
[ghc.git] / libraries / base / Foreign / Marshal / Pool.hs
1 {-# LANGUAGE CPP, NoImplicitPrelude #-}
2
3 --------------------------------------------------------------------------------
4 -- |
5 -- Module : Foreign.Marshal.Pool
6 -- Copyright : (c) Sven Panne 2002-2004
7 -- License : BSD-style (see the file libraries/base/LICENSE)
8 --
9 -- Maintainer : sven.panne@aedion.de
10 -- Stability : provisional
11 -- Portability : portable
12 --
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.
19 --
20 --------------------------------------------------------------------------------
21
22 module Foreign.Marshal.Pool (
23 -- * Pool management
24 Pool,
25 newPool, -- :: IO Pool
26 freePool, -- :: Pool -> IO ()
27 withPool, -- :: (Pool -> IO b) -> IO b
28
29 -- * (Re-)Allocation within a pool
30 pooledMalloc, -- :: Storable a => Pool -> IO (Ptr a)
31 pooledMallocBytes, -- :: Pool -> Int -> IO (Ptr a)
32
33 pooledRealloc, -- :: Storable a => Pool -> Ptr a -> IO (Ptr a)
34 pooledReallocBytes, -- :: Pool -> Ptr a -> Int -> IO (Ptr a)
35
36 pooledMallocArray, -- :: Storable a => Pool -> Int -> IO (Ptr a)
37 pooledMallocArray0, -- :: Storable a => Pool -> Int -> IO (Ptr a)
38
39 pooledReallocArray, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
40 pooledReallocArray0, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
41
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)
46 ) where
47
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(..) )
56 #else
57 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
58 #if defined(__NHC__)
59 import IO ( bracket )
60 #else
61 import Control.Exception.Base ( bracket )
62 #endif
63 #endif
64
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) )
72
73 --------------------------------------------------------------------------------
74
75 -- To avoid non-H98 stuff like existentially quantified data constructors, we
76 -- simply use pointers to () below. Not very nice, but...
77
78 -- | A memory pool.
79
80 newtype Pool = Pool (IORef [Ptr ()])
81
82 -- | Allocate a fresh memory pool.
83
84 newPool :: IO Pool
85 newPool = liftM Pool (newIORef [])
86
87 -- | Deallocate a memory pool and everything which has been allocated in the
88 -- pool itself.
89
90 freePool :: Pool -> IO ()
91 freePool (Pool pool) = readIORef pool >>= freeAll
92 where freeAll [] = return ()
93 freeAll (p:ps) = free p >> freeAll ps
94
95 -- | Execute an action with a fresh memory pool, which gets automatically
96 -- deallocated (including its contents) after the action has finished.
97
98 withPool :: (Pool -> IO b) -> IO b
99 #ifdef __GLASGOW_HASKELL__
100 withPool act = -- ATTENTION: cut-n-paste from Control.Exception below!
101 mask (\restore -> do
102 pool <- newPool
103 val <- catchAny
104 (restore (act pool))
105 (\e -> do freePool pool; throw e)
106 freePool pool
107 return val)
108 #else
109 withPool = bracket newPool freePool
110 #endif
111
112 --------------------------------------------------------------------------------
113
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.
117
118 pooledMalloc :: Storable a => Pool -> IO (Ptr a)
119 pooledMalloc = pm undefined
120 where
121 pm :: Storable a' => a' -> Pool -> IO (Ptr a')
122 pm dummy pool = pooledMallocBytes pool (sizeOf dummy)
123
124 -- | Allocate the given number of bytes of storage in the pool.
125
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)
131 return (castPtr ptr)
132
133 -- | Adjust the storage area for an element in the pool to the given size of
134 -- the required type.
135
136 pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a)
137 pooledRealloc = pr undefined
138 where
139 pr :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a')
140 pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy)
141
142 -- | Adjust the storage area for an element in the pool to the given size.
143
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)
152
153 -- | Allocate storage for the given number of elements of a storable type in the
154 -- pool.
155
156 pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a)
157 pooledMallocArray = pma undefined
158 where
159 pma :: Storable a' => a' -> Pool -> Int -> IO (Ptr a')
160 pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy)
161
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.
164
165 pooledMallocArray0 :: Storable a => Pool -> Int -> IO (Ptr a)
166 pooledMallocArray0 pool size =
167 pooledMallocArray pool (size + 1)
168
169 -- | Adjust the size of an array in the given pool.
170
171 pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
172 pooledReallocArray = pra undefined
173 where
174 pra :: Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a')
175 pra dummy pool ptr size = pooledReallocBytes pool ptr (size * sizeOf dummy)
176
177 -- | Adjust the size of an array with an end marker in the given pool.
178
179 pooledReallocArray0 :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
180 pooledReallocArray0 pool ptr size =
181 pooledReallocArray pool ptr (size + 1)
182
183 --------------------------------------------------------------------------------
184
185 -- | Allocate storage for a value in the given pool and marshal the value into
186 -- this storage.
187
188 pooledNew :: Storable a => Pool -> a -> IO (Ptr a)
189 pooledNew pool val = do
190 ptr <- pooledMalloc pool
191 poke ptr val
192 return ptr
193
194 -- | Allocate consecutive storage for a list of values in the given pool and
195 -- marshal these values into it.
196
197 pooledNewArray :: Storable a => Pool -> [a] -> IO (Ptr a)
198 pooledNewArray pool vals = do
199 ptr <- pooledMallocArray pool (length vals)
200 pokeArray ptr vals
201 return ptr
202
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.
205
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
210 return ptr