diff --git a/CHANGELOG.md b/CHANGELOG.md index e2d1817..d89638d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ * 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. diff --git a/resource-pool.cabal b/resource-pool.cabal index 32b8fb7..58e8e23 100644 --- a/resource-pool.cabal +++ b/resource-pool.cabal @@ -36,6 +36,7 @@ library , hashable >= 1.1.0.0 , primitive >= 0.7 , stm + , text , time ghc-options: -Wall diff --git a/src/Data/Pool.hs b/src/Data/Pool.hs index 3594b4b..4d99dd9 100644 --- a/src/Data/Pool.hs +++ b/src/Data/Pool.hs @@ -10,6 +10,7 @@ module Data.Pool , PoolConfig , defaultPoolConfig , setNumStripes + , setPoolLabel -- * Resource management , withResource @@ -27,6 +28,7 @@ module Data.Pool import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.Text qualified as T import Data.Time (NominalDiffTime) import Data.Pool.Internal @@ -116,6 +118,7 @@ createPool create free numStripes idleTime maxResources = , poolCacheTTL = realToFrac idleTime , poolMaxResources = numStripes * maxResources , poolNumStripes = Just numStripes + , pcLabel = T.empty } ---------------------------------------- diff --git a/src/Data/Pool/Internal.hs b/src/Data/Pool/Internal.hs index 3aad38d..a4087cb 100644 --- a/src/Data/Pool/Internal.hs +++ b/src/Data/Pool/Internal.hs @@ -15,8 +15,9 @@ import Data.Hashable (hash) import Data.IORef import Data.List qualified as L import Data.Primitive.SmallArray +import Data.Text qualified as T import GHC.Clock (getMonotonicTime) -import GHC.Conc (unsafeIOToSTM) +import GHC.Conc (labelThread, unsafeIOToSTM) -- | Striped resource pool based on "Control.Concurrent.QSem". data Pool a = Pool @@ -60,6 +61,7 @@ data PoolConfig a = PoolConfig , poolCacheTTL :: !Double , poolMaxResources :: !Int , poolNumStripes :: !(Maybe Int) + , pcLabel :: !T.Text } -- | Create a 'PoolConfig' with optional parameters having default values. @@ -94,6 +96,7 @@ defaultPoolConfig create free cacheTTL maxResources = , poolCacheTTL = cacheTTL , poolMaxResources = maxResources , poolNumStripes = Just 1 + , pcLabel = T.empty } -- | Set the number of stripes (sub-pools) in the pool. @@ -111,6 +114,15 @@ defaultPoolConfig create free cacheTTL maxResources = setNumStripes :: Maybe Int -> PoolConfig a -> PoolConfig a 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. -- -- /Note:/ although the runtime system will destroy all idle resources when the @@ -149,7 +161,10 @@ newPool pc = do } mask_ $ do ref <- newIORef () - collectorA <- forkIOWithUnmask $ \unmask -> unmask $ collector pools + 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. diff --git a/src/Data/Pool/Introspection.hs b/src/Data/Pool/Introspection.hs index 53e8fbe..18fa829 100644 --- a/src/Data/Pool/Introspection.hs +++ b/src/Data/Pool/Introspection.hs @@ -9,6 +9,7 @@ module Data.Pool.Introspection , PoolConfig , defaultPoolConfig , setNumStripes + , setPoolLabel -- * Resource management , Resource (..) @@ -25,6 +26,7 @@ module Data.Pool.Introspection import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.Text qualified as T import GHC.Clock (getMonotonicTime) import GHC.Generics (Generic) @@ -33,6 +35,7 @@ import Data.Pool.Internal -- | A resource taken from the pool along with additional information. data Resource a = Resource { resource :: a + , poolLabel :: !T.Text , stripeNumber :: !Int , availableResources :: !Int , acquisition :: !Acquisition @@ -75,6 +78,7 @@ takeResource pool = mask_ $ do let res = Resource { resource = a + , poolLabel = pcLabel $ poolConfig pool , stripeNumber = stripeId lp , availableResources = 0 , acquisition = Delayed @@ -89,6 +93,7 @@ takeResource pool = mask_ $ do let res = Resource { resource = a + , poolLabel = pcLabel $ poolConfig pool , stripeNumber = stripeId lp , availableResources = 0 , acquisition = Delayed @@ -143,6 +148,7 @@ takeAvailableResource pool t1 lp stripe = case cache stripe of let res = Resource { resource = a + , poolLabel = pcLabel $ poolConfig pool , stripeNumber = stripeId lp , availableResources = newAvailable , acquisition = Immediate @@ -158,6 +164,7 @@ takeAvailableResource pool t1 lp stripe = case cache stripe of let res = Resource { resource = a + , poolLabel = pcLabel $ poolConfig pool , stripeNumber = stripeId lp , availableResources = newAvailable , acquisition = Immediate