1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
----------------------------------------------------------------------------
-- |
-- Module : BenchMain
-- Copyright : (c) Sergey Vinokurov 2022
-- License : Apache-2.0 (see LICENSE)
-- Maintainer : serg.foo@gmail.com
----------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE UnboxedTuples #-}
module BenchMain (main) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import Data.IORef
import Data.Primitive.Types
import Data.Semigroup
import GHC.Exts
import GHC.IO
import Test.QuickCheck
import Test.Tasty hiding (defaultMain)
import Test.Tasty.Bench
import Test.Tasty.Patterns.Printer
import qualified Test.Tasty.QuickCheck as QC
import qualified Control.Concurrent.Counter.Lifted.IO as C
import TestUtils
#if MIN_VERSION_base(4, 16, 0)
readAddr :: Addr# -> Word
readAddr addr = W# (indexWordOffAddr# addr 0#)
withAddr :: (Addr# -> IO a) -> IO a
withAddr f = IO $ \s1 -> case newPinnedByteArray# (sizeOf# (undefined :: Word)) s1 of
(# s2, mbarr #) ->
let !addr = mutableByteArrayContents# mbarr in
case writeWordOffAddr# addr 0# 0## s2 of
s3 -> case unIO (f addr) s3 of
(# s4, res #) -> case touch# mbarr s4 of
s5 -> (# s5, res #)
incrementAddr :: Addr# -> Int -> IO ()
incrementAddr addr (I# delta) = IO $ \s1 -> case fetchAddWordAddr# addr (int2Word# delta) s1 of
(# s2, _ #) -> (# s2, () #)
#endif
incrementIORef :: IORef Int -> Int -> IO ()
incrementIORef !x !delta = atomicModifyIORef' x (\old -> (old + delta, ()))
incrementIORefInconsistent :: IORef Int -> Int -> IO ()
incrementIORefInconsistent !x !delta = do
n <- readIORef x
writeIORef x $! n + delta
incrementMVar :: MVar Int -> Int -> IO ()
incrementMVar !x !delta = do
!n <- takeMVar x
putMVar x $! n + delta
incrementTMVar :: TMVar Int -> Int -> IO ()
incrementTMVar !x !delta = atomically $ do
!n <- takeTMVar x
putTMVar x $! n + delta
incrementTVar :: TVar Int -> Int -> IO ()
incrementTVar !x !delta = atomically $ modifyTVar' x (+ delta)
incrementCounter :: C.Counter -> Int -> IO ()
incrementCounter !x !delta = void (C.add x delta)
main :: IO ()
main = do
let tests =
[ localOption (QC.QuickCheckTests 10000) $
QC.testProperty "Correctness" $
\(Threads ts) -> ioProperty $ do
a <- spawnAndCall ts (newIORef 0) (\ref t -> runThread t (\_ -> pure ()) (incrementIORef ref)) >>= readIORef
b <- spawnAndCall ts (newMVar 0) (\ref t -> runThread t (\_ -> pure ()) (incrementMVar ref)) >>= takeMVar
c <- spawnAndCall ts (newTMVarIO 0) (\ref t -> runThread t (\_ -> pure ()) (incrementTMVar ref)) >>= atomically . takeTMVar
d <- spawnAndCall ts (newTVarIO 0) (\ref t -> runThread t (\_ -> pure ()) (incrementTVar ref)) >>= atomically . readTVar
-- e <- spawnAndCall ts (newIORef 0) (\ref t -> runThread t (incrementIORefInconsistent ref *> sleep delay)) >>= readIORef
#if MIN_VERSION_base(4, 16, 0)
f <- withAddr $ \addr -> do
spawnAndCall ts (pure ()) (\() t -> runThread t (\_ -> pure ()) (incrementAddr addr))
evaluate (readAddr addr)
#endif
g <- spawnAndCall ts (C.new 0) (\ref t -> runThread t (\_ -> pure ()) (incrementCounter ref)) >>= C.get
let Sum expected =
foldMap (\Thread{tIncrement, tIterations} -> Sum $ tIncrement * unIterations tIterations) ts
pure $
a === expected .&&.
b === expected .&&.
c === expected .&&.
d === expected .&&.
#if MIN_VERSION_base(4, 16, 0)
fromIntegral f === expected .&&.
#endif
g === expected
]
let benchmarks = map (mapLeafBenchmarks addCompare)
[ bgroup ("Read/write contention with " ++ show (unIterations n) ++ " iterations and " ++ show (length threads) ++ " threads")
[ bench counterBenchName $
whnfIO (spawnAndCall threads (C.new 0) (\ref _ -> callN n (incrementCounter ref 1)))
, bench "IORef inconsistent" $
whnfIO (spawnAndCall threads (newIORef 0) (\ref _ -> callN n (incrementIORefInconsistent ref 1)))
, bench "IORef atomic" $
whnfIO (spawnAndCall threads (newIORef 0) (\ref _ -> callN n (incrementIORef ref 1)))
, bench "MVar" $
whnfIO (spawnAndCall threads (newMVar 0) (\ref _ -> callN n (incrementMVar ref 1)))
, bench "TMVar" $
whnfIO (spawnAndCall threads (newTMVarIO 0) (\ref _ -> callN n (incrementTMVar ref 1)))
, bench "TVar" $
whnfIO (spawnAndCall threads (newTVarIO 0) (\ref _ -> callN n (incrementTVar ref 1)))
#if MIN_VERSION_base(4, 16, 0)
, bench "Addr" $
whnfIO $ withAddr $ \addr -> do
spawnAndCall
threads
(pure ())
(\() _ -> callN n (incrementAddr addr 1))
evaluate (readAddr addr)
#endif
]
| maxThreads <- [1, 2, 4, 6, 8, 12, 16, 20, 32, 64, 128]
, let threads = [1..maxThreads]
, n <- [Iterations 10, Iterations 100, Iterations 1000, Iterations 10000]
]
defaultMain $ tests ++ benchmarks
counterBenchName :: String
counterBenchName = "Counter"
addCompare :: [String] -> Benchmark -> Benchmark
addCompare (name : path)
| name /= counterBenchName
= bcompare (printAwkExpr (locateBenchmark (counterBenchName : path)))
addCompare _ = id
|
