git.iko.soy/streamly
on cf63b4e help sign in
streamly/benchmark/lib/Streamly/Benchmark/Common.hs
209 lines 6.7 kB history raw
1{-# LANGUAGE CPP #-}
2#if __GLASGOW_HASKELL__ >= 800
3{-# OPTIONS_GHC -Wno-orphans #-}
4#endif
6-- |
7-- Module : Streamly.Benchmark.Common
8-- Copyright : (c) 2019 Composewell Technologies
9--
10-- License : BSD3
11-- Maintainer : streamly@composewell.com
13module Streamly.Benchmark.Common
14 ( o_1_space_prefix
15 , o_n_space_prefix
16 , o_n_heap_prefix
17 , o_n_stack_prefix
19 , parseCLIOpts
21 , benchIOSink1
22 , benchPure
23 , benchPureSink1
24 , benchFold
26 , benchIOSrc1
27 , benchPureSrc
29 , mkString
30 , mkList
31 , mkListString
33 , defaultStreamSize
34 )
35where
37import Control.DeepSeq (NFData(..))
38import Control.Exception (evaluate)
39import Control.Monad (when)
40import Data.Functor.Identity (Identity, runIdentity)
41import Data.List (scanl')
42import Data.Maybe (mapMaybe)
43import System.Console.GetOpt
44 (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt')
45import System.Environment (getArgs, lookupEnv, setEnv)
46import Text.Read (readMaybe)
47import System.Random (randomRIO)
49import qualified Streamly.Prelude as S
51import Streamly.Prelude (SerialT)
52import Gauge
54-------------------------------------------------------------------------------
55-- Benchmark Prefixes
56-------------------------------------------------------------------------------
58o_1_space_prefix :: String -> String
59o_1_space_prefix name = name ++ "/o-1-space"
61o_n_space_prefix :: String -> String
62o_n_space_prefix name = name ++ "/o-n-space"
64o_n_heap_prefix :: String -> String
65o_n_heap_prefix name = name ++ "/o-n-heap"
67o_n_stack_prefix :: String -> String
68o_n_stack_prefix name = name ++ "/o-n-stack"
70-------------------------------------------------------------------------------
71-- Benchmarking utilities
72-------------------------------------------------------------------------------
74#if !MIN_VERSION_deepseq(1,4,3)
75instance NFData Ordering where rnf = (`seq` ())
76#endif
78-- XXX once we convert all the functions to use this we can rename this to
79-- benchIOSink
80{-# INLINE benchIOSink1 #-}
81benchIOSink1 :: NFData b => String -> (Int -> IO b) -> Benchmark
82benchIOSink1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f
84{-# INLINE benchIOSrc1 #-}
85benchIOSrc1 :: String -> (Int -> IO ()) -> Benchmark
86benchIOSrc1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f
88-- We need a monadic bind here to make sure that the function f does not get
89-- completely optimized out by the compiler in some cases.
90{-# INLINE benchFold #-}
91benchFold :: NFData b
92 => String -> (t IO Int -> IO b) -> (Int -> t IO Int) -> Benchmark
93benchFold name f src = bench name $ nfIO $ randomRIO (1,1) >>= f . src
95{-# INLINE benchPure #-}
96benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark
97benchPure name src f = bench name $ nfIO $ randomRIO (1,1) >>= return . f . src
99-- XXX once we convert all the functions to use this we can rename this to
100-- benchPureSink
101{-# INLINE benchPureSink1 #-}
102benchPureSink1 :: NFData b => String -> (Int -> Identity b) -> Benchmark
103benchPureSink1 name f =
104 bench name $ nfIO $ randomRIO (1,1) >>= return . runIdentity . f
106{-# INLINE benchPureSrc #-}
107benchPureSrc :: String -> (Int -> SerialT Identity a) -> Benchmark
108benchPureSrc name src = benchPure name src (runIdentity . S.drain)
110-------------------------------------------------------------------------------
111-- String/List generation for read instances
112-------------------------------------------------------------------------------
114{-# INLINABLE mkString #-}
115mkString :: Int -> String
116mkString value = "fromList [1" ++ concat (replicate value ",1") ++ "]"
118{-# INLINABLE mkListString #-}
119mkListString :: Int -> String
120mkListString value = "[1" ++ concat (replicate value ",1") ++ "]"
122{-# INLINABLE mkList #-}
123mkList :: Int -> [Int]
124mkList value = [1..value]
126-------------------------------------------------------------------------------
127-- Stream size
128-------------------------------------------------------------------------------
130defaultStreamSize :: Int
131defaultStreamSize = 100000
133-------------------------------------------------------------------------------
134-- Parse custom CLI options
135-------------------------------------------------------------------------------
137newtype BenchOpts = StreamSize Int deriving Show
139getStreamSize :: String -> Int
140getStreamSize size =
141 case (readMaybe size :: Maybe Int) of
142 Just x -> x
143 Nothing -> error "Stream size must be numeric"
145options :: [OptDescr BenchOpts]
146options =
147 [
148 Option [] ["stream-size"] (ReqArg getSize "COUNT") "Stream element count"
149 ]
151 where
153 getSize = StreamSize . getStreamSize
155deleteOptArgs
156 :: (Maybe String, Maybe String) -- (prev, yielded)
157 -> String
158 -> (Maybe String, Maybe String)
159deleteOptArgs (Nothing, _) opt =
160 if opt == "--stream-size"
161 then (Just opt, Nothing)
162 else (Just opt, Just opt)
164deleteOptArgs (Just prev, _) opt =
165 if opt == "--stream-size" || prev == "--stream-size"
166 then (Just opt, Nothing)
167 else (Just opt, Just opt)
169parseCLIOpts :: Int -> IO (Int, Config, [String])
170parseCLIOpts defStreamSize = do
171 args <- getArgs
173 -- Parse custom options
174 let (opts, _, _, errs) = getOpt' Permute options args
175 when (not $ null errs) $ error $ concat errs
176 (streamSize, args') <-
177 case opts of
178 StreamSize x : _ -> do
179 putStrLn $ "Stream size: " ++ show x
180 -- When using the gauge "--measure-with" option we need to make
181 -- sure that we pass the stream size to child process forked by
182 -- gauge. So we use this env var for that purpose.
183 setEnv "STREAM_SIZE" (show x)
184 -- Hack! remove the option and its argument from args
185 -- getOpt should have a way to return the unconsumed args in
186 -- correct order.
187 newArgs <-
188 evaluate
189 $ mapMaybe snd
190 $ scanl' deleteOptArgs (Nothing, Nothing) args
191 return (x, newArgs)
192 _ -> do
193 r <- lookupEnv "STREAM_SIZE"
194 case r of
195 Just x -> do
196 s <- evaluate $ getStreamSize x
197 return (s, args)
198 Nothing -> do
199 setEnv "STREAM_SIZE" (show defStreamSize)
200 return (defStreamSize, args)
202 -- Parse gauge options
203 let config = defaultConfig
204 { timeLimit = Just 1
205 , minDuration = 0
206 , includeFirstIter = streamSize > defStreamSize
207 }
208 let (cfg, benches) = parseWith config args'
209 streamSize `seq` return (streamSize, cfg, benches)