Skip to content

Commit 2e8e4e2

Browse files
cootcoot
committed
io-sim: benchmarks
1 parent 43f6075 commit 2e8e4e2

File tree

2 files changed

+170
-1
lines changed

2 files changed

+170
-1
lines changed

‎io-sim/bench/Main.hs

Lines changed: 147 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,147 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
4+
module Main (main) where
5+
6+
import Control.Monad (replicateM)
7+
import Control.Monad.Class.MonadAsync
8+
import Control.Monad.Class.MonadFork
9+
import Control.Monad.Class.MonadSay
10+
import Control.Monad.Class.MonadSTM
11+
import Control.Monad.Class.MonadThrow
12+
import Control.Monad.Class.MonadTimer
13+
import Control.Monad.IOSim
14+
import Control.Tracer (Tracer (..), nullTracer)
15+
16+
import Criterion
17+
import Criterion.Main
18+
19+
import Control.Exception (AsyncException (..))
20+
import Data.Foldable (traverse_)
21+
22+
import Network.TypedProtocol.Channel
23+
import Network.TypedProtocol.Driver.Simple
24+
25+
import Network.TypedProtocol.PingPong.Client
26+
import Network.TypedProtocol.PingPong.Codec
27+
-- import qualified Network.TypedProtocol.PingPong.Codec.CBOR as CBOR
28+
import Network.TypedProtocol.PingPong.Examples
29+
import Network.TypedProtocol.PingPong.Server
30+
import Network.TypedProtocol.PingPong.Type
31+
32+
33+
prop_channel :: forall m. (MonadSTM m, MonadAsync m, MonadCatch m, MonadTimer m)
34+
=> Maybe (DiffTime, DiffTime)
35+
-> Int
36+
-> Tracer m (Role, TraceSendRecv PingPong)
37+
-> m Bool
38+
prop_channel delay n tr = do
39+
((), n') <- runConnectedPeers createChannel
40+
tr
41+
codecPingPongId client server
42+
return (n' == n)
43+
where
44+
createChannel :: forall a. m (Channel m a, Channel m a)
45+
createChannel =
46+
case delay of
47+
Nothing -> createConnectedChannels
48+
Just (d1, d2) -> (\(a, b) -> (delayChannel d1 a, delayChannel d2 b))
49+
<$> createConnectedChannels
50+
51+
client = pingPongClientPeer (pingPongClientCount n)
52+
server = pingPongServerPeer pingPongServerCount
53+
54+
--
55+
-- timers, delays, timeouts
56+
--
57+
58+
prop_threadDelay :: forall m. MonadDelay m => m ()
59+
prop_threadDelay = threadDelay 1
60+
61+
prop_registerDelay :: forall m. MonadTimer m => m ()
62+
prop_registerDelay = registerDelay 1 >>= \v -> atomically (readTVar v >>= check)
63+
64+
prop_timeout_fail :: forall m. MonadTimer m => m (Maybe ())
65+
prop_timeout_fail = timeout 1 (threadDelay 2)
66+
67+
prop_timeout_succeed :: forall m. MonadTimer m => m (Maybe ())
68+
prop_timeout_succeed = timeout 2 (threadDelay 1)
69+
70+
71+
--
72+
-- threads, async
73+
--
74+
75+
prop_threads :: forall m. (MonadFork m, MonadDelay m, MonadSay m) => Int -> m ()
76+
prop_threads n = do
77+
threads <- replicateM n (forkIO $ threadDelay 2
78+
>> say ""
79+
)
80+
threadDelay 1
81+
traverse_ (\tid -> throwTo tid ThreadKilled) threads
82+
83+
84+
prop_async :: forall m. (MonadAsync m, MonadDelay m, MonadSay m) => Int -> m ()
85+
prop_async n = do
86+
threads <- replicateM n (async $ threadDelay 1
87+
>> say ""
88+
)
89+
traverse_ wait threads
90+
91+
92+
main :: IO ()
93+
main = defaultMain
94+
[ env (let !n = 10000
95+
!d1 = 1
96+
!d2 = 2
97+
in pure (n, d1, d2))
98+
$ \ ~(n, d1, d2) ->
99+
bgroup "ping-pong"
100+
[ bench "stm channel without delay" $
101+
whnf id (runSimOrThrow (prop_channel Nothing n nullTracer))
102+
, bench "stm channel with delay" $
103+
whnf id (runSimOrThrow (prop_channel (Just (d1, d2)) n nullTracer))
104+
, bench "events" $
105+
nf id ( selectTraceEventsSay
106+
$ runSimTrace
107+
$ prop_channel Nothing n (Tracer $ say . show))
108+
]
109+
, env (pure ()) $ \_ ->
110+
bgroup "delays"
111+
[ bench "threadDelay" $
112+
whnf id (runSimOrThrow prop_threadDelay)
113+
, bench "registerDelay" $
114+
whnf id (runSimOrThrow prop_registerDelay)
115+
, bgroup "timeout"
116+
[ bench "fail" $
117+
whnf id (runSimOrThrow prop_timeout_fail)
118+
, bench "succeed" $
119+
whnf id (runSimOrThrow prop_timeout_succeed)
120+
]
121+
]
122+
,
123+
bgroup "threads"
124+
[ env (pure 50) $ \n ->
125+
bgroup "50"
126+
[ bench "async silent" $
127+
whnf id (runSimOrThrow (prop_async n))
128+
, bench "forkIO silent" $
129+
whnf id (runSimOrThrow (prop_threads n))
130+
, bench "async say" $
131+
nf id ( selectTraceEventsSay
132+
$ runSimTrace
133+
$ prop_async n)
134+
, bench "forkIO say" $
135+
nf id ( selectTraceEventsSay
136+
$ runSimTrace
137+
$ prop_threads n)
138+
]
139+
, env (pure 250) $ \n ->
140+
bgroup "250"
141+
[ bench "async" $
142+
whnf id (runSimOrThrow (prop_async n))
143+
, bench "forkIO" $
144+
whnf id (runSimOrThrow (prop_threads n))
145+
]
146+
]
147+
]

‎io-sim/io-sim.cabal

Lines changed: 23 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
cabal-version: 2.4
12
name: io-sim
23
version: 0.2.0.0
34
synopsis: A pure simulator for monadic concurrency with STM
@@ -11,7 +12,6 @@ author: Duncan Coutts, Marcin Szamotulski, Alexander Vieth
1112
maintainer:
1213
category: Testing
1314
build-type: Simple
14-
cabal-version: >=1.10
1515

1616
flag asserts
1717
description: Enable assertions
@@ -94,3 +94,25 @@ test-suite test
9494

9595
ghc-options: -Wall
9696
-fno-ignore-asserts
97+
98+
benchmark bench
99+
type: exitcode-stdio-1.0
100+
hs-source-dirs: bench
101+
main-is: Main.hs
102+
default-language: Haskell2010
103+
build-depends: base,
104+
criterion,
105+
106+
contra-tracer,
107+
io-classes,
108+
io-sim,
109+
typed-protocols,
110+
typed-protocols-cborg,
111+
typed-protocols-examples
112+
ghc-options: -Wall
113+
-Wcompat
114+
-Wincomplete-uni-patterns
115+
-Wincomplete-record-updates
116+
-Wpartial-fields
117+
-Widentities
118+
-Wredundant-constraints

0 commit comments

Comments
 (0)