Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-resource-pool for
openSUSE:Factory checked in at 2025-07-31 17:45:39
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-resource-pool (Old)
and /work/SRC/openSUSE:Factory/.ghc-resource-pool.new.1944 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-resource-pool"
Thu Jul 31 17:45:39 2025 rev:14 rq:1296449 version:0.5.0.0
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-resource-pool/ghc-resource-pool.changes
2023-04-04 21:22:58.750066370 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-resource-pool.new.1944/ghc-resource-pool.changes
2025-07-31 17:46:37.601216717 +0200
@@ -1,0 +2,17 @@
+Fri Jun 13 16:44:53 UTC 2025 - Peter Simons <[email protected]>
+
+- Update resource-pool to version 0.5.0.0.
+ # resource-pool-0.5.0.0 (2025-06-13)
+ * Drop support for GHC < 8.10.
+ * Use STM based lockless implementation as it results in much better
throughput
+ in a multi-threaded environment when number of stripes is not equal to the
+ number of capabilities (in particular with a single stripe).
+ * Stop running resource freeing functions within `uninterruptibleMask`.
+ * `destroyResource` no longer ignores exceptions thrown from resource
releasing
+ functions.
+ * Change the default number of stripes to 1.
+ * Do not exceed the maximum number of resources if the number of stripes does
+ not divide it.
+ * Add support for assigning a label to the pool.
+
+-------------------------------------------------------------------
Old:
----
resource-pool-0.4.0.0.tar.gz
New:
----
resource-pool-0.5.0.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-resource-pool.spec ++++++
--- /var/tmp/diff_new_pack.03YrOd/_old 2025-07-31 17:46:38.189241156 +0200
+++ /var/tmp/diff_new_pack.03YrOd/_new 2025-07-31 17:46:38.193241323 +0200
@@ -1,7 +1,7 @@
#
# spec file for package ghc-resource-pool
#
-# Copyright (c) 2023 SUSE LLC
+# Copyright (c) 2025 SUSE LLC
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -19,7 +19,7 @@
%global pkg_name resource-pool
%global pkgver %{pkg_name}-%{version}
Name: ghc-%{pkg_name}
-Version: 0.4.0.0
+Version: 0.5.0.0
Release: 0
Summary: A high-performance striped resource pooling implementation
License: BSD-3-Clause
@@ -33,6 +33,10 @@
BuildRequires: ghc-primitive-devel
BuildRequires: ghc-primitive-prof
BuildRequires: ghc-rpm-macros
+BuildRequires: ghc-stm-devel
+BuildRequires: ghc-stm-prof
+BuildRequires: ghc-text-devel
+BuildRequires: ghc-text-prof
BuildRequires: ghc-time-devel
BuildRequires: ghc-time-prof
ExcludeArch: %{ix86}
++++++ resource-pool-0.4.0.0.tar.gz -> resource-pool-0.5.0.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.4.0.0/CHANGELOG.md
new/resource-pool-0.5.0.0/CHANGELOG.md
--- old/resource-pool-0.4.0.0/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
+++ new/resource-pool-0.5.0.0/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
@@ -1,3 +1,16 @@
+# resource-pool-0.5.0.0 (2025-06-13)
+* Drop support for GHC < 8.10.
+* Use STM based lockless implementation as it results in much better throughput
+ in a multi-threaded environment when number of stripes is not equal to the
+ number of capabilities (in particular with a single stripe).
+* Stop running resource freeing functions within `uninterruptibleMask`.
+* `destroyResource` no longer ignores exceptions thrown from resource releasing
+ functions.
+* Change the default number of stripes to 1.
+* Do not exceed the maximum number of resources if the number of stripes does
+ not divide it.
+* Add support for assigning a label to the pool.
+
# 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.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.4.0.0/README.md
new/resource-pool-0.5.0.0/README.md
--- old/resource-pool-0.4.0.0/README.md 2001-09-09 03:46:40.000000000 +0200
+++ new/resource-pool-0.5.0.0/README.md 2001-09-09 03:46:40.000000000 +0200
@@ -1,8 +1,7 @@
# resource-pool
-[](https://github.com/scrive/pool/actions?query=branch%3Amaster)
+[](https://github.com/scrive/pool/actions/workflows/haskell-ci.yml)
[](https://hackage.haskell.org/package/resource-pool)
-[](https://packdeps.haskellers.com/[email protected])
[](https://www.stackage.org/lts/package/resource-pool)
[](https://www.stackage.org/nightly/package/resource-pool)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.4.0.0/resource-pool.cabal
new/resource-pool-0.5.0.0/resource-pool.cabal
--- old/resource-pool-0.4.0.0/resource-pool.cabal 2001-09-09
03:46:40.000000000 +0200
+++ new/resource-pool-0.5.0.0/resource-pool.cabal 2001-09-09
03:46:40.000000000 +0200
@@ -1,7 +1,7 @@
-cabal-version: 2.4
+cabal-version: 3.0
build-type: Simple
name: resource-pool
-version: 0.4.0.0
+version: 0.5.0.0
license: BSD-3-Clause
license-file: LICENSE
category: Data, Database, Network
@@ -14,8 +14,7 @@
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.5
- || ==9.4.3
+tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2,
9.12.2 }
extra-doc-files:
CHANGELOG.md
@@ -33,16 +32,24 @@
Data.Pool.Internal
Data.Pool.Introspection
- build-depends: base >= 4.11 && < 5
+ build-depends: base >= 4.14 && < 5
, hashable >= 1.1.0.0
, primitive >= 0.7
+ , stm
+ , text
, time
- ghc-options: -Wall -Wcompat
+ ghc-options: -Wall
+ -Wcompat
+ -Wmissing-deriving-strategies
+ -Werror=prepositive-qualified-module
default-language: Haskell2010
default-extensions: DeriveGeneric
+ , DerivingStrategies
+ , ImportQualifiedPost
, LambdaCase
, RankNTypes
+ , ScopedTypeVariables
, TypeApplications
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.4.0.0/src/Data/Pool/Internal.hs
new/resource-pool-0.5.0.0/src/Data/Pool/Internal.hs
--- old/resource-pool-0.4.0.0/src/Data/Pool/Internal.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/resource-pool-0.5.0.0/src/Data/Pool/Internal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,60 +1,67 @@
+{-# OPTIONS_HADDOCK not-home #-}
+
-- | Internal implementation details for "Data.Pool".
--
-- This module is intended for internal use only, and may change without
warning
-- in subsequent releases.
-{-# OPTIONS_HADDOCK not-home #-}
module Data.Pool.Internal where
import Control.Concurrent
+import Control.Concurrent.STM
import Control.Exception
import Control.Monad
+import Data.Either
import Data.Hashable (hash)
import Data.IORef
+import Data.List qualified as L
import Data.Primitive.SmallArray
-import GHC.Clock
-import qualified Data.List as L
+import Data.Text qualified as T
+import GHC.Clock (getMonotonicTime)
+import GHC.Conc (labelThread, unsafeIOToSTM)
-- | Striped resource pool based on "Control.Concurrent.QSem".
data Pool a = Pool
- { poolConfig :: !(PoolConfig a)
- , localPools :: !(SmallArray (LocalPool a))
- , reaperRef :: !(IORef ())
+ { poolConfig :: !(PoolConfig a)
+ , localPools :: !(SmallArray (LocalPool a))
+ , reaperRef :: !(IORef ())
}
-- | A single, local pool.
data LocalPool a = LocalPool
- { stripeId :: !Int
- , stripeVar :: !(MVar (Stripe a))
+ { stripeId :: !Int
+ , stripeVar :: !(TVar (Stripe a))
, cleanerRef :: !(IORef ())
}
-- | Stripe of a resource pool. If @available@ is 0, the list of threads
waiting
--- for a resource (each with an associated 'MVar') is @queue ++ reverse
queueR@.
+-- for a resource (each with an associated 'TMVar') is @queue ++ reverse
queueR@
+-- to ensure fairness.
data Stripe a = Stripe
{ available :: !Int
- , cache :: ![Entry a]
- , queue :: !(Queue a)
- , queueR :: !(Queue a)
+ , cache :: ![Entry a]
+ , queue :: !(Queue a)
+ , queueR :: !(Queue a)
}
-- | An existing resource currently sitting in a pool.
data Entry a = Entry
- { entry :: a
+ { entry :: a
, lastUsed :: !Double
}
--- | A queue of MVarS corresponding to threads waiting for resources.
+-- | A queue of TMVarS corresponding to threads waiting for resources.
--
-- Basically a monomorphic list to save two pointer indirections.
-data Queue a = Queue !(MVar (Maybe a)) (Queue a) | Empty
+data Queue a = Queue !(TMVar (Maybe a)) (Queue a) | Empty
-- | Configuration of a 'Pool'.
data PoolConfig a = PoolConfig
- { createResource :: !(IO a)
- , freeResource :: !(a -> IO ())
- , poolCacheTTL :: !Double
+ { createResource :: !(IO a)
+ , freeResource :: !(a -> IO ())
+ , poolCacheTTL :: !Double
, poolMaxResources :: !Int
- , poolNumStripes :: !(Maybe Int)
+ , poolNumStripes :: !(Maybe Int)
+ , pcLabel :: !T.Text
}
-- | Create a 'PoolConfig' with optional parameters having default values.
@@ -70,37 +77,51 @@
-> (a -> IO ())
-- ^ The action that destroys an existing resource.
-> Double
- -- ^ The amount of seconds for which an unused resource is kept around. The
+ -- ^ The number 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.
-> Int
-- ^ The maximum number of resources to keep open __across all stripes__. The
- -- smallest acceptable value is @1@.
+ -- smallest acceptable value is @1@ per stripe.
--
- -- /Note:/ for each stripe the number of resources is divided by the number
of
- -- 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.
+ -- /Note:/ if the number of stripes does not divide the number of resources,
+ -- some of the stripes will have 1 more resource available than the others.
-> PoolConfig a
-defaultPoolConfig create free cacheTTL maxResources = PoolConfig
- { createResource = create
- , freeResource = free
- , poolCacheTTL = cacheTTL
- , poolMaxResources = maxResources
- , poolNumStripes = Nothing
- }
-
--- | Set the number of stripes in the pool.
+defaultPoolConfig create free cacheTTL maxResources =
+ PoolConfig
+ { createResource = create
+ , freeResource = free
+ , poolCacheTTL = cacheTTL
+ , poolMaxResources = maxResources
+ , poolNumStripes = Just 1
+ , pcLabel = T.empty
+ }
+
+-- | Set the number of stripes (sub-pools) in the pool.
--
--- 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.
+-- If not explicitly set, the default number of stripes is 1, which should be
+-- good for typical use (when in doubt, profile your application first).
+--
+-- If set to 'Nothing', the pool will create the number of stripes equal to the
+-- number of capabilities.
+--
+-- /Note:/ usage of multiple stripes reduces contention, but can also result in
+-- suboptimal use of resources since stripes are separated from each other.
--
-- @since 0.4.0.0
setNumStripes :: Maybe Int -> PoolConfig a -> PoolConfig a
-setNumStripes numStripes pc = pc { poolNumStripes = numStripes }
+setNumStripes numStripes pc = pc {poolNumStripes = numStripes}
+
+-- | Assign a label to the pool.
+--
+-- The label will appear in a label of the collector thread as well as
+-- t'Data.Pool.Introspection.Resource'.
+--
+-- @since 0.5.0.0
+setPoolLabel :: T.Text -> PoolConfig a -> PoolConfig a
+setPoolLabel label pc = pc {pcLabel = label}
-- | Create a new striped resource pool.
--
@@ -119,36 +140,51 @@
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
+ let mkArray = fmap (smallArrayFromListN numStripes)
+ pools <- mkArray . forM (stripeResources numStripes) $ \(n, resources) -> do
ref <- newIORef ()
- stripe <- newMVar Stripe
- { available = poolMaxResources pc `quotCeil` numStripes
- , cache = []
- , queue = Empty
- , queueR = Empty
- }
+ stripe <-
+ newTVarIO
+ Stripe
+ { available = resources
+ , cache = []
+ , queue = Empty
+ , queueR = Empty
+ }
-- When the local pool goes out of scope, free its resources.
void . mkWeakIORef ref $ cleanStripe (const True) (freeResource pc) stripe
- pure LocalPool { stripeId = n
- , stripeVar = stripe
- , cleanerRef = ref
- }
+ pure
+ LocalPool
+ { stripeId = n
+ , stripeVar = stripe
+ , cleanerRef = ref
+ }
mask_ $ do
- ref <- newIORef ()
- collectorA <- forkIOWithUnmask $ \unmask -> unmask $ collector pools
+ ref <- newIORef ()
+ collectorA <- forkIOWithUnmask $ \unmask -> unmask $ do
+ tid <- myThreadId
+ labelThread tid $ "resource-pool: collector (" ++ T.unpack (pcLabel pc)
++ ")"
+ collector pools
void . mkWeakIORef ref $ do
-- When the pool goes out of scope, stop the collector. Resources
existing
-- in stripes will be taken care by their cleaners.
killThread collectorA
- pure Pool { poolConfig = pc
- , localPools = pools
- , reaperRef = ref
- }
+ pure
+ Pool
+ { poolConfig = pc
+ , localPools = pools
+ , reaperRef = ref
+ }
where
- quotCeil :: Int -> Int -> Int
- quotCeil x y =
- -- Basically ceiling (x / y) without going through Double.
- let (z, r) = x `quotRem` y in if r == 0 then z else z + 1
+ stripeResources :: Int -> [(Int, Int)]
+ stripeResources numStripes =
+ let (base, rest) = quotRem (poolMaxResources pc) numStripes
+ in zip [1 .. numStripes] $ addRest (replicate numStripes base) rest
+ where
+ addRest [] = error "unreachable"
+ addRest acc@(r : rs) = \case
+ 0 -> acc
+ rest -> r + 1 : addRest rs (rest - 1)
-- Collect stale resources from the pool once per second.
collector pools = forever $ do
@@ -161,20 +197,19 @@
--
-- Note that this will ignore any exceptions in the destroy function.
destroyResource :: Pool a -> LocalPool a -> a -> IO ()
-destroyResource pool lp a = do
- uninterruptibleMask_ $ do -- Note [signal uninterruptible]
- stripe <- takeMVar (stripeVar lp)
+destroyResource pool lp a = mask_ $ do
+ atomically $ do
+ stripe <- readTVar (stripeVar lp)
newStripe <- signal stripe Nothing
- putMVar (stripeVar lp) newStripe
- void . try @SomeException $ freeResource (poolConfig pool) a
+ writeTVar (stripeVar lp) $! newStripe
+ freeResource (poolConfig pool) a
-- | Return a resource to the given 'LocalPool'.
putResource :: LocalPool a -> a -> IO ()
-putResource lp a = do
- uninterruptibleMask_ $ do -- Note [signal uninterruptible]
- stripe <- takeMVar (stripeVar lp)
- newStripe <- signal stripe (Just a)
- putMVar (stripeVar lp) newStripe
+putResource lp a = atomically $ do
+ stripe <- readTVar (stripeVar lp)
+ newStripe <- signal stripe (Just a)
+ writeTVar (stripeVar lp) $! newStripe
-- | Destroy all resources in all stripes in the pool.
--
@@ -200,121 +235,131 @@
-- | Get a local pool.
getLocalPool :: SmallArray (LocalPool a) -> IO (LocalPool a)
getLocalPool pools = do
- 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
+ sid <-
+ if stripes == 1
+ then -- If there is just one stripe, there is no choice.
+ 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)
-waitForResource mstripe q = takeMVar q `onException` cleanup
+-- | Wait for the resource to be put into a given 'TMVar'.
+waitForResource :: TVar (Stripe a) -> TMVar (Maybe a) -> IO (Maybe a)
+waitForResource mstripe q = atomically (takeTMVar q) `onException` cleanup
where
- cleanup = uninterruptibleMask_ $ do -- Note [signal uninterruptible]
- stripe <- takeMVar mstripe
- newStripe <- tryTakeMVar q >>= \case
- Just ma -> do
- -- Between entering the exception handler and taking ownership of
- -- the stripe we got the resource we wanted. We don't need it
- -- anymore though, so pass it to someone else.
- signal stripe ma
- Nothing -> do
- -- If we're still waiting, fill up the MVar with an undefined value
- -- so that 'signal' can discard our MVar from the queue.
- putMVar q $ error "unreachable"
- pure stripe
- putMVar mstripe newStripe
+ cleanup = atomically $ do
+ stripe <- readTVar mstripe
+ newStripe <-
+ tryTakeTMVar q >>= \case
+ Just ma -> do
+ -- Between entering the exception handler and taking ownership of
+ -- the stripe we got the resource we wanted. We don't need it
+ -- anymore though, so pass it to someone else.
+ signal stripe ma
+ Nothing -> do
+ -- If we're still waiting, fill up the TMVar with an undefined
value
+ -- so that 'signal' can discard our TMVar from the queue.
+ putTMVar q $ error "unreachable"
+ pure stripe
+ writeTVar mstripe $! newStripe
-- | If an exception is received while a resource is being created, restore the
-- original size of the stripe.
-restoreSize :: MVar (Stripe a) -> IO ()
-restoreSize mstripe = uninterruptibleMask_ $ do
- -- 'uninterruptibleMask_' is used since 'takeMVar' might block.
- stripe <- takeMVar mstripe
- putMVar mstripe $! stripe { available = available stripe + 1 }
+restoreSize :: TVar (Stripe a) -> IO ()
+restoreSize mstripe = atomically $ do
+ modifyTVar' mstripe $ \stripe -> stripe {available = available stripe + 1}
-- | Free resource entries in the stripes that fulfil a given condition.
cleanStripe
:: (Entry a -> Bool)
-> (a -> IO ())
- -> MVar (Stripe a)
+ -> TVar (Stripe a)
-> IO ()
-cleanStripe isStale free mstripe = mask $ \unmask -> do
+cleanStripe isStale free mstripe = mask_ $ do
-- Asynchronous exceptions need to be masked here to prevent leaking of
-- 'stale' resources before they're freed.
- stale <- modifyMVar mstripe $ \stripe -> unmask $ do
+ stale <- atomically $ do
+ stripe <- readTVar mstripe
let (stale, fresh) = L.partition isStale (cache stripe)
- -- There's no need to update 'available' here because it only tracks
- -- the number of resources taken from the pool.
- newStripe = stripe { cache = fresh }
- newStripe `seq` pure (newStripe, map entry stale)
+ -- There's no need to update 'available' here because it only tracks
+ -- the number of resources taken from the pool.
+ writeTVar mstripe $! stripe {cache = fresh}
+ pure $ map entry stale
-- We need to ignore exceptions in the 'free' function, otherwise if an
-- exception is thrown half-way, we leak the rest of the resources. Also,
- -- asynchronous exceptions need to be hard masked here since freeing a
- -- resource might in theory block.
- uninterruptibleMask_ . forM_ stale $ try @SomeException . free
-
--- Note [signal uninterruptible]
---
--- If we have
---
--- bracket takeResource putResource (...)
---
--- and an exception arrives at the putResource, then we must not lose the
--- resource. The putResource is masked by bracket, but taking the MVar might
--- block, and so it would be interruptible. Hence we need an uninterruptible
--- variant of mask here.
-signal :: Stripe a -> Maybe a -> IO (Stripe a)
-signal stripe ma = if available stripe == 0
- then loop (queue stripe) (queueR stripe)
- else do
- newCache <- case ma of
- Just a -> do
- now <- getMonotonicTime
- pure $ Entry a now : cache stripe
- Nothing -> pure $ cache stripe
- pure $! stripe { available = available stripe + 1
- , cache = newCache
- }
+ -- asynchronous exceptions need to be hard masked here we need to run 'free'
+ -- for all resources.
+ uninterruptibleMask $ \release -> do
+ rs <- forM stale $ try @SomeException . release . free
+ -- If any async exception arrived in between, propagate it.
+ rethrowFirstAsyncException $ lefts rs
where
+ rethrowFirstAsyncException = \case
+ [] -> pure ()
+ e : es
+ | Just SomeAsyncException {} <- fromException e -> throwIO e
+ | otherwise -> rethrowFirstAsyncException es
+
+signal :: forall a. Stripe a -> Maybe a -> STM (Stripe a)
+signal stripe ma =
+ if available stripe == 0
+ then loop (queue stripe) (queueR stripe)
+ else do
+ newCache <- case ma of
+ Just a -> do
+ now <- unsafeIOToSTM getMonotonicTime
+ pure $ Entry a now : cache stripe
+ Nothing -> pure $ cache stripe
+ pure
+ stripe
+ { available = available stripe + 1
+ , cache = newCache
+ }
+ where
+ loop :: Queue a -> Queue a -> STM (Stripe a)
loop Empty Empty = do
newCache <- case ma of
Just a -> do
- now <- getMonotonicTime
+ now <- unsafeIOToSTM getMonotonicTime
pure [Entry a now]
Nothing -> pure []
- pure $! Stripe { available = 1
- , cache = newCache
- , queue = Empty
- , queueR = Empty
- }
- loop Empty qR = loop (reverseQueue qR) Empty
- loop (Queue q qs) qR = tryPutMVar q ma >>= \case
- -- This fails when 'waitForResource' went into the exception handler and
- -- filled the MVar (with an undefined value) itself. In such case we
- -- simply ignore it.
- False -> loop qs qR
- True -> pure $! stripe { available = 0
- , queue = qs
- , queueR = qR
- }
+ pure
+ Stripe
+ { available = 1
+ , cache = newCache
+ , queue = Empty
+ , queueR = Empty
+ }
+ loop Empty qR = loop (reverseQueue qR) Empty
+ loop (Queue q qs) qR =
+ tryPutTMVar q ma >>= \case
+ -- This fails when 'waitForResource' went into the exception handler
and
+ -- filled the TMVar (with an undefined value) itself. In such case we
+ -- simply ignore it.
+ False -> loop qs qR
+ True ->
+ pure
+ stripe
+ { available = 0
+ , queue = qs
+ , queueR = qR
+ }
-reverseQueue :: Queue a -> Queue a
-reverseQueue = go Empty
- where
- go acc = \case
- Empty -> acc
- Queue x xs -> go (Queue x acc) xs
+ reverseQueue :: Queue a -> Queue a
+ reverseQueue = go Empty
+ where
+ go acc = \case
+ Empty -> acc
+ Queue x xs -> go (Queue x acc) xs
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.4.0.0/src/Data/Pool/Introspection.hs
new/resource-pool-0.5.0.0/src/Data/Pool/Introspection.hs
--- old/resource-pool-0.4.0.0/src/Data/Pool/Introspection.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/resource-pool-0.5.0.0/src/Data/Pool/Introspection.hs 2001-09-09
03:46:40.000000000 +0200
@@ -5,14 +5,15 @@
, LocalPool
, newPool
- -- ** Configuration
+ -- ** Configuration
, PoolConfig
, defaultPoolConfig
, setNumStripes
+ , setPoolLabel
-- * Resource management
- , Resource(..)
- , Acquisition(..)
+ , Resource (..)
+ , Acquisition (..)
, withResource
, takeResource
, tryWithResource
@@ -22,30 +23,34 @@
, destroyAllResources
) where
-import Control.Concurrent
+import Control.Concurrent.STM
import Control.Exception
-import GHC.Clock
+import Control.Monad
+import Data.Text qualified as T
+import GHC.Clock (getMonotonicTime)
import GHC.Generics (Generic)
import Data.Pool.Internal
-- | A resource taken from the pool along with additional information.
data Resource a = Resource
- { resource :: a
- , stripeNumber :: !Int
+ { resource :: a
+ , poolLabel :: !T.Text
+ , stripeNumber :: !Int
, availableResources :: !Int
- , acquisition :: !Acquisition
- , acquisitionTime :: !Double
- , creationTime :: !(Maybe Double)
- } deriving (Eq, Show, Generic)
+ , acquisition :: !Acquisition
+ , acquisitionTime :: !Double
+ , creationTime :: !(Maybe Double)
+ }
+ deriving stock (Eq, Generic, Show)
-- | Describes how a resource was acquired from the pool.
data Acquisition
- = Immediate
- -- ^ A resource was taken from the pool immediately.
- | Delayed
- -- ^ The thread had to wait until a resource was released.
- deriving (Eq, Show, Generic)
+ = -- | A resource was taken from the pool immediately.
+ Immediate
+ | -- | The thread had to wait until a resource was released.
+ Delayed
+ deriving stock (Eq, Generic, Show)
-- | 'Data.Pool.withResource' with introspection capabilities.
withResource :: Pool a -> (Resource a -> IO r) -> IO r
@@ -60,47 +65,54 @@
takeResource pool = mask_ $ do
t1 <- getMonotonicTime
lp <- getLocalPool (localPools pool)
- stripe <- takeMVar (stripeVar lp)
- if available stripe == 0
- then do
- q <- newEmptyMVar
- putMVar (stripeVar lp) $! stripe { queueR = Queue q (queueR stripe) }
- waitForResource (stripeVar lp) q >>= \case
- Just a -> do
- t2 <- getMonotonicTime
- let res = Resource
- { resource = a
- , stripeNumber = stripeId lp
- , availableResources = 0
- , acquisition = Delayed
- , acquisitionTime = t2 - t1
- , creationTime = Nothing
- }
- pure (res, lp)
- Nothing -> do
- t2 <- getMonotonicTime
- a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
- t3 <- getMonotonicTime
- let res = Resource
- { resource = a
- , stripeNumber = stripeId lp
- , availableResources = 0
- , acquisition = Delayed
- , acquisitionTime = t2 - t1
- , creationTime = Just $! t3 - t2
- }
- pure (res, lp)
- else takeAvailableResource pool t1 lp stripe
+ join . atomically $ do
+ stripe <- readTVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ q <- newEmptyTMVar
+ writeTVar (stripeVar lp) $! stripe {queueR = Queue q (queueR stripe)}
+ pure
+ $ waitForResource (stripeVar lp) q >>= \case
+ Just a -> do
+ t2 <- getMonotonicTime
+ let res =
+ Resource
+ { resource = a
+ , poolLabel = pcLabel $ poolConfig pool
+ , stripeNumber = stripeId lp
+ , availableResources = 0
+ , acquisition = Delayed
+ , acquisitionTime = t2 - t1
+ , creationTime = Nothing
+ }
+ pure (res, lp)
+ Nothing -> do
+ t2 <- getMonotonicTime
+ a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
+ t3 <- getMonotonicTime
+ let res =
+ Resource
+ { resource = a
+ , poolLabel = pcLabel $ poolConfig pool
+ , stripeNumber = stripeId lp
+ , availableResources = 0
+ , acquisition = Delayed
+ , acquisitionTime = t2 - t1
+ , creationTime = Just $! t3 - t2
+ }
+ pure (res, lp)
+ else takeAvailableResource pool t1 lp stripe
-- | A variant of 'withResource' that doesn't execute the action and returns
-- '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
- r <- unmask (act res) `onException` destroyResource pool localPool
(resource res)
- putResource localPool (resource res)
- pure (Just r)
- Nothing -> pure Nothing
+tryWithResource pool act = mask $ \unmask ->
+ tryTakeResource pool >>= \case
+ Just (res, localPool) -> do
+ r <- unmask (act res) `onException` destroyResource pool localPool
(resource res)
+ putResource localPool (resource res)
+ pure (Just r)
+ Nothing -> pure Nothing
-- | A variant of 'takeResource' that returns 'Nothing' instead of blocking if
-- the local pool is exhausted.
@@ -108,12 +120,13 @@
tryTakeResource pool = mask_ $ do
t1 <- getMonotonicTime
lp <- getLocalPool (localPools pool)
- stripe <- takeMVar (stripeVar lp)
- if available stripe == 0
- then do
- putMVar (stripeVar lp) stripe
- pure Nothing
- else Just <$> takeAvailableResource pool t1 lp stripe
+ join . atomically $ do
+ stripe <- readTVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ writeTVar (stripeVar lp) stripe
+ pure $ pure Nothing
+ else fmap Just <$> takeAvailableResource pool t1 lp stripe
----------------------------------------
-- Helpers
@@ -123,33 +136,39 @@
-> Double
-> LocalPool a
-> Stripe a
- -> IO (Resource a, LocalPool a)
+ -> STM (IO (Resource a, LocalPool a))
takeAvailableResource pool t1 lp stripe = case cache stripe of
[] -> do
let newAvailable = available stripe - 1
- putMVar (stripeVar lp) $! stripe { available = newAvailable }
- t2 <- getMonotonicTime
- a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
- t3 <- getMonotonicTime
- let res = Resource
- { resource = a
- , stripeNumber = stripeId lp
- , availableResources = newAvailable
- , acquisition = Immediate
- , acquisitionTime = t2 - t1
- , creationTime = Just $! t3 - t2
- }
- pure (res, lp)
+ writeTVar (stripeVar lp) $! stripe {available = newAvailable}
+ pure $ do
+ t2 <- getMonotonicTime
+ a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
+ t3 <- getMonotonicTime
+ let res =
+ Resource
+ { resource = a
+ , poolLabel = pcLabel $ poolConfig pool
+ , stripeNumber = stripeId lp
+ , availableResources = newAvailable
+ , acquisition = Immediate
+ , acquisitionTime = t2 - t1
+ , creationTime = Just $! t3 - t2
+ }
+ pure (res, lp)
Entry a _ : as -> do
let newAvailable = available stripe - 1
- putMVar (stripeVar lp) $! stripe { available = newAvailable, cache = as }
- t2 <- getMonotonicTime
- let res = Resource
- { resource = a
- , stripeNumber = stripeId lp
- , availableResources = newAvailable
- , acquisition = Immediate
- , acquisitionTime = t2 - t1
- , creationTime = Nothing
- }
- pure (res, lp)
+ writeTVar (stripeVar lp) $! stripe {available = newAvailable, cache = as}
+ pure $ do
+ t2 <- getMonotonicTime
+ let res =
+ Resource
+ { resource = a
+ , poolLabel = pcLabel $ poolConfig pool
+ , stripeNumber = stripeId lp
+ , availableResources = newAvailable
+ , acquisition = Immediate
+ , acquisitionTime = t2 - t1
+ , creationTime = Nothing
+ }
+ pure (res, lp)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.4.0.0/src/Data/Pool.hs
new/resource-pool-0.5.0.0/src/Data/Pool.hs
--- old/resource-pool-0.4.0.0/src/Data/Pool.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/resource-pool-0.5.0.0/src/Data/Pool.hs 2001-09-09 03:46:40.000000000
+0200
@@ -10,6 +10,7 @@
, PoolConfig
, defaultPoolConfig
, setNumStripes
+ , setPoolLabel
-- * Resource management
, withResource
@@ -24,8 +25,10 @@
, createPool
) where
-import Control.Concurrent
+import Control.Concurrent.STM
import Control.Exception
+import Control.Monad
+import Data.Text qualified as T
import Data.Time (NominalDiffTime)
import Data.Pool.Internal
@@ -50,7 +53,7 @@
withResource :: Pool a -> (a -> IO r) -> IO r
withResource pool act = mask $ \unmask -> do
(res, localPool) <- takeResource pool
- r <- unmask (act res) `onException` destroyResource pool
localPool res
+ r <- unmask (act res) `onException` destroyResource pool localPool res
putResource localPool res
pure r
@@ -63,52 +66,60 @@
takeResource :: Pool a -> IO (a, LocalPool a)
takeResource pool = mask_ $ do
lp <- getLocalPool (localPools pool)
- stripe <- takeMVar (stripeVar lp)
- if available stripe == 0
- then do
- q <- newEmptyMVar
- putMVar (stripeVar lp) $! stripe { queueR = Queue q (queueR stripe) }
- waitForResource (stripeVar lp) q >>= \case
- Just a -> pure (a, lp)
- Nothing -> do
- a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
- pure (a, lp)
- else takeAvailableResource pool lp stripe
+ join . atomically $ do
+ stripe <- readTVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ q <- newEmptyTMVar
+ writeTVar (stripeVar lp) $! stripe {queueR = Queue q (queueR stripe)}
+ pure
+ $ waitForResource (stripeVar lp) q >>= \case
+ Just a -> pure (a, lp)
+ Nothing -> do
+ a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
+ pure (a, lp)
+ else takeAvailableResource pool lp stripe
-- | A variant of 'withResource' that doesn't execute the action and returns
-- '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
- r <- unmask (act res) `onException` destroyResource pool localPool res
- putResource localPool res
- pure (Just r)
- Nothing -> pure Nothing
+tryWithResource pool act = mask $ \unmask ->
+ tryTakeResource pool >>= \case
+ Just (res, localPool) -> do
+ r <- unmask (act res) `onException` destroyResource pool localPool res
+ putResource localPool res
+ pure (Just r)
+ Nothing -> pure Nothing
-- | A variant of 'takeResource' that returns 'Nothing' instead of blocking if
-- the local pool is exhausted.
tryTakeResource :: Pool a -> IO (Maybe (a, LocalPool a))
tryTakeResource pool = mask_ $ do
lp <- getLocalPool (localPools pool)
- stripe <- takeMVar (stripeVar lp)
- if available stripe == 0
- then do
- putMVar (stripeVar lp) stripe
- pure Nothing
- else Just <$> takeAvailableResource pool lp stripe
+ join . atomically $ do
+ stripe <- readTVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ writeTVar (stripeVar lp) stripe
+ pure $ pure Nothing
+ else fmap Just <$> takeAvailableResource pool lp stripe
{-# DEPRECATED createPool "Use newPool instead" #-}
+
-- | Provided for compatibility with @resource-pool < 0.3@.
--
-- Use 'newPool' instead.
createPool :: IO a -> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO
(Pool a)
-createPool create free numStripes idleTime maxResources = newPool PoolConfig
- { createResource = create
- , freeResource = free
- , poolCacheTTL = realToFrac idleTime
- , poolMaxResources = numStripes * maxResources
- , poolNumStripes = Just numStripes
- }
+createPool create free numStripes idleTime maxResources =
+ newPool
+ PoolConfig
+ { createResource = create
+ , freeResource = free
+ , poolCacheTTL = realToFrac idleTime
+ , poolMaxResources = numStripes * maxResources
+ , poolNumStripes = Just numStripes
+ , pcLabel = T.empty
+ }
----------------------------------------
-- Helpers
@@ -117,15 +128,17 @@
:: Pool a
-> LocalPool a
-> Stripe a
- -> IO (a, LocalPool a)
+ -> STM (IO (a, LocalPool a))
takeAvailableResource pool lp stripe = case cache stripe of
[] -> do
- putMVar (stripeVar lp) $! stripe { available = available stripe - 1 }
- a <- createResource (poolConfig pool) `onException` restoreSize (stripeVar
lp)
- pure (a, lp)
+ writeTVar (stripeVar lp) $! stripe {available = available stripe - 1}
+ pure $ do
+ a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
+ pure (a, lp)
Entry a _ : as -> do
- putMVar (stripeVar lp) $! stripe
- { available = available stripe - 1
- , cache = as
- }
- pure (a, lp)
+ writeTVar (stripeVar lp)
+ $! stripe
+ { available = available stripe - 1
+ , cache = as
+ }
+ pure $ pure (a, lp)
