Skip to content

Commit e84ddbc

Browse files
pepeiborrapepeiborra
committed
STM stats
1 parent 18633c7 commit e84ddbc

File tree

3 files changed

+195
-0
lines changed

3 files changed

+195
-0
lines changed

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Development.IDE.Main
1111
import Control.Concurrent.Extra (newLock, readVar,
1212
withLock,
1313
withNumCapabilities)
14+
import Control.Concurrent.STM.Stats (dumpSTMStats)
1415
import Control.Exception.Safe (Exception (displayException),
1516
catchAny)
1617
import Control.Monad.Extra (concatMapM, unless,
@@ -308,6 +309,7 @@ defaultMain Arguments{..} = do
308309
vfs
309310
hiedb
310311
hieChan
312+
dumpSTMStats
311313
Check argFiles -> do
312314
dir <- IO.getCurrentDirectory
313315
dbLoc <- getHieDbLoc dir

‎hls-graph/hls-graph.cabal

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,12 +31,18 @@ flag embed-files
3131
manual: True
3232
description: Embed data files into the shake library
3333

34+
flag stm-stats
35+
default: False
36+
manual: True
37+
description: Collect STM transaction stats
38+
3439
source-repository head
3540
type: git
3641
location: https://github.com/haskell/haskell-language-server
3742

3843
library
3944
exposed-modules:
45+
Control.Concurrent.STM.Stats
4046
Development.IDE.Graph
4147
Development.IDE.Graph.Classes
4248
Development.IDE.Graph.Database
@@ -82,6 +88,9 @@ library
8288
build-depends:
8389
file-embed >= 0.0.11,
8490
template-haskell
91+
if flag(stm-stats)
92+
cpp-options: -DSTM_STATS
93+
8594

8695
ghc-options:
8796
-Wall -Wredundant-constraints -Wno-name-shadowing

‎hls-graph/src/Control/Concurrent/STM/Stats.hs

Lines changed: 184 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,184 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
module Control.Concurrent.STM.Stats
5+
( atomicallyNamed
6+
, atomically
7+
, getSTMStats
8+
, dumpSTMStats
9+
, module Control.Concurrent.STM
10+
) where
11+
12+
import Control.Concurrent.STM hiding (atomically)
13+
import qualified Control.Concurrent.STM as STM
14+
import Data.Map (Map)
15+
#ifdef STM_STATS
16+
import Control.Exception (BlockedIndefinitelyOnSTM, Exception,
17+
catch, throwIO)
18+
import Control.Monad
19+
import Data.IORef
20+
import qualified Data.Map.Strict as M
21+
import Data.Time (getCurrentTime)
22+
import Data.Typeable (Typeable)
23+
import GHC.Conc (unsafeIOToSTM)
24+
import System.IO
25+
import System.IO.Unsafe
26+
import Text.Printf
27+
#endif
28+
29+
atomicallyNamed :: String -> STM a -> IO a
30+
atomically :: STM a -> IO a
31+
dumpSTMStats :: IO ()
32+
getSTMStats :: IO (Map String (Int,Int))
33+
34+
#ifndef STM_STATS
35+
36+
getSTMStats = pure mempty
37+
atomicallyNamed _ = atomically
38+
dumpSTMStats = pure ()
39+
atomically = STM.atomically
40+
41+
#else
42+
-- adapted from the STM.Stats package
43+
44+
atomicallyNamed = trackNamedSTM
45+
atomically = trackSTM
46+
47+
-- | Global state, seems to be unavoidable here.
48+
globalRetryCountMap :: IORef (Map String (Int,Int))
49+
globalRetryCountMap = unsafePerformIO (newIORef M.empty)
50+
{-# NOINLINE globalRetryCountMap #-}
51+
52+
53+
-- | For the most general transaction tracking function, 'trackSTMConf', all
54+
-- settings can be configured using a 'TrackSTMConf' value.
55+
data TrackSTMConf = TrackSTMConf
56+
{ tryThreshold :: Maybe Int
57+
-- ^ If the number of retries of one transaction run reaches this
58+
-- count, a warning is issued at runtime. If set to @Nothing@, disables the warnings completely.
59+
, globalTheshold :: Maybe Int
60+
-- ^ If the total number of retries of one named transaction reaches
61+
-- this count, a warning is issued. If set to @Nothing@, disables the
62+
-- warnings completely.
63+
, extendException :: Bool
64+
-- ^ If this is set, a 'BlockedIndefinitelyOnSTM' exception is replaced
65+
-- by a 'BlockedIndefinitelyOnNamedSTM' exception, carrying the name of
66+
-- the exception.
67+
, warnFunction :: String -> IO ()
68+
-- ^ Function to call when a warning is to be emitted.
69+
, warnInSTMFunction :: String -> IO ()
70+
-- ^ Function to call when a warning is to be emitted during an STM
71+
-- transaction. This is possibly dangerous, see the documentation to
72+
-- 'unsafeIOToSTM', but can be useful to detect transactions that keep
73+
-- retrying forever.
74+
}
75+
76+
-- | The default settings are:
77+
--
78+
-- > defaultTrackSTMConf = TrackSTMConf
79+
-- > { tryThreshold = Just 10
80+
-- > , globalTheshold = Just 3000
81+
-- > , exception = True
82+
-- > , warnFunction = hPutStrLn stderr
83+
-- > , warnInSTMFunction = \_ -> return ()
84+
-- > }
85+
defaultTrackSTMConf :: TrackSTMConf
86+
defaultTrackSTMConf = TrackSTMConf
87+
{ tryThreshold = Just 10
88+
, globalTheshold = Just 3000
89+
, extendException = True
90+
, warnFunction = hPutStrLn stderr
91+
, warnInSTMFunction = \_ -> return ()
92+
}
93+
94+
-- | A drop-in replacement for 'atomically'. The statistics will list this, and
95+
-- all other unnamed transactions, as \"@_anonymous_@\" and
96+
-- 'BlockedIndefinitelyOnSTM' exceptions will not be replaced.
97+
-- See below for variants that give more control over the statistics and
98+
-- generated warnings.
99+
trackSTM :: STM a -> IO a
100+
trackSTM = trackSTMConf defaultTrackSTMConf { extendException = False } "_anonymous_"
101+
102+
-- | Run 'atomically' and collect the retry statistics under the given name and using the default configuration, 'defaultTrackSTMConf'.
103+
trackNamedSTM :: String -> STM a -> IO a
104+
trackNamedSTM = trackSTMConf defaultTrackSTMConf
105+
106+
-- | Run 'atomically' and collect the retry statistics under the given name,
107+
-- while issuing warnings when the configured thresholds are exceeded.
108+
trackSTMConf :: TrackSTMConf -> String -> STM a -> IO a
109+
trackSTMConf (TrackSTMConf {..}) name txm = do
110+
counter <- newIORef 0
111+
let wrappedTx =
112+
do unsafeIOToSTM $ do
113+
i <- atomicModifyIORef' counter incCounter
114+
when (warnPred i) $
115+
warnInSTMFunction $ msgPrefix ++ " reached try count of " ++ show i
116+
txm
117+
res <- if extendException
118+
then STM.atomically wrappedTx
119+
`catch` (\(_::BlockedIndefinitelyOnSTM) ->
120+
throwIO (BlockedIndefinitelyOnNamedSTM name))
121+
else STM.atomically wrappedTx
122+
i <- readIORef counter
123+
doMB tryThreshold $ \threshold ->
124+
when (i > threshold) $
125+
warnFunction $ msgPrefix ++ " finished after " ++ show (i-1) ++ " retries"
126+
incGlobalRetryCount (i - 1)
127+
return res
128+
where
129+
doMB Nothing _ = return ()
130+
doMB (Just x) m = m x
131+
incCounter i = let j = i + 1 in (j, j)
132+
warnPred j = case tryThreshold of
133+
Nothing -> False
134+
Just n -> j >= 2*n && (j >= 4 * n || j `mod` (2 * n) == 0)
135+
msgPrefix = "STM transaction " ++ name
136+
incGlobalRetryCount i = do
137+
(k,k') <- atomicModifyIORef' globalRetryCountMap $ \m ->
138+
let (oldVal, m') = M.insertLookupWithKey
139+
(\_ (a1,b1) (a2,b2) -> ((,) $! a1+a2) $! b1+b2)
140+
name
141+
(1,i)
142+
m
143+
in (m', let j = maybe 0 snd oldVal in (j,j+i))
144+
doMB globalTheshold $ \globalRetryThreshold ->
145+
when (k `div` globalRetryThreshold /= k' `div` globalRetryThreshold) $
146+
warnFunction $ msgPrefix ++ " reached global retry count of " ++ show k'
147+
148+
-- | If 'extendException' is set (which is the case with 'trackNamedSTM'), an
149+
-- occurrence of 'BlockedIndefinitelyOnSTM' is replaced by
150+
-- 'BlockedIndefinitelyOnNamedSTM', carrying the name of the transaction and
151+
-- thus giving more helpful error messages.
152+
newtype BlockedIndefinitelyOnNamedSTM = BlockedIndefinitelyOnNamedSTM String
153+
deriving (Typeable)
154+
155+
instance Show BlockedIndefinitelyOnNamedSTM where
156+
showsPrec _ (BlockedIndefinitelyOnNamedSTM name) =
157+
showString $ "thread blocked indefinitely in STM transaction" ++ name
158+
159+
instance Exception BlockedIndefinitelyOnNamedSTM
160+
161+
162+
163+
-- | Fetches the current transaction statistics data.
164+
--
165+
-- The map maps transaction names to counts of transaction commits and
166+
-- transaction retries.
167+
getSTMStats = readIORef globalRetryCountMap
168+
169+
-- | Dumps the current transaction statistics data to 'System.IO.stderr'.
170+
dumpSTMStats = do
171+
stats <- getSTMStats
172+
time <- show <$> getCurrentTime
173+
hPutStrLn stderr $ "STM transaction statistics (" ++ time ++ "):"
174+
sequence_ $
175+
hPrintf stderr "%-22s %10s %10s %10s\n" "Transaction" "Commits" "Retries" "Ratio" :
176+
[ hPrintf stderr "%-22s %10d %10d %10.2f\n" name commits retries ratio
177+
| (name,(commits,retries)) <- M.toList stats
178+
, commits > 0 -- safeguard
179+
, let ratio = fromIntegral retries / fromIntegral commits :: Double
180+
]
181+
182+
183+
#endif
184+

0 commit comments

Comments
 (0)