final revision to GArrow classes

[ghc-base.git] / Foreign / Marshal / Pool.hs

diff --git a/Foreign/Marshal/Pool.hs b/Foreign/Marshal/Pool.hs
index 0aa4caf..ed94e46 100644 (file)
--- a/Foreign/Marshal/Pool.hs
+++ b/Foreign/Marshal/Pool.hs
@@ -1,10 +1,12 @@
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Foreign.Marshal.Pool
--- Copyright   :  (c) Sven Panne 2003
+-- Copyright   :  (c) Sven Panne 2002-2004
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
--- Maintainer  :  sven_panne@yahoo.com
+-- Maintainer  :  sven.panne@aedion.de
 -- Stability   :  provisional
 -- Portability :  portable
 --
@@ -43,19 +45,30 @@ module Foreign.Marshal.Pool (
    pooledNewArray0      -- :: Storable a => Pool -> a -> [a]     -> IO (Ptr a)
 ) where
 
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base              ( Int, Monad(..), (.), 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(..) )
+#else
+import Data.IORef            ( IORef, newIORef, readIORef, writeIORef )
 #if defined(__NHC__)
-import IO                       ( bracket )
+import IO                    ( bracket )
 #else
-import Control.Exception        ( bracket )
+import Control.Exception.Base ( bracket )
+#endif
 #endif
-import Control.Monad            ( liftM )
-import Data.IORef               ( IORef, newIORef, readIORef, modifyIORef )
-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) )
+
+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) )
 
 --------------------------------------------------------------------------------
 
@@ -69,19 +82,32 @@ newtype Pool = Pool (IORef [Ptr ()])
 -- | Allocate a fresh memory pool.
 
 newPool :: IO Pool
-newPool = liftM Pool $ newIORef []
+newPool = liftM Pool (newIORef [])
 
 -- | Deallocate a memory pool and everything which has been allocated in the
 -- pool itself.
 
 freePool :: Pool -> IO ()
-freePool (Pool ps) = readIORef ps >>= mapM_ free
+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
+#ifdef __GLASGOW_HASKELL__
+withPool act =   -- ATTENTION: cut-n-paste from Control.Exception below!
+   mask (\restore -> do
+      pool <- newPool
+      val <- catchAny
+                (restore (act pool))
+                (\e -> do freePool pool; throw e)
+      freePool pool
+      return val)
+#else
 withPool = bracket newPool freePool
+#endif
 
 --------------------------------------------------------------------------------
 
@@ -92,7 +118,7 @@ withPool = bracket newPool freePool
 pooledMalloc :: Storable a => Pool -> IO (Ptr a)
 pooledMalloc = pm undefined
   where
-    pm           :: Storable a => a -> Pool -> IO (Ptr a)
+    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.
@@ -100,7 +126,8 @@ pooledMalloc = pm undefined
 pooledMallocBytes :: Pool -> Int -> IO (Ptr a)
 pooledMallocBytes (Pool pool) size = do
    ptr <- mallocBytes size
-   modifyIORef pool (ptr:)
+   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
@@ -109,7 +136,7 @@ pooledMallocBytes (Pool pool) size = do
 pooledRealloc :: Storable a => Pool -> Ptr a -> IO (Ptr a)
 pooledRealloc = pr undefined
   where
-    pr               :: Storable a => a -> Pool -> Ptr a -> IO (Ptr a)
+    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.
@@ -117,9 +144,10 @@ pooledRealloc = pr undefined
 pooledReallocBytes :: Pool -> Ptr a -> Int -> IO (Ptr a)
 pooledReallocBytes (Pool pool) ptr size = do
    let cPtr = castPtr ptr
-   throwIf (not . (cPtr `elem`)) (const "pointer not in pool") (readIORef pool)
+   _ <- throwIf (not . (cPtr `elem`)) (\_ -> "pointer not in pool") (readIORef pool)
    newPtr <- reallocBytes cPtr size
-   modifyIORef pool ((newPtr :) . delete cPtr)
+   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
@@ -128,7 +156,7 @@ pooledReallocBytes (Pool pool) ptr size = do
 pooledMallocArray :: Storable a => Pool -> Int -> IO (Ptr a)
 pooledMallocArray = pma undefined
   where
-    pma                :: Storable a => a -> Pool -> Int -> IO (Ptr a)
+    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
@@ -143,7 +171,7 @@ pooledMallocArray0 pool size =
 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                ::  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.