git.iko.soy/effectful
on master help sign in
Benchmark multiple implementations of asyncWithUnmask
f56627fAndrzej Rybczak
bench/Concurrency.hsnew file+77
compare with master
unifiedsplit
@@ -0,0 +1,77 @@
1+{-# LANGUAGE CPP #-}
2+module Concurrency (concurrencyBenchmark) where
3+
4+#ifdef VERSION_criterion
5+import Criterion
6+import Criterion.Main
7+#endif
8+
9+#ifdef VERSION_tasty_bench
10+import Test.Tasty.Bench hiding (env)
11+#endif
12+
13+import Control.Concurrent.Async
14+import Control.Monad
15+import Control.Monad.IO.Class
16+import qualified Effectful.Async as A
17+
18+import Effectful
19+import Utils
20+
21+concurrencyBenchmark :: Benchmark
22+concurrencyBenchmark = bgroup "concurrency"
23+ [ bench "async (IO)" $ nfAppIO asyncBenchIO (pure 1)
24+ , bgroup "shallow"
25+ [ bench "async (Eff)" $ nfAppIO (runShallow . A.runAsyncE . asyncBench) (pure 1)
26+ , bench "Fork (unlift)" $ nfAppIO (runShallow . runFork1 . forkBench) (pure 1)
27+ , bench "Fork (lift/unlift)" $ nfAppIO (runShallow . runFork2 . forkBench) (pure 1)
28+ ]
29+ , bgroup "deep"
30+ [ bench "async (Eff)" $ nfAppIO (runDeep . A.runAsyncE . asyncBench) (pure 1)
31+ , bench "Fork (unlift)" $ nfAppIO (runDeep . runFork1 . forkBench) (pure 1)
32+ , bench "Fork (lift/unlift)" $ nfAppIO (runDeep . runFork2 . forkBench) (pure 1)
33+ ]
34+ ]
35+
36+----------------------------------------
37+
38+data Fork :: Effect where
39+ ForkWithUnmask :: ((forall a. m a -> m a) -> m r) -> Fork m (Async r)
40+
41+-- | Uses 'localUnliftIO' and 'withLiftSeqOp'.
42+runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a
43+runFork1 = interpretM $ \env (ForkWithUnmask m) -> withLiftSeqOp $ \liftSeqOp -> do
44+ localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
45+ asyncWithUnmask $ \unmask -> unlift $ m $ liftSeqOp unmask
46+
47+-- | Uses 'localLiftUnliftIO', slower than (1).
48+runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a
49+runFork2 = interpretM $ \env (ForkWithUnmask m) -> do
50+ localLiftUnliftIO env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do
51+ asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift
52+
53+----------------------------------------
54+
55+n :: Int
56+n = 100
57+
58+asyncBenchIO :: IO Int -> IO Int
59+asyncBenchIO f = do
60+ a <- asyncWithUnmask $ \unmask -> do
61+ sum <$> replicateM n (unmask f)
62+ wait a
63+{-# NOINLINE asyncBenchIO #-}
64+
65+asyncBench :: A.AsyncE :> es => Eff es Int -> Eff es Int
66+asyncBench f = do
67+ a <- A.asyncWithUnmask $ \unmask -> do
68+ sum <$> replicateM n (unmask f)
69+ A.wait a
70+{-# NOINLINE asyncBench #-}
71+
72+forkBench :: (IOE :> es, Fork :> es) => Eff es Int -> Eff es Int
73+forkBench f = do
74+ a <- send $ ForkWithUnmask $ \unmask -> do
75+ sum <$> replicateM n (unmask f)
76+ liftIO $ wait a
77+{-# NOINLINE forkBench #-}
bench/Main.hs+3−1
@@ -10,13 +10,15 @@ import Criterion.Main
10import Test.Tasty.Bench
10import Test.Tasty.Bench
11#endif
11#endif
12
12
13+import Concurrency
13import Countdown
14import Countdown
14import FileSizes
15import FileSizes
15import Unlift
16import Unlift
16
17
17main :: IO ()
18main :: IO ()
18main = defaultMain
19main = defaultMain
20+ [ concurrencyBenchmark
19− [ unliftBenchmark
21+ , unliftBenchmark
20 , bgroup "countdown" $ map countdown [1000, 10000]
22 , bgroup "countdown" $ map countdown [1000, 10000]
21 , bgroup "filesize" $ map filesize [100, 1000]
23 , bgroup "filesize" $ map filesize [100, 1000]
22 ]
24 ]
bench/Unlift.hs+11−27
@@ -14,6 +14,7 @@ import UnliftIO
14
14
15import Effectful
15import Effectful
16import Effectful.State.Dynamic
16import Effectful.State.Dynamic
17+import Utils
17
18
18unliftBenchmark :: Benchmark
19unliftBenchmark :: Benchmark
19unliftBenchmark = bgroup "unlift"
20unliftBenchmark = bgroup "unlift"
@@ -24,7 +25,7 @@ unliftBenchmark = bgroup "unlift"
24 ]
25 ]
25 , bgroup "shallow"
26 , bgroup "shallow"
26 [ bgroup "dummy"
27 [ bgroup "dummy"
27− [ bench "seq" $ nfAppIO (runShallow SeqUnlift) benchDummy
28+ [ bench "seq" $ nfAppIO (runShallow . withUnliftStrategy SeqUnlift) benchDummy
28 , shallowConc "conc" 1 benchDummy
29 , shallowConc "conc" 1 benchDummy
29 ]
30 ]
30 , shallowConc "async" 1 benchAsync
31 , shallowConc "async" 1 benchAsync
@@ -32,7 +33,7 @@ unliftBenchmark = bgroup "unlift"
32 ]
33 ]
33 , bgroup "deep"
34 , bgroup "deep"
34 [ bgroup "dummy"
35 [ bgroup "dummy"
35− [ bench "seq" $ nfAppIO (runDeep SeqUnlift) benchDummy
36+ [ bench "seq" $ nfAppIO (runDeep . withUnliftStrategy SeqUnlift) benchDummy
36 , deepConc "conc" 1 benchDummy
37 , deepConc "conc" 1 benchDummy
37 ]
38 ]
38 , deepConc "async" 1 benchAsync
39 , deepConc "async" 1 benchAsync
@@ -42,23 +43,6 @@ unliftBenchmark = bgroup "unlift"
42
43
43----------------------------------------
44----------------------------------------
44
45
45−runShallow :: UnliftStrategy -> Eff '[IOE] a -> IO a
46−runShallow s = runIOE . withUnliftStrategy s
47−
48−runDeep
49− :: UnliftStrategy
50− -> Eff '[ State (), State (), State (), State (), State ()
51− , State (), State (), State (), State (), State ()
52− , IOE
53− ] a
54− -> IO a
55−runDeep s = runIOE
56− . evalState () . evalState () . evalState () . evalState () . evalState ()
57− . evalState () . evalState () . evalState () . evalState () . evalState ()
58− . withUnliftStrategy s
59−
60−----------------------------------------
61−
62shallowConc
46shallowConc
63 :: String
47 :: String
64 -> Int
48 -> Int
@@ -66,13 +50,13 @@ shallowConc
66 -> Benchmark
50 -> Benchmark
67shallowConc name n f = bgroup name
51shallowConc name n f = bgroup name
68 [ bench "ephemeral/limited" $ nfAppIO
52 [ bench "ephemeral/limited" $ nfAppIO
69− (runShallow (ConcUnlift Ephemeral $ Limited n)) f
53+ (runShallow . withUnliftStrategy (ConcUnlift Ephemeral $ Limited n)) f
70 , bench "ephemeral/unlimited" $ nfAppIO
54 , bench "ephemeral/unlimited" $ nfAppIO
71− (runShallow (ConcUnlift Ephemeral Unlimited)) f
55+ (runShallow . withUnliftStrategy (ConcUnlift Ephemeral Unlimited)) f
72 , bench "persistent/limited" $ nfAppIO
56 , bench "persistent/limited" $ nfAppIO
73− (runShallow (ConcUnlift Persistent $ Limited n)) f
57+ (runShallow . withUnliftStrategy (ConcUnlift Persistent $ Limited n)) f
74 , bench "persistent/unlimited" $ nfAppIO
58 , bench "persistent/unlimited" $ nfAppIO
75− (runShallow (ConcUnlift Persistent Unlimited)) f
59+ (runShallow . withUnliftStrategy (ConcUnlift Persistent Unlimited)) f
76 ]
60 ]
77
61
78deepConc
62deepConc
@@ -84,13 +68,13 @@ deepConc
84 -> Benchmark
68 -> Benchmark
85deepConc name n f = bgroup name
69deepConc name n f = bgroup name
86 [ bench "ephemeral/limited" $ nfAppIO
70 [ bench "ephemeral/limited" $ nfAppIO
87− (runDeep (ConcUnlift Ephemeral $ Limited n)) f
71+ (runDeep . withUnliftStrategy (ConcUnlift Ephemeral $ Limited n)) f
88 , bench "ephemeral/unlimited" $ nfAppIO
72 , bench "ephemeral/unlimited" $ nfAppIO
89− (runDeep (ConcUnlift Ephemeral Unlimited)) f
73+ (runDeep . withUnliftStrategy (ConcUnlift Ephemeral Unlimited)) f
90 , bench "persistent/limited" $ nfAppIO
74 , bench "persistent/limited" $ nfAppIO
91− (runDeep (ConcUnlift Persistent $ Limited n)) f
75+ (runDeep . withUnliftStrategy (ConcUnlift Persistent $ Limited n)) f
92 , bench "persistent/unlimited" $ nfAppIO
76 , bench "persistent/unlimited" $ nfAppIO
93− (runDeep (ConcUnlift Persistent Unlimited)) f
77+ (runDeep . withUnliftStrategy (ConcUnlift Persistent Unlimited)) f
94 ]
78 ]
95
79
96----------------------------------------
80----------------------------------------
bench/Utils.hsnew file+20
@@ -0,0 +1,20 @@
1+module Utils
2+ ( runShallow
3+ , runDeep
4+ ) where
5+
6+import Effectful
7+import Effectful.State.Dynamic
8+
9+runShallow :: Eff '[IOE] a -> IO a
10+runShallow = runIOE
11+
12+runDeep
13+ :: Eff '[ State (), State (), State (), State (), State ()
14+ , State (), State (), State (), State (), State ()
15+ , IOE
16+ ] a
17+ -> IO a
18+runDeep = runIOE
19+ . evalState () . evalState () . evalState () . evalState () . evalState ()
20+ . evalState () . evalState () . evalState () . evalState () . evalState ()
effectful.cabal+4−1
@@ -149,12 +149,15 @@ benchmark bench
149 , tasty-bench
149 , tasty-bench
150 , unix
150 , unix
151 , unliftio
151 , unliftio
152+ , async
152
153
153 hs-source-dirs: bench
154 hs-source-dirs: bench
154
155
155 type: exitcode-stdio-1.0
156 type: exitcode-stdio-1.0
156 main-is: Main.hs
157 main-is: Main.hs
157
158
159+ other-modules: Concurrency
158− other-modules: Countdown
160+ Countdown
159 FileSizes
161 FileSizes
160 Unlift
162 Unlift
163+ Utils