resource-pool 0.2.0.3 → 0.2.0.4

raw patch · 2 files changed

+27/−8 lines, 2 filesdep +transformers-basedep ~monad-control

Dependencies added: transformers-base

Dependency ranges changed: monad-control

Files

• Data/Pool.hs +25/−7
• resource-pool.cabal +2/−1

@@ -1,5 +1,9 @@ {-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ScopedTypeVariables #-} +#if MIN_VERSION_monad_control(0,3,0)+{-# LANGUAGE FlexibleContexts #-}+#endif+ -- | -- Module:      Data.Pool -- Copyright:   (c) 2011 MailRank, Inc.@@ -30,8 +34,6 @@ import Control.Concurrent.STM import Control.Exception (SomeException, catch, onException) import Control.Monad (forM_, forever, join, liftM2, unless, when)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.IO.Control (MonadControlIO, controlIO) import Data.Hashable (hash) import Data.List (partition) import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)@@ -39,6 +41,16 @@ import System.Mem.Weak (addFinalizer) import qualified Data.Vector as V +#if MIN_VERSION_monad_control(0,3,0)+import Control.Monad.Trans.Control (MonadBaseControl, control)+import Control.Monad.Base (liftBase)+#else+import Control.Monad.IO.Control (MonadControlIO, controlIO)+import Control.Monad.IO.Class (liftIO)+#define control controlIO+#define liftBase liftIO+#endif+ -- | A single resource pool entry. data Entry a = Entry {       entry :: a@@ -164,12 +176,18 @@ -- destroy a pooled resource, as doing so will almost certainly cause -- a subsequent user (who expects the resource to be valid) to throw -- an exception.-withResource :: MonadControlIO m => Pool a -> (a -> m b) -> m b+withResource ::+#if MIN_VERSION_monad_control(0,3,0)+    (MonadBaseControl IO m)+#else+    (MonadControlIO m)+#endif+  => Pool a -> (a -> m b) -> m b {-# SPECIALIZE withResource :: Pool a -> (a -> IO b) -> IO b #-} withResource Pool{..} act = do-  i <- liftIO $ ((`mod` numStripes) . hash) <$> myThreadId+  i <- liftBase $ ((`mod` numStripes) . hash) <$> myThreadId   let LocalPool{..} = localPools V.! i-  resource <- liftIO . join . atomically $ do+  resource <- liftBase . join . atomically $ do     ents <- readTVar entries     case ents of       (Entry{..}:es) -> writeTVar entries es >> return (return entry)@@ -179,10 +197,10 @@         writeTVar inUse $! used + 1         return $           create `onException` atomically (modifyTVar_ inUse (subtract 1))-  ret <- controlIO $ \runInIO -> runInIO (act resource) `onException` (do+  ret <- control $ \runInIO -> runInIO (act resource) `onException` (do            destroy resource `catch` \(_::SomeException) -> return ()            atomically (modifyTVar_ inUse (subtract 1)))-  liftIO $ do+  liftBase $ do     now <- getCurrentTime     atomically $ modifyTVar_ entries (Entry resource now:)   return ret

@@ -1,5 +1,5 @@ name:                resource-pool-version:             0.2.0.3+version:             0.2.0.4 synopsis:            A high-performance striped resource pooling implementation description:   A high-performance striped pooling abstraction for managing@@ -32,6 +32,7 @@     hashable,     monad-control >= 0.2.0.1,     transformers,+    transformers-base >= 0.4,     stm,     time,     vector >= 0.7