git.iko.soy/streamly
on d3b4e36 help sign in
streamly/benchmark/Streamly/Benchmark/Prelude/Serial/NestedStream.hs
502 lines 16 kB history raw
1-- |
2-- Module : Serial.NestedStream
3-- Copyright : (c) 2018 Composewell Technologies
4-- License : BSD-3-Clause
5-- Maintainer : streamly@composewell.com
7{-# LANGUAGE CPP #-}
8{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE RankNTypes #-}
12#ifdef __HADDOCK_VERSION__
13#undef INSPECTION
14#endif
16#ifdef INSPECTION
17{-# LANGUAGE TemplateHaskell #-}
18{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
19#endif
21module Serial.NestedStream (benchmarks) where
23import Control.Monad.Trans.Class (lift)
25import qualified Control.Applicative as AP
27#ifdef INSPECTION
28import GHC.Types (SPEC(..))
29import Test.Inspection
31import qualified Streamly.Internal.Data.Stream.StreamD as D
32#endif
34import qualified Streamly.Prelude as S
35import qualified Streamly.Internal.Data.Stream.IsStream as Internal
36import qualified Streamly.Internal.Data.Unfold as UF
38import Gauge
39import Streamly.Prelude (SerialT, fromSerial, serial)
40import Streamly.Benchmark.Common
41import Streamly.Benchmark.Prelude
42import Prelude hiding (concatMap)
44-------------------------------------------------------------------------------
45-- Iteration/looping utilities
46-------------------------------------------------------------------------------
48{-# INLINE iterateN #-}
49iterateN :: (Int -> a -> a) -> a -> Int -> a
50iterateN g initial count = f count initial
52 where
54 f (0 :: Int) x = x
55 f i x = f (i - 1) (g i x)
57-- Iterate a transformation over a singleton stream
58{-# INLINE iterateSingleton #-}
59iterateSingleton :: S.MonadAsync m
60 => (Int -> SerialT m Int -> SerialT m Int)
61 -> Int
62 -> Int
63 -> SerialT m Int
64iterateSingleton g count n = iterateN g (return n) count
66-- XXX need to check why this is slower than the explicit recursion above, even
67-- if the above code is written in a foldr like head recursive way. We also
68-- need to try this with foldlM' once #150 is fixed.
69-- However, it is perhaps best to keep the iteration benchmarks independent of
70-- foldrM and any related fusion issues.
71{-# INLINE _iterateSingleton #-}
72_iterateSingleton ::
73 S.MonadAsync m
74 => (Int -> SerialT m Int -> SerialT m Int)
75 -> Int
76 -> Int
77 -> SerialT m Int
78_iterateSingleton g value n = S.foldrM g (return n) $ sourceIntFromTo value n
80-------------------------------------------------------------------------------
81-- Multi-Stream
82-------------------------------------------------------------------------------
84-------------------------------------------------------------------------------
85-- Appending
86-------------------------------------------------------------------------------
88{-# INLINE serial2 #-}
89serial2 :: Int -> Int -> IO ()
90serial2 count n =
91 S.drain $
92 S.serial (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1))
94{-# INLINE serial4 #-}
95serial4 :: Int -> Int -> IO ()
96serial4 count n =
97 S.drain $
98 S.serial
99 (S.serial (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1)))
100 (S.serial
101 (sourceUnfoldrM count (n + 2))
102 (sourceUnfoldrM count (n + 3)))
104{-# INLINE append2 #-}
105append2 :: Int -> Int -> IO ()
106append2 count n =
107 S.drain $
108 Internal.append (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1))
110{-# INLINE append4 #-}
111append4 :: Int -> Int -> IO ()
112append4 count n =
113 S.drain $
114 Internal.append
115 (Internal.append
116 (sourceUnfoldrM count n)
117 (sourceUnfoldrM count (n + 1)))
118 (Internal.append
119 (sourceUnfoldrM count (n + 2))
120 (sourceUnfoldrM count (n + 3)))
122#ifdef INSPECTION
123inspect $ hasNoTypeClasses 'append2
124inspect $ 'append2 `hasNoType` ''SPEC
125inspect $ 'append2 `hasNoType` ''D.AppendState
126#endif
128o_1_space_joining :: Int -> [Benchmark]
129o_1_space_joining value =
130 [ bgroup "joining"
131 [ benchIOSrc1 "serial (2,x/2)" (serial2 (value `div` 2))
132 , benchIOSrc1 "append (2,x/2)" (append2 (value `div` 2))
133 , benchIOSrc1 "serial (2,2,x/4)" (serial4 (value `div` 4))
134 , benchIOSrc1 "append (2,2,x/4)" (append4 (value `div` 4))
135 ]
136 ]
138-------------------------------------------------------------------------------
139-- Concat Foldable containers
140-------------------------------------------------------------------------------
142o_1_space_concatFoldable :: Int -> [Benchmark]
143o_1_space_concatFoldable value =
144 [ bgroup "concat-foldable"
145 [ benchIOSrc fromSerial "foldMapWith (<>) (List)"
146 (sourceFoldMapWith value)
147 , benchIOSrc fromSerial "foldMapWith (<>) (Stream)"
148 (sourceFoldMapWithStream value)
149 , benchIOSrc fromSerial "foldMapWithM (<>) (List)"
150 (sourceFoldMapWithM value)
151 , benchIOSrc fromSerial "S.concatFoldableWith (<>) (List)"
152 (concatFoldableWith value)
153 , benchIOSrc fromSerial "S.concatForFoldableWith (<>) (List)"
154 (concatForFoldableWith value)
155 , benchIOSrc fromSerial "foldMapM (List)" (sourceFoldMapM value)
156 ]
157 ]
159-------------------------------------------------------------------------------
160-- Concat
161-------------------------------------------------------------------------------
163-- concatMap unfoldrM/unfoldrM
165{-# INLINE concatMap #-}
166concatMap :: Int -> Int -> Int -> IO ()
167concatMap outer inner n =
168 S.drain $ S.concatMap
169 (\_ -> sourceUnfoldrM inner n)
170 (sourceUnfoldrM outer n)
172{-# INLINE concatMapM #-}
173concatMapM :: Int -> Int -> Int -> IO ()
174concatMapM outer inner n =
175 S.drain $ S.concatMapM
176 (\_ -> return $ sourceUnfoldrM inner n)
177 (sourceUnfoldrM outer n)
179#ifdef INSPECTION
180inspect $ hasNoTypeClasses 'concatMap
181inspect $ 'concatMap `hasNoType` ''SPEC
182#endif
184-- concatMap unfoldr/unfoldr
186{-# INLINE concatMapPure #-}
187concatMapPure :: Int -> Int -> Int -> IO ()
188concatMapPure outer inner n =
189 S.drain $ S.concatMap
190 (\_ -> sourceUnfoldr inner n)
191 (sourceUnfoldr outer n)
193#ifdef INSPECTION
194inspect $ hasNoTypeClasses 'concatMapPure
195inspect $ 'concatMapPure `hasNoType` ''SPEC
196#endif
198-- concatMap replicate/unfoldrM
200{-# INLINE concatMapRepl #-}
201concatMapRepl :: Int -> Int -> Int -> IO ()
202concatMapRepl outer inner n =
203 S.drain $ S.concatMap (S.replicate inner) (sourceUnfoldrM outer n)
205#ifdef INSPECTION
206inspect $ hasNoTypeClasses 'concatMapRepl
207inspect $ 'concatMapRepl `hasNoType` ''SPEC
208#endif
210-- concatMapWith
212{-# INLINE concatMapWithSerial #-}
213concatMapWithSerial :: Int -> Int -> Int -> IO ()
214concatMapWithSerial = concatStreamsWith S.serial
216#ifdef INSPECTION
217inspect $ hasNoTypeClasses 'concatMapWithSerial
218inspect $ 'concatMapWithSerial `hasNoType` ''SPEC
219#endif
221{-# INLINE concatMapWithAppend #-}
222concatMapWithAppend :: Int -> Int -> Int -> IO ()
223concatMapWithAppend = concatStreamsWith Internal.append
225#ifdef INSPECTION
226inspect $ hasNoTypeClasses 'concatMapWithAppend
227inspect $ 'concatMapWithAppend `hasNoType` ''SPEC
228#endif
230-- concatPairWith
232{-# INLINE concatPairWithSerial #-}
233concatPairWithSerial :: Int -> Int -> Int -> IO ()
234concatPairWithSerial = concatPairsWith Internal.serial
236{-# INLINE concatPairWithAppend #-}
237concatPairWithAppend :: Int -> Int -> Int -> IO ()
238concatPairWithAppend = concatPairsWith Internal.append
240-- unfoldMany
242-- unfoldMany replicate/unfoldrM
244{-# INLINE unfoldManyRepl #-}
245unfoldManyRepl :: Int -> Int -> Int -> IO ()
246unfoldManyRepl outer inner n =
247 S.drain
248 $ S.unfoldMany
249 (UF.lmap return (UF.replicateM inner))
250 (sourceUnfoldrM outer n)
252#ifdef INSPECTION
253inspect $ hasNoTypeClasses 'unfoldManyRepl
254inspect $ 'unfoldManyRepl `hasNoType` ''D.ConcatMapUState
255inspect $ 'unfoldManyRepl `hasNoType` ''SPEC
256#endif
258o_1_space_concat :: Int -> [Benchmark]
259o_1_space_concat value = sqrtVal `seq`
260 [ bgroup "concat"
261 [ benchIOSrc1 "concatMapPure (n of 1)"
262 (concatMapPure value 1)
263 , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)"
264 (concatMapPure sqrtVal sqrtVal)
265 , benchIOSrc1 "concatMapPure (1 of n)"
266 (concatMapPure 1 value)
268 -- This is for comparison with foldMapWith
269 , benchIOSrc fromSerial "concatMapId (n of 1) (fromFoldable)"
270 (S.concatMap id . sourceConcatMapId value)
272 , benchIOSrc1 "concatMap (n of 1)"
273 (concatMap value 1)
274 , benchIOSrc1 "concatMap (sqrt n of sqrt n)"
275 (concatMap sqrtVal sqrtVal)
276 , benchIOSrc1 "concatMap (1 of n)"
277 (concatMap 1 value)
279 , benchIOSrc1 "concatMapM (n of 1)"
280 (concatMapM value 1)
281 , benchIOSrc1 "concatMapM (sqrt n of sqrt n)"
282 (concatMapM sqrtVal sqrtVal)
283 , benchIOSrc1 "concatMapM (1 of n)"
284 (concatMapM 1 value)
286 -- This is for comparison with foldMapWith
287 , benchIOSrc fromSerial "concatMapWithId (n of 1) (fromFoldable)"
288 (S.concatMapWith serial id . sourceConcatMapId value)
290 , benchIOSrc1 "concatMapWith (n of 1)"
291 (concatMapWithSerial value 1)
292 , benchIOSrc1 "concatMapWith (sqrt n of sqrt n)"
293 (concatMapWithSerial sqrtVal sqrtVal)
294 , benchIOSrc1 "concatMapWith (1 of n)"
295 (concatMapWithSerial 1 value)
297 -- quadratic with number of outer streams
298 , benchIOSrc1 "concatMapWithAppend (2 of n/2)"
299 (concatMapWithAppend 2 (value `div` 2))
301 -- concatMap vs unfoldMany
302 , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)"
303 (concatMapRepl sqrtVal sqrtVal)
304 , benchIOSrc1 "unfoldManyRepl (sqrt n of sqrt n)"
305 (unfoldManyRepl sqrtVal sqrtVal)
306 ]
307 ]
309 where
311 sqrtVal = round $ sqrt (fromIntegral value :: Double)
313o_n_space_concat :: Int -> [Benchmark]
314o_n_space_concat value = sqrtVal `seq`
315 [ bgroup "concat"
316 [
317 -------------------concatPairsWith-----------------
319 -- Use large number of streams to check scalability
321 benchIOSrc1 "concatPairWithSerial (n of 1)"
322 (concatPairWithSerial value 1)
323 , benchIOSrc1 "concatPairWithSerial (sqrtVal of sqrtVal)"
324 (concatPairWithSerial sqrtVal sqrtVal)
325 , benchIOSrc1 "concatPairWithSerial (2 of n/2)"
326 (concatPairWithSerial 2 (value `div` 2))
328 , benchIOSrc1 "concatPairWithAppend (n of 1)"
329 (concatPairWithAppend value 1)
330 , benchIOSrc1 "concatPairWithAppend (sqrtVal of sqrtVal)"
331 (concatPairWithAppend sqrtVal sqrtVal)
332 ]
333 ]
335 where
337 sqrtVal = round $ sqrt (fromIntegral value :: Double)
339-------------------------------------------------------------------------------
340-- Applicative
341-------------------------------------------------------------------------------
343o_1_space_applicative :: Int -> [Benchmark]
344o_1_space_applicative value =
345 [ bgroup "Applicative"
346 [ benchIO "(*>) (sqrt n x sqrt n)" $ apDiscardFst value fromSerial
347 , benchIO "(<*) (sqrt n x sqrt n)" $ apDiscardSnd value fromSerial
348 , benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp value fromSerial
349 , benchIO "liftA2 (sqrt n x sqrt n)" $ apLiftA2 value fromSerial
350 ]
351 ]
353o_n_space_applicative :: Int -> [Benchmark]
354o_n_space_applicative value =
355 [ bgroup "Applicative"
356 [ benchIOSrc fromSerial "(*>) (n times)" $
357 iterateSingleton ((*>) . pure) value
358 , benchIOSrc fromSerial "(<*) (n times)" $
359 iterateSingleton (\x xs -> xs <* pure x) value
360 , benchIOSrc fromSerial "(<*>) (n times)" $
361 iterateSingleton (\x xs -> pure (+ x) <*> xs) value
362 , benchIOSrc fromSerial "liftA2 (n times)" $
363 iterateSingleton (AP.liftA2 (+) . pure) value
364 ]
365 ]
367-------------------------------------------------------------------------------
368-- Monad
369-------------------------------------------------------------------------------
371o_1_space_monad :: Int -> [Benchmark]
372o_1_space_monad value =
373 [ bgroup "Monad"
374 [ benchIO "(>>) (sqrt n x sqrt n)" $ monadThen value fromSerial
375 , benchIO "(>>=) (sqrt n x sqrt n)" $ toNullM value fromSerial
376 , benchIO "(>>=) (sqrt n x sqrt n) (filterAllOut)" $
377 filterAllOutM value fromSerial
378 , benchIO "(>>=) (sqrt n x sqrt n) (filterAllIn)" $
379 filterAllInM value fromSerial
380 , benchIO "(>>=) (sqrt n x sqrt n) (filterSome)" $
381 filterSome value fromSerial
382 , benchIO "(>>=) (sqrt n x sqrt n) (breakAfterSome)" $
383 breakAfterSome value fromSerial
384 , benchIO "(>>=) (cubert n x cubert n x cubert n)" $
385 toNullM3 value fromSerial
386 ]
387 ]
389-- This is a good benchmark but inefficient way to compute primes. As we see a
390-- new prime we keep appending a division filter for all the future numbers.
391{-# INLINE sieve #-}
392sieve :: Monad m => SerialT m Int -> SerialT m Int
393sieve s = do
394 r <- lift $ S.uncons s
395 case r of
396 Just (prime, rest) ->
397 prime `S.cons` sieve (S.filter (\n -> n `mod` prime /= 0) rest)
398 Nothing -> S.nil
400o_n_space_monad :: Int -> [Benchmark]
401o_n_space_monad value =
402 [ bgroup "Monad"
403 [ benchIOSrc fromSerial "(>>) (n times)" $
404 iterateSingleton ((>>) . pure) value
405 , benchIOSrc fromSerial "(>>=) (n times)" $
406 iterateSingleton (\x xs -> xs >>= \y -> return (x + y)) value
407 , benchIO "(>>=) (sqrt n x sqrt n) (toList)" $
408 toListM value fromSerial
409 , benchIO "(>>=) (sqrt n x sqrt n) (toListSome)" $
410 toListSome value fromSerial
411 , benchIO "naive prime sieve (n/4)"
412 (\n -> S.sum $ sieve $ S.enumerateFromTo 2 (value `div` 4 + n))
413 ]
414 ]
416-------------------------------------------------------------------------------
417-- Joining
418-------------------------------------------------------------------------------
420toKv :: Int -> (Int, Int)
421toKv p = (p, p)
423{-# INLINE joinWith #-}
424joinWith :: (S.MonadAsync m) =>
425 ((Int -> Int -> Bool) -> SerialT m Int -> SerialT m Int -> SerialT m b)
426 -> Int
427 -> Int
428 -> m ()
429joinWith j val i =
430 S.drain $ j (==) (sourceUnfoldrM val i) (sourceUnfoldrM val (val `div` 2))
432{-# INLINE joinMapWith #-}
433joinMapWith :: (S.MonadAsync m) =>
434 (SerialT m (Int, Int) -> SerialT m (Int, Int) -> SerialT m b)
435 -> Int
436 -> Int
437 -> m ()
438joinMapWith j val i =
439 S.drain
440 $ j
441 (fmap toKv (sourceUnfoldrM val i))
442 (fmap toKv (sourceUnfoldrM val (val `div` 2)))
444o_n_heap_buffering :: Int -> [Benchmark]
445o_n_heap_buffering value =
446 [ bgroup "buffered"
447 [
448 benchIOSrc1 "joinInner (sqrtVal)"
449 $ joinWith Internal.joinInner sqrtVal
450 , benchIOSrc1 "joinInnerMap"
451 $ joinMapWith Internal.joinInnerMap halfVal
452 , benchIOSrc1 "joinLeft (sqrtVal)"
453 $ joinWith Internal.joinLeft sqrtVal
454 , benchIOSrc1 "joinLeftMap "
455 $ joinMapWith Internal.joinLeftMap halfVal
456 , benchIOSrc1 "joinOuter (sqrtVal)"
457 $ joinWith Internal.joinOuter sqrtVal
458 , benchIOSrc1 "joinOuterMap"
459 $ joinMapWith Internal.joinOuterMap halfVal
460 , benchIOSrc1 "intersectBy (sqrtVal)"
461 $ joinWith Internal.intersectBy sqrtVal
462 , benchIOSrc1 "intersectBySorted"
463 $ joinMapWith (Internal.intersectBySorted compare) halfVal
464 ]
465 ]
467 where
469 halfVal = value `div` 2
470 sqrtVal = round $ sqrt (fromIntegral value :: Double)
472-------------------------------------------------------------------------------
473-- Main
474-------------------------------------------------------------------------------
476-- In addition to gauge options, the number of elements in the stream can be
477-- passed using the --stream-size option.
478--
479benchmarks :: String -> Int -> [Benchmark]
480benchmarks moduleName size =
481 [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat
482 [
483 -- multi-stream
484 o_1_space_joining size
485 , o_1_space_concatFoldable size
486 , o_1_space_concat size
488 , o_1_space_applicative size
489 , o_1_space_monad size
491 ]
492 , bgroup (o_n_space_prefix moduleName) $ Prelude.concat
493 [
494 -- multi-stream
495 o_n_space_applicative size
496 , o_n_space_monad size
497 , o_n_space_concat size
498 ]
499 , bgroup (o_n_heap_prefix moduleName) $
500 -- multi-stream
501 o_n_heap_buffering size
502 ]