[implement Foreign.Marshal.Pool efficiently using unboxed values
John Meacham <john@repetae.net>**20060427040824] hunk ./lib/base/Foreign/Marshal/Pool.hs 7
--- 
+--
hunk ./lib/base/Foreign/Marshal/Pool.hs 19
+-- modified by John Meacham to use unboxed linked lists directly
+--
hunk ./lib/base/Foreign/Marshal/Pool.hs 23
-module Foreign.Marshal.Pool () where {- FIXME
+module Foreign.Marshal.Pool(
hunk ./lib/base/Foreign/Marshal/Pool.hs 25
-   Pool,
+   Pool(),
hunk ./lib/base/Foreign/Marshal/Pool.hs 49
-#ifdef __GLASGOW_HASKELL__
-import GHC.Base              ( Int, Monad(..), (.), not )
-import GHC.Err               ( undefined )
-import GHC.Exception         ( block, unblock, throw, catchException )
-import GHC.IOBase            ( IO, 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 )
-#else
hunk ./lib/base/Foreign/Marshal/Pool.hs 50
-#endif
-#endif
-
-import Control.Monad         ( liftM )
-import Data.List             ( delete )
-import Foreign.Marshal.Alloc ( mallocBytes, reallocBytes, free )
+import Foreign.Marshal.Alloc
hunk ./lib/base/Foreign/Marshal/Pool.hs 52
-import Foreign.Marshal.Error ( throwIf )
-import Foreign.Ptr           ( Ptr, castPtr )
-import Foreign.Storable      ( Storable(sizeOf, poke) )
+import Foreign.Ptr
+import Foreign.Storable
hunk ./lib/base/Foreign/Marshal/Pool.hs 62
-newtype Pool = Pool (IORef [Ptr ()])
+
+
+newtype Pool = Pool (Ptr (Ptr ())) -- (IORef [Ptr ()])
hunk ./lib/base/Foreign/Marshal/Pool.hs 69
-newPool = liftM Pool (newIORef [])
+newPool = do
+    pool <- malloc
+    poke pool nullPtr
+    return $ Pool pool
hunk ./lib/base/Foreign/Marshal/Pool.hs 78
-freePool (Pool pool) = readIORef pool >>= freeAll
-   where freeAll []     = return ()
-         freeAll (p:ps) = free p >> freeAll ps
+freePool (Pool pool) = f pool where
+    f p = do
+        v <- peek p
+        free p
+        if v == nullPtr then return () else f (castPtr v :: Ptr (Ptr ()))
hunk ./lib/base/Foreign/Marshal/Pool.hs 88
-#ifdef __GLASGOW_HASKELL__
-withPool act =   -- ATTENTION: cut-n-paste from Control.Exception below!
-   block (do
-      pool <- newPool
-      val <- catchException
-                (unblock (act pool))
-                (\e -> do freePool pool; throw e)
-      freePool pool
-      return val)
-#else
hunk ./lib/base/Foreign/Marshal/Pool.hs 89
-#endif
hunk ./lib/base/Foreign/Marshal/Pool.hs 106
-   ptr <- mallocBytes size
-   ptrs <- readIORef pool
-   writeIORef pool (ptr:ptrs)
-   return (castPtr ptr)
+    ptr <- mallocBytes (size + sizeOf pool)
+    v <- peek pool
+    poke ptr (v :: Ptr ())
+    return ((ptr :: Ptr (Ptr ())) `plusPtr` sizeOf pool)
hunk ./lib/base/Foreign/Marshal/Pool.hs 123
-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)
+pooledReallocBytes = error "pools don't support reallocing the size" --(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)
hunk ./lib/base/Foreign/Marshal/Pool.hs 189
--}
+
+