git.iko.soy/streamly
on 385f0fc help sign in
streamly/benchmark/Chart.hs
393 lines 14 kB history raw
1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
5module Main where
7import Control.Exception (handle, catch, SomeException, ErrorCall(..))
8import Control.Monad.Trans.State
9import Control.Monad.Trans.Maybe
10import Data.Function (on, (&))
11import Data.List
12import Data.List.Split
13import Data.Maybe (mapMaybe)
14import Data.Ord (comparing)
15import System.Environment (getArgs)
16import Control.Monad.IO.Class (liftIO)
17import Control.Monad (mzero)
19import BenchShow
21------------------------------------------------------------------------------
22-- Command line parsing
23------------------------------------------------------------------------------
25data BenchType
26 = Linear
27 | LinearAsync
28 | LinearRate
29 | Nested
30 | NestedConcurrent
31 | NestedUnfold
32 | Base
33 | FileIO
34 | Array
35 | Concurrent
36 deriving Show
38data Options = Options
39 { genGraphs :: Bool
40 , groupDiff :: Bool
41 , benchType :: BenchType
42 } deriving Show
44defaultOptions = Options False False Linear
46setGenGraphs val = do
47 (args, opts) <- get
48 put (args, opts { genGraphs = val })
50setGroupDiff val = do
51 (args, opts) <- get
52 put (args, opts { groupDiff = val })
54setBenchType val = do
55 (args, opts) <- get
56 put (args, opts { benchType = val })
58-- Like the shell "shift" to shift the command line arguments
59shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
60shift = do
61 s <- get
62 case s of
63 ([], _) -> return Nothing
64 (x : xs, opts) -> put (xs, opts) >> return (Just x)
66parseBench :: StateT ([String], Options) (MaybeT IO) ()
67parseBench = do
68 x <- shift
69 case x of
70 Just "linear" -> setBenchType Linear
71 Just "linear-async" -> setBenchType LinearAsync
72 Just "linear-rate" -> setBenchType LinearRate
73 Just "nested" -> setBenchType Nested
74 Just "nested-concurrent" -> setBenchType NestedConcurrent
75 Just "nested-unfold" -> setBenchType NestedUnfold
76 Just "base" -> setBenchType Base
77 Just "fileio" -> setBenchType FileIO
78 Just "array" -> setBenchType Array
79 Just "concurrent" -> setBenchType Concurrent
80 Just str -> do
81 liftIO $ putStrLn $ "unrecognized benchmark type " <> str
82 mzero
83 Nothing -> do
84 liftIO $ putStrLn "please provide a benchmark type "
85 mzero
87-- totally imperative style option parsing
88parseOptions :: IO (Maybe Options)
89parseOptions = do
90 args <- getArgs
91 runMaybeT $ flip evalStateT (args, defaultOptions) $ do
92 parseLoop
93 fmap snd get
95 where
97 parseOpt opt =
98 case opt of
99 "--graphs" -> setGenGraphs True
100 "--group-diff" -> setGroupDiff True
101 "--benchmark" -> parseBench
102 str -> do
103 liftIO $ putStrLn $ "Unrecognized option " <> str
104 mzero
106 parseLoop = do
107 next <- shift
108 case next of
109 Just opt -> parseOpt opt >> parseLoop
110 Nothing -> return ()
112ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->
113 putStrLn $ "Failed with error:\n" <> err <> "\nSkipping.")
115------------------------------------------------------------------------------
116-- Linear composition charts
117------------------------------------------------------------------------------
119makeLinearGraphs :: Config -> String -> IO ()
120makeLinearGraphs cfg@Config{..} inputFile = do
121 ignoringErr $ graph inputFile "generation" $ cfg
122 { title = (++) <$> title <*> Just " generation"
123 , classifyBenchmark =
124 fmap ("Streamly",) . stripPrefix "serially/generation/"
125 }
127 ignoringErr $ graph inputFile "elimination" $ cfg
128 { title = (++) <$> title <*> Just " Elimination"
129 , classifyBenchmark =
130 fmap ("Streamly",) . stripPrefix "serially/elimination/"
131 }
133 ignoringErr $ graph inputFile "transformation-zip" $ cfg
134 { title = (++) <$> title <*> Just " Transformation & Zip"
135 , classifyBenchmark = \b ->
136 if "serially/transformation/" `isPrefixOf` b
137 || "serially/zipping" `isPrefixOf` b
138 then Just ("Streamly", last $ splitOn "/" b)
139 else Nothing
140 }
142 ignoringErr $ graph inputFile "filtering" $ cfg
143 { title = (++) <$> title <*> Just " Filtering"
144 , classifyBenchmark =
145 fmap ("Streamly",) . stripPrefix "serially/filtering/"
146 }
148 ignoringErr $ graph inputFile "transformationX4" $ cfg
149 { title = (++) <$> title <*> Just " Transformation x 4"
150 , classifyBenchmark =
151 fmap ("Streamly",) . stripPrefix "serially/transformationX4/"
152 }
154 ignoringErr $ graph inputFile "filteringX4"
155 $ cfg
156 { title = (++) <$> title <*> Just " Filtering x 4"
157 , classifyBenchmark =
158 fmap ("Streamly",) . stripPrefix "serially/filteringX4/"
159 }
161 ignoringErr $ graph inputFile "mixedX4"
162 $ cfg
163 { title = (++) <$> title <*> Just " Mixed x 4"
164 , classifyBenchmark =
165 fmap ("Streamly",) . stripPrefix "serially/mixedX4/"
166 }
168 ignoringErr $ graph inputFile "iterated"
169 $ cfg
170 { title = Just "iterate 10,000 times over 10 elems"
171 , classifyBenchmark =
172 fmap ("Streamly",) . stripPrefix "serially/iterated/"
173 }
175------------------------------------------------------------------------------
176-- Nested composition charts
177------------------------------------------------------------------------------
179makeNestedGraphs :: Config -> String -> IO ()
180makeNestedGraphs cfg inputFile =
181 ignoringErr $ graph inputFile "nested-all" $ cfg
182 { presentation = Groups Absolute
183 , classifyBenchmark = classifyNested
184 , selectGroups = \gs ->
185 groupBy ((==) `on` snd) gs
186 & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)
187 & concat
188 }
190 where
192 order = ["serially", "asyncly", "wAsyncly", "aheadly", "parallely"]
194 classifyNested b
195 | "serially/" `isPrefixOf` b =
196 ("serially",) <$> stripPrefix "serially/" b
197 | "asyncly/" `isPrefixOf` b =
198 ("asyncly",) <$> stripPrefix "asyncly/" b
199 | "wAsyncly/" `isPrefixOf` b =
200 ("wAsyncly",) <$> stripPrefix "wAsyncly/" b
201 | "aheadly/" `isPrefixOf` b =
202 ("aheadly",) <$> stripPrefix "aheadly/" b
203 | "parallely/" `isPrefixOf` b =
204 ("parallely",) <$> stripPrefix "parallely/" b
205 | otherwise = Nothing
207------------------------------------------------------------------------------
208-- Charts for parallel streams
209------------------------------------------------------------------------------
211makeLinearAsyncGraphs :: Config -> String -> IO ()
212makeLinearAsyncGraphs cfg inputFile =
213 ignoringErr $ graph inputFile "linear-async" cfg
214 { presentation = Groups Absolute
215 , classifyBenchmark = classifyAsync
216 , selectGroups = \gs ->
217 groupBy ((==) `on` snd) gs
218 & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)
219 & concat
220 }
222 where
224 order = ["asyncly", "wAsyncly", "aheadly", "parallely"]
226 classifyAsync b
227 | "asyncly/" `isPrefixOf` b =
228 ("asyncly",) <$> stripPrefix "asyncly/" b
229 | "wAsyncly/" `isPrefixOf` b =
230 ("wAsyncly",) <$> stripPrefix "wAsyncly/" b
231 | "aheadly/" `isPrefixOf` b =
232 ("aheadly",) <$> stripPrefix "aheadly/" b
233 | "parallely/" `isPrefixOf` b =
234 ("parallely",) <$> stripPrefix "parallely/" b
235 | otherwise = Nothing
237makeLinearRateGraphs :: Config -> String -> IO ()
238makeLinearRateGraphs cfg inputFile = do
239 putStrLn "Not implemented"
240 return ()
242------------------------------------------------------------------------------
243-- FileIO
244------------------------------------------------------------------------------
246makeFileIOGraphs :: Config -> String -> IO ()
247makeFileIOGraphs cfg@Config{..} inputFile =
248 ignoringErr $ graph inputFile "fileIO" cfg
250makeArrayGraphs :: Config -> String -> IO ()
251makeArrayGraphs cfg@Config{..} inputFile =
252 ignoringErr $ graph inputFile "array" cfg
254makeConcurrentGraphs :: Config -> String -> IO ()
255makeConcurrentGraphs cfg@Config{..} inputFile =
256 ignoringErr $ graph inputFile "concurrent" cfg
258------------------------------------------------------------------------------
259-- Reports/Charts for base streams
260------------------------------------------------------------------------------
262showStreamDVsK Options{..} cfg inp out =
263 let cfg' = cfg { classifyBenchmark = classifyBase }
264 in if genGraphs
265 then ignoringErr $ graph inp "streamD-vs-streamK"
266 cfg' { outputDir = Just out
267 , presentation = Groups Absolute
268 }
269 else ignoringErr $ report inp Nothing cfg'
271 where
273 classifyBase b
274 | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b
275 | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b
276 | otherwise = Nothing
278showStreamD Options{..} cfg inp out =
279 let cfg' = cfg { classifyBenchmark = classifyStreamD }
280 in if genGraphs
281 then ignoringErr $ graph inp "streamD"
282 cfg' {outputDir = Just out}
283 else ignoringErr $ report inp Nothing cfg'
285 where
287 classifyStreamD b
288 | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b
289 | otherwise = Nothing
291showStreamK Options{..} cfg inp out =
292 let cfg' = cfg { classifyBenchmark = classifyStreamK }
293 in if genGraphs
294 then ignoringErr $ graph inp "streamK"
295 cfg' {outputDir = Just out}
296 else ignoringErr $ report inp Nothing cfg'
298 where
300 classifyStreamK b
301 | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b
302 | otherwise = Nothing
304------------------------------------------------------------------------------
305-- text reports
306------------------------------------------------------------------------------
308selectBench
309 :: (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])
310 -> [String]
311selectBench f =
312 reverse
313 $ fmap fst
314 $ either
315 (const $ either error (sortOn snd) $ f (ColumnIndex 0) (Just PercentDiff))
316 (sortOn snd)
317 $ f (ColumnIndex 1) (Just PercentDiff)
319benchShow Options{..} cfg func inp out =
320 if genGraphs
321 then func cfg {outputDir = Just out} inp
322 else ignoringErr $ report inp Nothing cfg
324main :: IO ()
325main = do
326 let cfg = defaultConfig
327 { presentation = Groups PercentDiff
328 , selectBenchmarks = selectBench
329 }
330 res <- parseOptions
332 case res of
333 Nothing -> do
334 putStrLn "cannot parse options"
335 return ()
336 Just opts@Options{..} ->
337 case benchType of
338 Linear -> benchShow opts cfg
339 { title = Just "Linear" }
340 makeLinearGraphs
341 "charts/linear/results.csv"
342 "charts/linear"
343 LinearAsync -> benchShow opts cfg
344 { title = Just "Linear Async" }
345 makeLinearAsyncGraphs
346 "charts/linear-async/results.csv"
347 "charts/linear-async"
348 LinearRate -> benchShow opts cfg makeLinearRateGraphs
349 "charts/linear-rate/results.csv"
350 "charts/linear-rate"
351 Nested -> benchShow opts cfg
352 { title = Just "Nested loops" }
353 makeNestedGraphs
354 "charts/nested/results.csv"
355 "charts/nested"
356 NestedConcurrent -> benchShow opts cfg
357 { title = Just "Nested concurrent loops" }
358 makeNestedGraphs
359 "charts/nested-concurrent/results.csv"
360 "charts/nested-concurrent"
361 NestedUnfold -> benchShow opts cfg
362 { title = Just "Nested unfold loops" }
363 makeNestedGraphs
364 "charts/nested-unfold/results.csv"
365 "charts/nested-unfold"
366 FileIO -> benchShow opts cfg
367 { title = Just "File IO" }
368 makeFileIOGraphs
369 "charts/fileio/results.csv"
370 "charts/fileio"
371 Array -> benchShow opts cfg
372 { title = Just "Array" }
373 makeArrayGraphs
374 "charts/array/results.csv"
375 "charts/array"
376 Concurrent -> benchShow opts cfg
377 { title = Just "Concurrent Ops" }
378 makeConcurrentGraphs
379 "charts/concurrent/results.csv"
380 "charts/concurrent"
381 Base -> do
382 let cfg' = cfg { title = Just "Base stream" }
383 if groupDiff
384 then showStreamDVsK opts cfg'
385 "charts/base/results.csv"
386 "charts/base"
387 else do
388 showStreamD opts cfg'
389 "charts/base/results.csv"
390 "charts/base"
391 showStreamK opts cfg'
392 "charts/base/results.csv"
393 "charts/base"