1import Gauge
2import Gauge.Main
3import Control.Concurrent (threadDelay)
4import UnliftIO
5import qualified Control.Concurrent.Async as A
6import Data.List (foldl')
7import Control.Applicative (liftA2, (<|>), empty)
8
9sizes :: (Int -> [Benchmark]) -> [Benchmark]
10sizes f = map
11  (\size -> bgroup (show size) (f size))
12  [1, 2, 10, 100, 1000, 10000, 100000]
13
14sum' :: [Int] -> Int
15sum' = foldl' (+) 0
16{-# INLINE sum' #-}
17
18replicateA_ :: Applicative f => Int -> f () -> f ()
19replicateA_ cnt0 f =
20    let go 1 = f
21        go i = f *> go (i - 1)
22     in go cnt0
23{-# INLINE replicateA_ #-}
24
25main :: IO ()
26main = defaultMain
27  [ bgroup "concurrently, minimal work" $ sizes $ \size ->
28    [ bench "A.replicateConcurrently_" $ whnfIO $ do
29        ref <- newIORef (0 :: Int)
30        A.replicateConcurrently_ size $ atomicModifyIORef' ref $ \i -> (i + 1, ())
31    , bench "replicateConcurrently_" $ whnfIO $ do
32        ref <- newIORef (0 :: Int)
33        replicateConcurrently_ size $ atomicModifyIORef' ref $ \i -> (i + 1, ())
34    , bench "Conc" $ whnfIO $ do
35        ref <- newIORef (0 :: Int)
36        runConc $ replicateA_ size $ conc $ atomicModifyIORef' ref $ \i -> (i + 1, ())
37    ]
38  , bgroup "concurrently, no results" $ sizes $ \size ->
39    [ bench "A.replicateConcurrently_" $ whnfIO $ A.replicateConcurrently_ size (pure ())
40    , bench "replicateConcurrently_" $ whnfIO $ replicateConcurrently_ size (pure ())
41    , bench "Conc" $ whnfIO $ runConc $ replicateA_ size $ conc $ pure ()
42    , bench "Conc, cheating" $ whnfIO $ runConc $ replicateA_ size $ pure ()
43    ]
44  , bgroup "concurrently, with results" $ sizes $ \size ->
45      [ bench "A.mapConcurrently" $ whnfIO $ fmap sum' $ A.mapConcurrently pure [1..size]
46      , bench "mapConcurrently" $ whnfIO $ fmap sum' $ mapConcurrently pure [1..size]
47      , bench "Conc" $ whnfIO $ runConc $
48          let go i
49                | i == size = conc (pure i)
50                | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1))
51           in go 1
52      -- This is cheating, since it's using our Pure data constructor
53      , bench "Conc, cheating" $ whnfIO $ runConc $
54          let go i
55                | i == size = pure i
56                | otherwise = liftA2 (+) (pure i) (go (i + 1))
57           in go 1
58      ]
59  , bgroup "race" $ sizes $ \size ->
60    [ bench "A.Concurrently" $ whnfIO $
61        A.runConcurrently $
62        foldr (<|>) empty (replicate size (pure ()))
63    , bench "Concurrently" $ whnfIO $
64        runConcurrently $
65        foldr (<|>) empty (replicate size (pure ()))
66    , bench "Conc" $ whnfIO $
67        runConc $
68        foldr (<|>) empty (replicate size (conc (pure ())))
69    -- This is cheating, since it's using our Pure data constructor
70    , bench "Conc, cheating" $ whnfIO $
71        runConc $
72        foldr (<|>) empty (replicate size (pure ()))
73    ]
74  , bgroup "race (with result)" $
75      sizes $ \size ->
76        [ bench "Concurrently" $
77          whnfIO $
78          runConcurrently $
79          let go i
80                | i == size = Concurrently (pure i)
81                | otherwise = liftA2 (+) (Concurrently (pure i)) (go (i + 1))
82           in (Concurrently $ threadDelay maxBound >> return 0) <|> (go 1) <|>
83              (Concurrently $ threadDelay maxBound >> return 0)
84        , bench "Conc" $
85          whnfIO $
86          runConc $
87          let go i
88                | i == size = conc (pure i)
89                | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1))
90           in (conc $ threadDelay maxBound >> return 0) <|> (go 1) <|>
91              (conc $ threadDelay maxBound >> return 0)
92        , bench "Conc, cheating" $
93          whnfIO $
94          runConc $
95          let go i
96                | i == size = conc (pure i)
97                | otherwise = liftA2 (+) (pure i) (go (i + 1))
98           in (conc $ threadDelay maxBound >> return 0) <|> (go 1) <|>
99              (conc $ threadDelay maxBound >> return 0)
100        ]
101    , let size = 10
102       in bgroup
103            "race (nested)"
104            [ bench "Concurrently" $
105              whnfIO $
106              runConcurrently $
107              let go i
108                    | i == size = Concurrently (pure i)
109                    | i `mod` 2 == 0 =
110                      (liftA2 (+) (Concurrently (pure i)) (go (i + 1))) <|>
111                      (liftA2 (+) (Concurrently (pure i)) (go (i + 2)))
112                    | otherwise =
113                      liftA2 (+) (Concurrently (pure i)) (go (i + 1))
114               in go 1
115            , bench "Conc" $
116              whnfIO $
117              runConc $
118              let go i
119                    | i == size = conc (pure i)
120                    | i `mod` 2 == 0 =
121                      (liftA2 (+) (conc (pure i)) (go (i + 1))) <|>
122                      (liftA2 (+) (conc (pure i)) (go (i + 2)))
123                    | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1))
124               in go 1
125            , bench "Conc, cheating" $
126              whnfIO $
127              runConc $
128              let go i
129                    | i == size = conc (pure i)
130                    | i `mod` 2 == 0 =
131                      (liftA2 (+) (pure i) (go (i + 1))) <|>
132                      (liftA2 (+) (pure i) (go (i + 2)))
133                    | otherwise = liftA2 (+) (pure i) (go (i + 1))
134               in go 1
135            ]
136  ]
137