diff --git a/Control/Concurrent/STM/Stats.hs b/Control/Concurrent/STM/Stats.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/STM/Stats.hs @@ -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 +-- 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. + diff --git a/Demo.hs b/Demo.hs new file mode 100644 --- /dev/null +++ b/Demo.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/stm-stats.cabal b/stm-stats.cabal new file mode 100644 --- /dev/null +++ b/stm-stats.cabal @@ -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 , + Joachim Breitner +Maintainer: Joachim Breitner +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/