git.iko.soy/streamly
on 57fad21 help sign in
streamly/benchmark/Chart.hs
335 lines 12 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 = Linear | LinearAsync | LinearRate | Nested | Base
26 deriving Show
28data Options = Options
29 { genGraphs :: Bool
30 , groupDiff :: Bool
31 , benchType :: BenchType
32 } deriving Show
34defaultOptions = Options False False Linear
36setGenGraphs val = do
37 (args, opts) <- get
38 put (args, opts { genGraphs = val })
40setGroupDiff val = do
41 (args, opts) <- get
42 put (args, opts { groupDiff = val })
44setBenchType val = do
45 (args, opts) <- get
46 put (args, opts { benchType = val })
48-- Like the shell "shift" to shift the command line arguments
49shift :: StateT ([String], Options) (MaybeT IO) (Maybe String)
50shift = do
51 s <- get
52 case s of
53 ([], _) -> return Nothing
54 (x : xs, opts) -> put (xs, opts) >> return (Just x)
56parseBench :: StateT ([String], Options) (MaybeT IO) ()
57parseBench = do
58 x <- shift
59 case x of
60 Just "linear" -> setBenchType Linear
61 Just "linear-async" -> setBenchType LinearAsync
62 Just "linear-rate" -> setBenchType LinearRate
63 Just "nested" -> setBenchType Nested
64 Just "base" -> setBenchType Base
65 Just str -> do
66 liftIO $ putStrLn $ "unrecognized benchmark type " <> str
67 mzero
68 Nothing -> do
69 liftIO $ putStrLn "please provide a benchmark type "
70 mzero
72-- totally imperative style option parsing
73parseOptions :: IO (Maybe Options)
74parseOptions = do
75 args <- getArgs
76 runMaybeT $ flip evalStateT (args, defaultOptions) $ do
77 parseLoop
78 fmap snd get
80 where
82 parseOpt opt =
83 case opt of
84 "--graphs" -> setGenGraphs True
85 "--group-diff" -> setGroupDiff True
86 "--benchmark" -> parseBench
87 str -> do
88 liftIO $ putStrLn $ "Unrecognized option " <> str
89 mzero
91 parseLoop = do
92 next <- shift
93 case next of
94 Just opt -> parseOpt opt >> parseLoop
95 Nothing -> return ()
97ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->
98 putStrLn $ "Failed with error:\n" <> err <> "\nSkipping.")
100------------------------------------------------------------------------------
101-- Linear composition charts
102------------------------------------------------------------------------------
104makeLinearGraphs :: Config -> String -> IO ()
105makeLinearGraphs cfg@Config{..} inputFile = do
106 ignoringErr $ graph inputFile "generation" $ cfg
107 { title = (++) <$> title <*> Just " generation"
108 , classifyBenchmark =
109 fmap ("Streamly",) . stripPrefix "serially/generation/"
110 }
112 ignoringErr $ graph inputFile "elimination" $ cfg
113 { title = (++) <$> title <*> Just " Elimination"
114 , classifyBenchmark =
115 fmap ("Streamly",) . stripPrefix "serially/elimination/"
116 }
118 ignoringErr $ graph inputFile "transformation-zip" $ cfg
119 { title = (++) <$> title <*> Just " Transformation & Zip"
120 , classifyBenchmark = \b ->
121 if "serially/transformation/" `isPrefixOf` b
122 || "serially/zipping" `isPrefixOf` b
123 then Just ("Streamly", last $ splitOn "/" b)
124 else Nothing
125 }
127 ignoringErr $ graph inputFile "filtering" $ cfg
128 { title = (++) <$> title <*> Just " Filtering"
129 , classifyBenchmark =
130 fmap ("Streamly",) . stripPrefix "serially/filtering/"
131 }
133 ignoringErr $ graph inputFile "transformationX4" $ cfg
134 { title = (++) <$> title <*> Just " Transformation x 4"
135 , classifyBenchmark =
136 fmap ("Streamly",) . stripPrefix "serially/transformationX4/"
137 }
139 ignoringErr $ graph inputFile "filteringX4"
140 $ cfg
141 { title = (++) <$> title <*> Just " Filtering x 4"
142 , classifyBenchmark =
143 fmap ("Streamly",) . stripPrefix "serially/filteringX4/"
144 }
146 ignoringErr $ graph inputFile "mixedX4"
147 $ cfg
148 { title = (++) <$> title <*> Just " Mixed x 4"
149 , classifyBenchmark =
150 fmap ("Streamly",) . stripPrefix "serially/mixedX4/"
151 }
153 ignoringErr $ graph inputFile "iterated"
154 $ cfg
155 { title = Just "iterate 10,000 times over 10 elems"
156 , classifyBenchmark =
157 fmap ("Streamly",) . stripPrefix "serially/iterated/"
158 }
160------------------------------------------------------------------------------
161-- Nested composition charts
162------------------------------------------------------------------------------
164makeNestedGraphs :: Config -> String -> IO ()
165makeNestedGraphs cfg inputFile =
166 ignoringErr $ graph inputFile "nested-all" $ cfg
167 { presentation = Groups Absolute
168 , classifyBenchmark = classifyNested
169 , selectGroups = \gs ->
170 groupBy ((==) `on` snd) gs
171 & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)
172 & concat
173 }
175 where
177 order = ["serially", "asyncly", "wAsyncly", "aheadly", "parallely"]
179 classifyNested b
180 | "serially/" `isPrefixOf` b =
181 ("serially",) <$> stripPrefix "serially/" b
182 | "asyncly/" `isPrefixOf` b =
183 ("asyncly",) <$> stripPrefix "asyncly/" b
184 | "wAsyncly/" `isPrefixOf` b =
185 ("wAsyncly",) <$> stripPrefix "wAsyncly/" b
186 | "aheadly/" `isPrefixOf` b =
187 ("aheadly",) <$> stripPrefix "aheadly/" b
188 | "parallely/" `isPrefixOf` b =
189 ("parallely",) <$> stripPrefix "parallely/" b
190 | otherwise = Nothing
192------------------------------------------------------------------------------
193-- Charts for parallel streams
194------------------------------------------------------------------------------
196makeLinearAsyncGraphs :: Config -> String -> IO ()
197makeLinearAsyncGraphs cfg inputFile =
198 ignoringErr $ graph inputFile "linear-async" cfg
199 { presentation = Groups Absolute
200 , classifyBenchmark = classifyAsync
201 , selectGroups = \gs ->
202 groupBy ((==) `on` snd) gs
203 & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)
204 & concat
205 }
207 where
209 order = ["asyncly", "wAsyncly", "aheadly", "parallely"]
211 classifyAsync b
212 | "asyncly/" `isPrefixOf` b =
213 ("asyncly",) <$> stripPrefix "asyncly/" b
214 | "wAsyncly/" `isPrefixOf` b =
215 ("wAsyncly",) <$> stripPrefix "wAsyncly/" b
216 | "aheadly/" `isPrefixOf` b =
217 ("aheadly",) <$> stripPrefix "aheadly/" b
218 | "parallely/" `isPrefixOf` b =
219 ("parallely",) <$> stripPrefix "parallely/" b
220 | otherwise = Nothing
222makeLinearRateGraphs :: Config -> String -> IO ()
223makeLinearRateGraphs cfg inputFile = do
224 putStrLn "Not implemented"
225 return ()
227------------------------------------------------------------------------------
228-- Reports/Charts for base streams
229------------------------------------------------------------------------------
231showStreamDVsK Options{..} cfg inp out =
232 let cfg' = cfg { classifyBenchmark = classifyBase }
233 in if genGraphs
234 then ignoringErr $ graph inp "streamD-vs-streamK"
235 cfg' { outputDir = Just out
236 , presentation = Groups Absolute
237 }
238 else ignoringErr $ report inp Nothing cfg'
240 where
242 classifyBase b
243 | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b
244 | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b
245 | otherwise = Nothing
247showStreamD Options{..} cfg inp out =
248 let cfg' = cfg { classifyBenchmark = classifyStreamD }
249 in if genGraphs
250 then ignoringErr $ graph inp "streamD"
251 cfg' {outputDir = Just out}
252 else ignoringErr $ report inp Nothing cfg'
254 where
256 classifyStreamD b
257 | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b
258 | otherwise = Nothing
260showStreamK Options{..} cfg inp out =
261 let cfg' = cfg { classifyBenchmark = classifyStreamK }
262 in if genGraphs
263 then ignoringErr $ graph inp "streamK"
264 cfg' {outputDir = Just out}
265 else ignoringErr $ report inp Nothing cfg'
267 where
269 classifyStreamK b
270 | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b
271 | otherwise = Nothing
273------------------------------------------------------------------------------
274-- text reports
275------------------------------------------------------------------------------
277selectBench :: (SortColumn -> Either String [(String, Double)]) -> [String]
278selectBench f =
279 reverse
280 $ fmap fst
281 $ either
282 (const $ either error (sortOn snd) $ f $ ColumnIndex 0)
283 (sortOn snd)
284 $ f $ ColumnIndex 1
286benchShow Options{..} cfg func inp out =
287 if genGraphs
288 then func cfg {outputDir = Just out} inp
289 else ignoringErr $ report inp Nothing cfg
291main :: IO ()
292main = do
293 let cfg = defaultConfig
294 { presentation = Groups PercentDiff
295 , selectBenchmarks = selectBench
296 }
297 res <- parseOptions
299 case res of
300 Nothing -> do
301 putStrLn "cannot parse options"
302 return ()
303 Just opts@Options{..} ->
304 case benchType of
305 Linear -> benchShow opts cfg
306 { title = Just "100,000 elems" }
307 makeLinearGraphs
308 "charts/linear/results.csv"
309 "charts/linear"
310 LinearAsync -> benchShow opts cfg
311 { title = Just "Async 10,000 elems" }
312 makeLinearAsyncGraphs
313 "charts/linear-async/results.csv"
314 "charts/linear-async"
315 LinearRate -> benchShow opts cfg makeLinearRateGraphs
316 "charts/linear-rate/results.csv"
317 "charts/linear-rate"
318 Nested -> benchShow opts cfg
319 { title = Just "Nested loops 100 x 100 elems" }
320 makeNestedGraphs
321 "charts/nested/results.csv"
322 "charts/nested"
323 Base -> do
324 let cfg' = cfg { title = Just "100,000 elems" }
325 if groupDiff
326 then showStreamDVsK opts cfg'
327 "charts/base/results.csv"
328 "charts/base"
329 else do
330 showStreamD opts cfg'
331 "charts/base/results.csv"
332 "charts/base"
333 showStreamK opts cfg'
334 "charts/base/results.csv"
335 "charts/base"