resource-pool 0.3.1.0 → 0.4.0.0

raw patch · 5 files changed

+94/−31 lines, 5 filesdep +hashable

Dependencies added: hashable

Files

• CHANGELOG.md +7/−0
• resource-pool.cabal +4/−2
• src/Data/Pool.hs +9/−4
• src/Data/Pool/Internal.hs +66/−21
• src/Data/Pool/Introspection.hs +8/−4

@@ -1,3 +1,10 @@+# resource-pool-0.4.0.0 (2023-01-16)+* Require `poolMaxResources` to be not smaller than the number of stripes.+* Add support for setting the number of stripes.+* Hide the constructor of `PoolConfig` from the public API and provide+  `defaultPoolConfig` so that future additions to `PoolConfig` don't require+  major version bumps.+ # resource-pool-0.3.1.0 (2022-06-15) * Add `tryWithResource` and `tryTakeResource`. 

@@ -1,7 +1,7 @@ cabal-version:       2.4 build-type:          Simple name:                resource-pool-version:             0.3.1.0+version:             0.4.0.0 license:             BSD-3-Clause license-file:        LICENSE category:            Data, Database, Network@@ -14,7 +14,8 @@              flexibly-sized collections of resources such as database              connections. -tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3+tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.5+              || ==9.4.3  extra-doc-files:   CHANGELOG.md@@ -33,6 +34,7 @@                    Data.Pool.Introspection    build-depends: base >= 4.11 && < 5+               , hashable >= 1.1.0.0                , primitive >= 0.7                , time 

