stm-stats (empty) → 0.1.0.0
raw patch · 5 files changed
+326/−0 lines, 5 filesdep +basedep +containersdep +stmsetup-changed
Dependencies added: base, containers, stm, template-haskell, time
Files
- Control/Concurrent/STM/Stats.hs +246/−0
- Demo.hs +17/−0
- LICENSE +31/−0
- Setup.hs +2/−0
- stm-stats.cabal +30/−0
+ Control/Concurrent/STM/Stats.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.STM.Stats+-- Copyright : (c) 2011 David Leuschner+-- (c) 2011 Joachim Breitner+-- License : BSD3+-- +-- Maintainer : Joachim Breitner <mail@joachim-breitner.de>+-- Portability : non-portable (requires STM)+--+-- This module provides variants to the function 'atomically' from+-- "Control.Concurrent.STM" which keep track of how often the transaction is+-- initiated and how often it was retried.+--+-----------------------------------------------------------------------------+++module Control.Concurrent.STM.Stats + (+ -- * Example usage+ --+ -- $intro++ -- * Generating statistics+ --+ trackSTM + , trackNamedSTM+ , trackThisSTM+ , trackSTMConf+ -- * Configuring TrackSTM+ , TrackSTMConf(..)+ , defaultTrackSTMConf+ -- * More helpful exceptions+ , BlockedIndefinitelyOnNamedSTM(..)+ -- * Reading the statistics+ , getSTMStats+ , dumpSTMStats+ ) where++import Prelude hiding (catch)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Functor+import Data.IORef+import Data.Time+import Data.Typeable ( Typeable )+import Control.Exception.Base+import Control.Monad+import Text.Printf+import System.IO+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent.STM+import Language.Haskell.TH (Q, Exp(AppE,VarE,LitE), Lit(StringL), Loc, location, loc_filename, loc_start, mkName)+import GHC.Conc (unsafeIOToSTM)++-- | Global state, seems to be unavoidable here.+globalRetryCountMap :: IORef (Map String (Int,Int))+globalRetryCountMap = unsafePerformIO (newIORef M.empty)+{-# NOINLINE globalRetryCountMap #-}++-- | For the most general transaction tracking function, 'trackSTMConf', all+-- settings can be configured using a 'TrackSTMConf' value.+data TrackSTMConf = TrackSTMConf + { tryThreshold :: Maybe Int+ -- ^ If the number of retries of one transaction run reaches this+ -- count, a warning is issued at runtime. If set to @Nothing@, disables the warnings completely.+ , globalTheshold :: Maybe Int+ -- ^ If the total number of retries of one named transaction reaches+ -- this count, a warning is issued. If set to @Nothing@, disables the+ -- warnings completely.+ , extendException :: Bool+ -- ^ If this is set, a 'BlockedIndefinitelyOnSTM' exception is replaced+ -- by a 'BlockedIndefinitelyOnNamedSTM' exception, carrying the name of+ -- the exception.+ , warnFunction :: String -> IO ()+ -- ^ Function to call when a warning is to be emitted.+ }++-- | The default settings are:+--+-- > defaultTrackSTMConf = TrackSTMConf+-- > { tryThreshold = Just 10+-- > , globalTheshold = Just 3000+-- > , exception = True+-- > , warnFunction = hPutStrLn stderr+-- > }+defaultTrackSTMConf :: TrackSTMConf+defaultTrackSTMConf = TrackSTMConf + { tryThreshold = Just 10+ , globalTheshold = Just 3000+ , extendException = True+ , warnFunction = hPutStrLn stderr+ }++-- | A drop-in replacement for 'atomically'. The statistics will list this, and+-- all other unnamed transactions, as \"@_anonymous_@\" and+-- 'BlockedIndefinitelyOnSTM' exceptions will not be replaced.+-- See below for variants that give more control over the statistics and+-- generated warnings.+trackSTM :: STM a -> IO a+trackSTM = trackSTMConf defaultTrackSTMConf { extendException = False } "_anonymous_"++-- | Run 'atomically' and collect the retry statistics under the given name and using the default configuration, 'defaultTrackSTMConf'.+trackNamedSTM :: String -> STM a -> IO a+trackNamedSTM = trackSTMConf defaultTrackSTMConf++-- | This, when used as @$trackThisSTM@ in a module with @-XTemplateHaskell@ enabled,+-- will call 'trackNamedSTM' with a name automatically derived from the source+-- file name and position, e.g. \"@Test.hs:6:21@\".+trackThisSTM :: Q Exp+trackThisSTM = do+ name <- formatLoc <$> location+ -- We don't use ''trackNamedSTM here, so that this module can be used on a+ -- compile that does not support TH.+ return $ AppE (VarE (mkName "Control.Concurrent.STM.Stats.trackNamedSTM"))+ (LitE (StringL name))+ where formatLoc :: Loc -> String+ formatLoc loc = let file = loc_filename loc+ (line, col) = loc_start loc+ in printf "%s:%d:%d" file line col++-- | Run 'atomically' and collect the retry statistics under the given name,+-- while issuing warnings when the configured thresholds are exceeded.+trackSTMConf :: TrackSTMConf -> String -> STM a -> IO a+trackSTMConf (TrackSTMConf {..}) name txm = do+ counter <- newIORef 0+ let wrappedTx =+ do unsafeIOToSTM $ do+ atomicModifyIORef counter incCounter+ -- This is disabled, because the documentation to+ -- unsafeIOToSTM says that using handles in unsafeIOToSTM+ -- can cause deadlocks:+ --+ -- when (warnPred i) $+ -- warnFunction $ msgPrefix ++ " reached try count of " ++ show i+ txm+ res <- if extendException+ then atomically wrappedTx+ `catch` (\(e::BlockedIndefinitelyOnSTM) ->+ throwIO (BlockedIndefinitelyOnNamedSTM name))+ else atomically wrappedTx+ i <- readIORef counter+ doMB tryThreshold $ \threshold ->+ when (i > threshold) $+ warnFunction $ msgPrefix ++ " finished after " ++ show (i-1) ++ " retries"+ incGlobalRetryCount (i - 1)+ return res+ where+ doMB Nothing _ = return ()+ doMB (Just x) m = m x+ incCounter i = let j = i + 1 in (j, j)+ warnPred j = case tryThreshold of+ Nothing -> False+ Just n -> j >= 2*n && (j >= 4 * n || j `mod` 2 * n == 0)+ msgPrefix = "STM transaction " ++ name+ incGlobalRetryCount i = do+ k <- atomicModifyIORef globalRetryCountMap $ \m -> + let (oldVal, m') = M.insertLookupWithKey'+ (\_ (a1,b1) (a2,b2) -> ((,) $! a1+a2) $! b1+b2)+ name+ (1,i)+ m+ in (m', case oldVal of+ Nothing -> i+ Just (_,j) -> j+i)+ doMB globalTheshold $ \globalRetryThreshold -> + when (k > 0 && k `mod` globalRetryThreshold == 0) $+ warnFunction $ msgPrefix ++ "reached global retry count of " ++ show k++-- | If 'extendException' is set (which is the case with 'trackNamedSTM'), an+-- occurrence of 'BlockedIndefinitelyOnSTM' is replaced by+-- 'BlockedIndefinitelyOnNamedSTM', carrying the name of the transaction and+-- thus giving more helpful error messages.+data BlockedIndefinitelyOnNamedSTM = BlockedIndefinitelyOnNamedSTM String+ deriving (Typeable)++instance Show BlockedIndefinitelyOnNamedSTM where+ showsPrec _ (BlockedIndefinitelyOnNamedSTM name) =+ showString $ "thread blocked indefinitely in STM transaction" ++ name++instance Exception BlockedIndefinitelyOnNamedSTM++++-- | Fetches the current transaction statistics data.+--+-- The map maps transaction names to counts of transaction commits and+-- transaction retries.+getSTMStats :: IO (Map String (Int, Int))+getSTMStats = readIORef globalRetryCountMap++-- | Dumps the current transaction statistics data to 'System.IO.stderr'.+dumpSTMStats :: IO ()+dumpSTMStats = do+ stats <- getSTMStats+ time <- show <$> getCurrentTime+ hPutStrLn stderr $ "STM transaction statistics (" ++ time ++ "):"+ hPrintf stderr "%-12s %10s %10s %10s\n" "Transaction" "Commits" "Retries" "Ratio"+ sequence_+ [ hPrintf stderr "%-12s %10d %10d %10.2f\n" name commits retries ratio+ | (name,(commits,retries)) <- M.toList stats+ , commits > 0 -- safeguard+ , let ratio = fromIntegral retries / fromIntegral commits :: Double+ ]++-- $intro+--+-- The following example code shows how to use the module:+--+-- @+--import Control.Concurrent+--import Control.Concurrent.STM+--import Control.Monad+-- +--import Control.Concurrent.STM.Stats+-- +--main = do+-- var <- 'trackSTM' $ newTVar 0+-- forkIO $ forM_ [1..23] $ \i -> do+-- threadDelay (100*1000)+-- 'trackNamedSTM' \"writer\" $ writeTVar var i+-- putStrLn \"Starting reader...\"+-- 'trackNamedSTM' \"reader\" $ do+-- i <- readTVar var+-- when (i < 23) retry+-- putStrLn \"Reader finished.\"+-- 'dumpSTMStats'+-- @+--+-- Running this program will result in this output:+-- +-- >Starting reader...+-- >STM transaction reader finished after 23 retries+-- >Reader finished.+-- >STM transaction statistics (2011-10-09 12:28:37.188951 UTC):+-- >Transaction Commits Retries Ratio+-- >_anonymous_ 1 0 0.00+-- >reader 1 23 23.00+-- >writer 23 0 0.00+--+-- The function 'trackSTM' is a direct replacement for 'atomically', while+-- 'trackNamedSTM' and 'trackSTMConf' provide more control and @$@'trackThisSTM'+-- uses Template Haskell to automatically generate a good name. +
+ Demo.hs view
@@ -0,0 +1,17 @@+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad++import Control.Concurrent.STM.Stats++main = do+ var <- trackSTM $ newTVar 0+ forkIO $ forM_ [1..23] $ \i -> do+ threadDelay (100*1000)+ trackNamedSTM "writer" $ writeTVar var i+ putStrLn "Starting reader..."+ trackNamedSTM "reader" $ do+ i <- readTVar var+ when (i < 23) retry+ putStrLn "Reader finished."+ dumpSTMStats
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2011 David Leuschner+Copyright (c) 2011 Joachim Breitner++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Joachim Breitner nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ stm-stats.cabal view
@@ -0,0 +1,30 @@+Name: stm-stats+Version: 0.1.0.0+Synopsis: retry statistics for STM transactions+Description: This module provides functions that can replace calls to+ 'atomically' and count how often the transaction was retried+ until it succeeded. It can emit warnings when transaction are+ retried more often than a given threshold, and provides global+ statistics across all transaction.+ .+ As an additional feature, if the transaction was named,+ transaction-related exceptions such as+ 'BlockedIndefinitelyOnSTM' are replaced by variants that+ indicate which transaction caused the exception.+License: BSD3+License-file: LICENSE+Author: David Leuschner <leuschner@factisresearch.com>,+ Joachim Breitner <mail@joachim-breitner.de>+Maintainer: Joachim Breitner <mail@joachim-breitner.de>+Category: Concurrency+Build-type: Simple+Cabal-version: >=1.6+Extra-source-files: Demo.hs++Library+ Build-depends: base >=4 && <5, time, containers, stm, template-haskell+ Exposed-Modules: Control.Concurrent.STM.Stats++Source-Repository head+ type: darcs+ location: http://darcs.umidev.de/pub/stm-stats/