/usr/lib/hugs/packages/base/Foreign/Marshal/Pool.hs is in libhugs-base-bundled 98.200609.21-5.3ubuntu1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 | {-# OPTIONS_GHC -fno-implicit-prelude #-}
--------------------------------------------------------------------------------
-- |
-- 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, -- :: IO Pool
freePool, -- :: Pool -> IO ()
withPool, -- :: (Pool -> IO b) -> IO b
-- * (Re-)Allocation within a pool
pooledMalloc, -- :: Storable a => Pool -> IO (Ptr a)
pooledMallocBytes, -- :: Pool -> Int -> IO (Ptr a)
pooledRealloc, -- :: Storable a => Pool -> Ptr a -> IO (Ptr a)
pooledReallocBytes, -- :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledMallocArray, -- :: Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray0, -- :: Storable a => Pool -> Int -> IO (Ptr a)
pooledReallocArray, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray0, -- :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
-- * Combined allocation and marshalling
pooledNew, -- :: Storable a => Pool -> a -> IO (Ptr a)
pooledNewArray, -- :: Storable a => Pool -> [a] -> IO (Ptr a)
pooledNewArray0 -- :: Storable a => Pool -> a -> [a] -> IO (Ptr a)
) where
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Control.Exception ( bracket )
import Control.Monad ( liftM )
import Data.List ( 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-H98 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 = liftM Pool (newIORef [])
-- | Deallocate a memory pool and everything which has been allocated in the
-- pool itself.
freePool :: Pool -> IO ()
freePool (Pool pool) = readIORef pool >>= freeAll
where freeAll [] = return ()
freeAll (p:ps) = free p >> freeAll 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 = bracket newPool freePool
--------------------------------------------------------------------------------
-- | 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 :: Storable a => Pool -> IO (Ptr a)
pooledMalloc = pm undefined
where
pm :: Storable a' => a' -> Pool -> IO (Ptr a')
pm dummy pool = pooledMallocBytes pool (sizeOf dummy)
-- | Allocate the given number of bytes of storage in the pool.
pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
pooledMallocBytes (Pool pool) size = do
ptr <- mallocBytes size
ptrs <- readIORef pool
writeIORef pool (ptr:ptrs)
return (castPtr ptr)
-- | Adjust the storage area for an element in the pool to the given size of
-- the required type.
pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a)
pooledRealloc = pr undefined
where
pr :: Storable a' => a' -> Pool -> Ptr a' -> IO (Ptr a')
pr dummy pool ptr = pooledReallocBytes pool ptr (sizeOf dummy)
-- | Adjust the storage area for an element in the pool to the given size.
pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocBytes (Pool pool) ptr size = do
let cPtr = castPtr ptr
throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)
newPtr <- reallocBytes cPtr size
ptrs <- readIORef pool
writeIORef pool (newPtr : delete cPtr ptrs)
return (castPtr newPtr)
-- | Allocate storage for the given number of elements of a storable type in the
-- pool.
pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a)
pooledMallocArray = pma undefined
where
pma :: Storable a' => a' -> Pool -> Int -> IO (Ptr a')
pma dummy pool size = pooledMallocBytes pool (size * sizeOf dummy)
-- | 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 size =
pooledMallocArray pool (size + 1)
-- | Adjust the size of an array in the given pool.
pooledReallocArray :: Storable a => Pool -> Ptr a -> Int -> IO (Ptr a)
pooledReallocArray = pra undefined
where
pra :: Storable a' => a' -> Pool -> Ptr a' -> Int -> IO (Ptr a')
pra dummy pool ptr size = pooledReallocBytes pool ptr (size * sizeOf dummy)
-- | 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 size =
pooledReallocArray pool ptr (size + 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 val = do
ptr <- pooledMalloc 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 pool vals = do
ptr <- pooledMallocArray pool (length 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 pool marker vals = do
ptr <- pooledMallocArray0 pool (length vals)
pokeArray0 marker ptr vals
return ptr
|