@@ -2,11 +2,15 @@ -- collections of resources such as database connections. module Data.Pool   ( -- * Pool-    PoolConfig(..)-  , Pool+    Pool   , LocalPool   , newPool +    -- ** Configuration+  , PoolConfig+  , defaultPoolConfig+  , setNumStripes+     -- * Resource management   , withResource   , takeResource@@ -72,7 +76,7 @@     else takeAvailableResource pool lp stripe  -- | A variant of 'withResource' that doesn't execute the action and returns--- 'Nothing' instead of blocking if the capability-local pool is exhausted.+-- 'Nothing' instead of blocking if the local pool is exhausted. tryWithResource :: Pool a -> (a -> IO r) -> IO (Maybe r) tryWithResource pool act = mask $ \unmask -> tryTakeResource pool >>= \case   Just (res, localPool) -> do@@ -82,7 +86,7 @@   Nothing -> pure Nothing  -- | A variant of 'takeResource' that returns 'Nothing' instead of blocking if--- the capability-local pool is exhausted.+-- the local pool is exhausted. tryTakeResource :: Pool a -> IO (Maybe (a, LocalPool a)) tryTakeResource pool = mask_ $ do   lp <- getLocalPool (localPools pool)@@ -103,6 +107,7 @@   , freeResource     = free   , poolCacheTTL     = realToFrac idleTime   , poolMaxResources = numStripes * maxResources+  , poolNumStripes   = Just numStripes   }  ----------------------------------------

@@ -8,23 +8,20 @@ import Control.Concurrent import Control.Exception import Control.Monad+import Data.Hashable (hash) import Data.IORef import Data.Primitive.SmallArray import GHC.Clock import qualified Data.List as L  -- | Striped resource pool based on "Control.Concurrent.QSem".------ The number of stripes is arranged to be equal to the number of capabilities--- so that they never compete over access to the same stripe. This results in a--- very good performance in a multi-threaded environment. data Pool a = Pool   { poolConfig   :: !(PoolConfig a)   , localPools   :: !(SmallArray (LocalPool a))   , reaperRef    :: !(IORef ())   } --- | A single, capability-local pool.+-- | A single, local pool. data LocalPool a = LocalPool   { stripeId   :: !Int   , stripeVar  :: !(MVar (Stripe a))@@ -53,30 +50,60 @@  -- | Configuration of a 'Pool'. data PoolConfig a = PoolConfig-  { createResource :: !(IO a)-    -- ^ The action that creates a new resource.-  , freeResource :: !(a -> IO ())-    -- ^ The action that destroys an existing resource.-  , poolCacheTTL :: !Double+  { createResource   :: !(IO a)+  , freeResource     :: !(a -> IO ())+  , poolCacheTTL     :: !Double+  , poolMaxResources :: !Int+  , poolNumStripes   :: !(Maybe Int)+  }++-- | Create a 'PoolConfig' with optional parameters having default values.+--+-- For setting optional parameters have a look at:+--+-- - 'setNumStripes'+--+-- @since 0.4.0.0+defaultPoolConfig+  :: IO a+  -- ^ The action that creates a new resource.+  -> (a -> IO ())+  -- ^ The action that destroys an existing resource.+  -> Double   -- ^ The amount of seconds for which an unused resource is kept around. The   -- smallest acceptable value is @0.5@.   --   -- /Note:/ the elapsed time before destroying a resource may be a little   -- longer than requested, as the collector thread wakes at 1-second intervals.-  , poolMaxResources :: !Int-  -- ^ The maximum number of resources to keep open across all stripes. The+  -> Int+  -- ^ The maximum number of resources to keep open __across all stripes__. The   -- smallest acceptable value is @1@.   --   -- /Note:/ for each stripe the number of resources is divided by the number of-  -- capabilities and rounded up. Therefore the pool might end up creating up to-  -- @N - 1@ resources more in total than specified, where @N@ is the number of-  -- capabilities.+  -- stripes and rounded up, hence the pool might end up creating up to @N - 1@+  -- resources more in total than specified, where @N@ is the number of stripes.+  -> PoolConfig a+defaultPoolConfig create free cacheTTL maxResources = PoolConfig+  { createResource   = create+  , freeResource     = free+  , poolCacheTTL     = cacheTTL+  , poolMaxResources = maxResources+  , poolNumStripes   = Nothing   } --- | Create a new striped resource pool.+-- | Set the number of stripes in the pool. ----- The number of stripes is equal to the number of capabilities.+-- If set to 'Nothing' (the default value), the pool will create the amount of+-- stripes equal to the number of capabilities. This ensures that threads never+-- compete over access to the same stripe and results in a very good performance+-- in a multi-threaded environment. --+-- @since 0.4.0.0+setNumStripes :: Maybe Int -> PoolConfig a -> PoolConfig a+setNumStripes numStripes pc = pc { poolNumStripes = numStripes }++-- | Create a new striped resource pool.+-- -- /Note:/ although the runtime system will destroy all idle resources when the -- pool is garbage collected, it's recommended to manually call -- 'destroyAllResources' when you're done with the pool so that the resources@@ -87,9 +114,11 @@     error "poolCacheTTL must be at least 0.5"   when (poolMaxResources pc < 1) $ do     error "poolMaxResources must be at least 1"-  numStripes <- getNumCapabilities+  numStripes <- maybe getNumCapabilities pure (poolNumStripes pc)   when (numStripes < 1) $ do     error "numStripes must be at least 1"+  when (poolMaxResources pc < numStripes) $ do+    error "poolMaxResources must not be smaller than numStripes"   pools <- fmap (smallArrayFromListN numStripes) . forM [1..numStripes] $ \n -> do     ref <- newIORef ()     stripe <- newMVar Stripe@@ -168,11 +197,27 @@ ---------------------------------------- -- Helpers --- | Get a capability-local pool.+-- | Get a local pool. getLocalPool :: SmallArray (LocalPool a) -> IO (LocalPool a) getLocalPool pools = do-  (cid, _) <- threadCapability =<< myThreadId-  pure $ pools `indexSmallArray` (cid `rem` sizeofSmallArray pools)+  sid <- if stripes == 1+    -- If there is just one stripe, there is no choice.+    then pure 0+    else do+      capabilities <- getNumCapabilities+      -- If the number of stripes is smaller than the number of capabilities and+      -- doesn't divide it, selecting a stripe by a capability the current+      -- thread runs on wouldn't give equal load distribution across all stripes+      -- (e.g. if there are 2 stripes and 3 capabilities, stripe 0 would be used+      -- by capability 0 and 2, while stripe 1 would only be used by capability+      -- 1, a 100% load difference). In such case we select based on the id of a+      -- thread.+      if stripes < capabilities && capabilities `rem` stripes /= 0+        then hash <$> myThreadId+        else fmap fst . threadCapability =<< myThreadId+  pure $ pools `indexSmallArray` (sid `rem` stripes)+  where+    stripes = sizeofSmallArray pools  -- | Wait for the resource to be put into a given 'MVar'. waitForResource :: MVar (Stripe a) -> MVar (Maybe a) -> IO (Maybe a)

@@ -1,11 +1,15 @@ -- | A variant of "Data.Pool" with introspection capabilities. module Data.Pool.Introspection   ( -- * Pool-    PoolConfig(..)-  , Pool+    Pool   , LocalPool   , newPool +  -- ** Configuration+  , PoolConfig+  , defaultPoolConfig+  , setNumStripes+     -- * Resource management   , Resource(..)   , Acquisition(..)@@ -89,7 +93,7 @@     else takeAvailableResource pool t1 lp stripe  -- | A variant of 'withResource' that doesn't execute the action and returns--- 'Nothing' instead of blocking if the capability-local pool is exhausted.+-- 'Nothing' instead of blocking if the local pool is exhausted. tryWithResource :: Pool a -> (Resource a -> IO r) -> IO (Maybe r) tryWithResource pool act = mask $ \unmask -> tryTakeResource pool >>= \case   Just (res, localPool) -> do@@ -99,7 +103,7 @@   Nothing -> pure Nothing  -- | A variant of 'takeResource' that returns 'Nothing' instead of blocking if--- the capability-local pool is exhausted.+-- the local pool is exhausted. tryTakeResource :: Pool a -> IO (Maybe (Resource a, LocalPool a)) tryTakeResource pool = mask_ $ do   t1 <- getMonotonicTime