From e6bd798c35a4bc1ebef25a735604557026052abb Mon Sep 17 00:00:00 2001 From: Wayne Lewis Date: Wed, 18 Mar 2015 01:45:07 -0700 Subject: [PATCH 1/5] add pool stats --- Data/Pool.hs | 54 ++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 50 insertions(+), 4 deletions(-) diff --git a/Data/Pool.hs b/Data/Pool.hs index 6764e8b..3968c5b 100644 --- a/Data/Pool.hs +++ b/Data/Pool.hs @@ -31,6 +31,8 @@ module Data.Pool ( Pool(idleTime, maxResources, numStripes) , LocalPool + , Stats(..) + , PoolStats(..) , createPool , withResource , takeResource @@ -39,13 +41,14 @@ module Data.Pool , destroyResource , putResource , destroyAllResources + , stats ) where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread, myThreadId, threadDelay) import Control.Concurrent.STM import Control.Exception (SomeException, onException, mask_) -import Control.Monad (forM_, forever, join, liftM3, unless, when) +import Control.Monad (forM_, forever, join, liftM5, unless, when) import Data.Hashable (hash) import Data.IORef (IORef, newIORef, mkWeakIORef) import Data.List (partition) @@ -80,12 +83,36 @@ data Entry a = Entry { -- ^ Time of last return. } + +-- | Stats for a single 'LocalPool'. +data PoolStats = PoolStats { + highwaterUsage :: Int + , currentUsage :: Int + , takes :: Int + , creates :: Int + , createFailures :: Int +} deriving (Show) + +-- | Pool-wide stats. +data Stats = Stats { + perStripe :: V.Vector PoolStats + , poolStats :: PoolStats +} deriving (Show) + -- | A single striped pool. data LocalPool a = LocalPool { inUse :: TVar Int -- ^ Count of open entries (both idle and in use). , entries :: TVar [Entry a] -- ^ Idle entries. + , highwaterVar :: TVar Int + -- ^ Highest value of 'inUse' since last reset. + , takeVar :: TVar Int + -- ^ Number of takes since last reset. + , createVar :: TVar Int + -- ^ Number of creates since last reset. + , createFailureVar :: TVar Int + -- ^ Number of create failures since last reset. , lfin :: IORef () -- ^ empty value used to attach a finalizer to (internal) } deriving (Typeable) @@ -159,7 +186,7 @@ createPool create destroy numStripes idleTime maxResources = do when (maxResources < 1) $ modError "pool " $ "invalid maximum resource count " ++ show maxResources localPools <- V.replicateM numStripes $ - liftM3 LocalPool (newTVarIO 0) (newTVarIO []) (newIORef ()) + LocalPool <$> newTVarIO 0 <*> newTVarIO [] <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 <*> newIORef () reaperId <- forkIOLabeledWithUnmask "resource-pool: reaper" $ \unmask -> unmask $ reaper destroy idleTime localPools fin <- newIORef () @@ -276,6 +303,7 @@ takeResource :: Pool a -> IO (a, LocalPool a) takeResource pool@Pool{..} = do local@LocalPool{..} <- getLocalPool pool resource <- liftBase . join . atomically $ do + modifyTVar_ takeVar (+ 1) ents <- readTVar entries case ents of (Entry{..}:es) -> writeTVar entries es >> return (return entry) @@ -283,8 +311,10 @@ takeResource pool@Pool{..} = do used <- readTVar inUse when (used == maxResources) retry writeTVar inUse $! used + 1 + modifyTVar_ highwaterVar (`max` (used + 1)) + modifyTVar_ createVar (+ 1) return $ - create `onException` atomically (modifyTVar_ inUse (subtract 1)) + create `onException` atomically (modifyTVar_ createFailureVar (+ 1) >> modifyTVar_ inUse (subtract 1)) return (resource, local) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE takeResource #-} @@ -385,6 +415,22 @@ putResource LocalPool{..} resource = do destroyAllResources :: Pool a -> IO () destroyAllResources Pool{..} = V.forM_ localPools $ purgeLocalPool destroy +-- | @stats pool reset@ returns statistics on each 'LocalPool' as well as a summary across the entire Pool. +-- When @reset@ is true, the stats are reset. +stats :: Pool a -> Bool -> IO Stats +stats Pool{..} reset = do + let stripeStats LocalPool{..} = atomically $ do + s <- liftM5 PoolStats (readTVar highwaterVar) (readTVar inUse) (readTVar takeVar) (readTVar createVar) (readTVar createFailureVar) + when reset $ do + mapM_ (\v -> writeTVar v 0) [takeVar, createVar, createFailureVar] + writeTVar highwaterVar $! currentUsage s + return s + + per <- V.mapM stripeStats localPools + let poolWide = V.foldr merge (PoolStats 0 0 0 0 0) per + merge (PoolStats hw1 cu1 t1 c1 f1) (PoolStats hw2 cu2 t2 c2 f2) = PoolStats (hw1 + hw2) (cu1 + cu2) (t1 + t2) (c1 + c2) (f1 + f2) + return $ Stats per poolWide + modifyTVar_ :: TVar a -> (a -> a) -> STM () modifyTVar_ v f = readTVar v >>= \a -> writeTVar v $! f a From 396a44e83ffe5738c181ff34630a803f0d2b5d45 Mon Sep 17 00:00:00 2001 From: Wayne Lewis Date: Wed, 18 Mar 2015 01:56:29 -0700 Subject: [PATCH 2/5] add docs for each field of Stats and PoolStats --- Data/Pool.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Data/Pool.hs b/Data/Pool.hs index 3968c5b..5cb3360 100644 --- a/Data/Pool.hs +++ b/Data/Pool.hs @@ -87,16 +87,23 @@ data Entry a = Entry { -- | Stats for a single 'LocalPool'. data PoolStats = PoolStats { highwaterUsage :: Int + -- ^ Highest usage since last reset. , currentUsage :: Int + -- ^ Current number of items. , takes :: Int + -- ^ Number of takes since last reset. , creates :: Int + -- ^ Number of cretes since last reset. , createFailures :: Int + -- ^ Number of creation failures since last reset. } deriving (Show) -- | Pool-wide stats. data Stats = Stats { perStripe :: V.Vector PoolStats + -- ^ Stats per 'LocalPool' (stripe). , poolStats :: PoolStats + -- ^ Aggregate stats across pool. } deriving (Show) -- | A single striped pool. From ecdfffe5dbaa51fb943c8734cebfc43fbe76583a Mon Sep 17 00:00:00 2001 From: Wayne Lewis Date: Wed, 18 Mar 2015 01:57:37 -0700 Subject: [PATCH 3/5] fix typo --- Data/Pool.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Data/Pool.hs b/Data/Pool.hs index 5cb3360..7b44d5a 100644 --- a/Data/Pool.hs +++ b/Data/Pool.hs @@ -93,7 +93,7 @@ data PoolStats = PoolStats { , takes :: Int -- ^ Number of takes since last reset. , creates :: Int - -- ^ Number of cretes since last reset. + -- ^ Number of creates since last reset. , createFailures :: Int -- ^ Number of creation failures since last reset. } deriving (Show) From 7f3b5becefe210c23ff3aacb2394d3419bef7a82 Mon Sep 17 00:00:00 2001 From: cydparser Date: Thu, 23 Sep 2021 23:24:06 -0700 Subject: [PATCH 4/5] Use `hashWithSalt` --- Data/Pool.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Data/Pool.hs b/Data/Pool.hs index 7b44d5a..7ae7ab4 100644 --- a/Data/Pool.hs +++ b/Data/Pool.hs @@ -49,7 +49,7 @@ import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread, myThreadId, t import Control.Concurrent.STM import Control.Exception (SomeException, onException, mask_) import Control.Monad (forM_, forever, join, liftM5, unless, when) -import Data.Hashable (hash) +import Data.Hashable (hashWithSalt) import Data.IORef (IORef, newIORef, mkWeakIORef) import Data.List (partition) import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) @@ -380,7 +380,7 @@ tryTakeResource pool@Pool{..} = do -- Internal, just to not repeat code for 'takeResource' and 'tryTakeResource' getLocalPool :: Pool a -> IO (LocalPool a) getLocalPool Pool{..} = do - i <- liftBase $ ((`mod` numStripes) . hash) <$> myThreadId + i <- liftBase $ ((`mod` numStripes) . hashWithSalt (-3750763034362895579)) <$> myThreadId return $ localPools V.! i #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE getLocalPool #-} From 501885f627e6ca5a382ab02d4457dbce628c7cd8 Mon Sep 17 00:00:00 2001 From: Wayne Lewis Date: Mon, 3 Nov 2025 00:51:27 -0800 Subject: [PATCH 5/5] add idle and non-idle stats --- .gitignore | 1 + Data/Pool.hs | 20 +++++++++++++------- 2 files changed, 14 insertions(+), 7 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..48a004c --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle diff --git a/Data/Pool.hs b/Data/Pool.hs index 7b44d5a..1fa80b4 100644 --- a/Data/Pool.hs +++ b/Data/Pool.hs @@ -44,11 +44,10 @@ module Data.Pool , stats ) where -import Control.Applicative ((<$>), (<*>)) import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread, myThreadId, threadDelay) import Control.Concurrent.STM import Control.Exception (SomeException, onException, mask_) -import Control.Monad (forM_, forever, join, liftM5, unless, when) +import Control.Monad (forM_, forever, join, unless, when) import Data.Hashable (hash) import Data.IORef (IORef, newIORef, mkWeakIORef) import Data.List (partition) @@ -87,9 +86,13 @@ data Entry a = Entry { -- | Stats for a single 'LocalPool'. data PoolStats = PoolStats { highwaterUsage :: Int - -- ^ Highest usage since last reset. + -- ^ Highest value of 'currentUsage' since last reset. , currentUsage :: Int - -- ^ Current number of items. + -- ^ Current number of items (both idle and in use). + , currentIdle :: Int + -- ^ Current number of items idle. + , currentNonIdle :: Int + -- ^ Current number of items that are not idle. , takes :: Int -- ^ Number of takes since last reset. , creates :: Int @@ -427,15 +430,18 @@ destroyAllResources Pool{..} = V.forM_ localPools $ purgeLocalPool destroy stats :: Pool a -> Bool -> IO Stats stats Pool{..} reset = do let stripeStats LocalPool{..} = atomically $ do - s <- liftM5 PoolStats (readTVar highwaterVar) (readTVar inUse) (readTVar takeVar) (readTVar createVar) (readTVar createFailureVar) + is <- readTVar inUse + idle <- length <$> readTVar entries + let nonIdle = is - idle + s <- PoolStats <$> readTVar highwaterVar <*> pure is <*> pure idle <*> pure nonIdle <*> readTVar takeVar <*> readTVar createVar <*> readTVar createFailureVar when reset $ do mapM_ (\v -> writeTVar v 0) [takeVar, createVar, createFailureVar] writeTVar highwaterVar $! currentUsage s return s per <- V.mapM stripeStats localPools - let poolWide = V.foldr merge (PoolStats 0 0 0 0 0) per - merge (PoolStats hw1 cu1 t1 c1 f1) (PoolStats hw2 cu2 t2 c2 f2) = PoolStats (hw1 + hw2) (cu1 + cu2) (t1 + t2) (c1 + c2) (f1 + f2) + let poolWide = V.foldr merge (PoolStats 0 0 0 0 0 0 0) per + merge (PoolStats hw1 cu1 i1 ni1 t1 c1 f1) (PoolStats hw2 cu2 i2 ni2 t2 c2 f2) = PoolStats (hw1 + hw2) (cu1 + cu2) (i1 + i2) (ni1 + ni2) (t1 + t2) (c1 + c2) (f1 + f2) return $ Stats per poolWide modifyTVar_ :: TVar a -> (a -> a) -> STM ()