@@ -1,2075 +1,29 @@
11-- |
2−-- Module : Main
2+-- Module : Serial
33-- Copyright : (c) 2018 Composewell Technologies
4−--
5−-- License : BSD3
4+-- License : BSD-3-Clause
65-- Maintainer : streamly@composewell.com
76
87{-# LANGUAGE CPP #-}
98{-# LANGUAGE FlexibleContexts #-}
109{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE DeriveAnyClass #-}
12−{-# LANGUAGE DeriveGeneric #-}
1310{-# LANGUAGE RankNTypes #-}
14−{-# LANGUAGE TupleSections #-}
15−
16−#ifdef __HADDOCK_VERSION__
17−#undef INSPECTION
18−#endif
19−
20−#ifdef INSPECTION
21−{-# LANGUAGE TemplateHaskell #-}
22−{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
23−#endif
24−
25−module Main where
2611
27−import Control.DeepSeq (NFData(..))
28−import Control.Monad (when)
29−import Control.Monad.IO.Class (MonadIO(..))
30−import Control.Monad.State.Strict (StateT, get, put, MonadState)
31−import qualified Control.Monad.State.Strict as State
32−import Control.Monad.Trans.Class (lift)
33−import Data.Functor.Identity (Identity, runIdentity)
34−import Data.IORef (newIORef, modifyIORef')
35−import GHC.Generics (Generic)
36−import System.Random (randomRIO)
37−import Prelude hiding
38− ( concatMap, mapM_, init, last, elem, notElem, all, any
39− , and, or, length, sum, product, maximum, minimum, reverse, fmap, map
40− , sequence, mapM, tail, repeat, replicate, iterate, (!!), lookup)
12+module Main (main) where
4113
42−import qualified Control.Applicative as AP
43−import qualified Prelude as P
44−import qualified Data.Foldable as F
45−import qualified GHC.Exts as GHC
46−
47−#ifdef INSPECTION
48−import GHC.Types (SPEC(..))
49−import Test.Inspection
50−
51−import qualified Streamly.Internal.Data.Stream.StreamD as D
52−#endif
53−
54−import qualified Streamly.Prelude as S
55−import qualified Streamly.Internal.Data.Stream.IsStream as Internal
56−import qualified Streamly.Internal.Data.Fold as FL
57−import qualified Streamly.Internal.Data.Unfold as UF
14+import qualified Serial.Generation as Generation
15+import qualified Serial.Elimination as Elimination
16+import qualified Serial.Transformation1 as Transformation1
17+import qualified Serial.Transformation2 as Transformation2
18+import qualified Serial.Transformation3 as Transformation3
19+import qualified Serial.Nested as Nested
5820
5921import Gauge
60−import Streamly.Prelude (SerialT, IsStream, serially, serial, MonadAsync)
6122import Streamly.Benchmark.Common
62−import Streamly.Benchmark.Prelude
63−import Streamly.Internal.Data.Time.Units
6423
6524moduleName :: String
6625moduleName = "Prelude.Serial"
6726
68−-------------------------------------------------------------------------------
69−-- Generation
70−-------------------------------------------------------------------------------
71−
72−-------------------------------------------------------------------------------
73−-- fromList
74−-------------------------------------------------------------------------------
75−
76−{-# INLINE sourceIsList #-}
77−sourceIsList :: Int -> Int -> SerialT Identity Int
78−sourceIsList value n = GHC.fromList [n..n+value]
79−
80−{-# INLINE sourceIsString #-}
81−sourceIsString :: Int -> Int -> SerialT Identity P.Char
82−sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a')
83−
84−{-# INLINE readInstance #-}
85−readInstance :: P.String -> SerialT Identity Int
86−readInstance str =
87− let r = P.reads str
88− in case r of
89− [(x,"")] -> x
90− _ -> P.error "readInstance: no parse"
91−
92−-- For comparisons
93−{-# INLINE readInstanceList #-}
94−readInstanceList :: P.String -> [Int]
95−readInstanceList str =
96− let r = P.reads str
97− in case r of
98− [(x,"")] -> x
99− _ -> P.error "readInstance: no parse"
100−
101−{-# INLINE repeat #-}
102−repeat :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
103−repeat count = S.take count . S.repeat
104−
105−{-# INLINE repeatM #-}
106−repeatM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int
107−repeatM count = S.take count . S.repeatM . return
108−
109−{-# INLINE replicate #-}
110−replicate :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
111−replicate count = S.replicate count
112−
113−{-# INLINE replicateM #-}
114−replicateM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int
115−replicateM count = S.replicateM count . return
116−
117−{-# INLINE enumerateFrom #-}
118−enumerateFrom :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
119−enumerateFrom count = S.take count . S.enumerateFrom
120−
121−{-# INLINE enumerateFromTo #-}
122−enumerateFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
123−enumerateFromTo = sourceIntFromTo
124−
125−{-# INLINE enumerateFromThen #-}
126−enumerateFromThen :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
127−enumerateFromThen count inp = S.take count $ S.enumerateFromThen inp (inp + 1)
128−
129−{-# INLINE enumerateFromThenTo #-}
130−enumerateFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
131−enumerateFromThenTo = sourceIntFromThenTo
132−
133−-- n ~ 1
134−{-# INLINE enumerate #-}
135−enumerate :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
136−enumerate count n = S.take (count + n) $ S.enumerate
137−
138−-- n ~ 1
139−{-# INLINE enumerateTo #-}
140−enumerateTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
141−enumerateTo count n = S.enumerateTo (minBound + count + n)
142−
143−{-# INLINE iterate #-}
144−iterate :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
145−iterate count = S.take count . S.iterate (+1)
146−
147−{-# INLINE iterateM #-}
148−iterateM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int
149−iterateM count = S.take count . S.iterateM (return . (+1)) . return
150−
151−{-# INLINE fromIndices #-}
152−fromIndices :: (Monad m, S.IsStream t) => Int -> Int -> t m Int
153−fromIndices value n = S.take value $ S.fromIndices (+ n)
154−
155−{-# INLINE fromIndicesM #-}
156−fromIndicesM :: (MonadAsync m, S.IsStream t) => Int -> Int -> t m Int
157−fromIndicesM value n = S.take value $ S.fromIndicesM (return <$> (+ n))
158−
159−o_1_space_generation :: Int -> [Benchmark]
160−o_1_space_generation value =
161− [ bgroup "generation"
162− [ benchIOSrc serially "unfoldr" (sourceUnfoldr value)
163− , benchIOSrc serially "unfoldrM" (sourceUnfoldrM value)
164− , benchIOSrc serially "repeat" (repeat value)
165− , benchIOSrc serially "repeatM" (repeatM value)
166− , benchIOSrc serially "replicate" (replicate value)
167− , benchIOSrc serially "replicateM" (replicateM value)
168− , benchIOSrc serially "iterate" (iterate value)
169− , benchIOSrc serially "iterateM" (iterateM value)
170− , benchIOSrc serially "fromIndices" (fromIndices value)
171− , benchIOSrc serially "fromIndicesM" (fromIndicesM value)
172− , benchIOSrc serially "intFromTo" (sourceIntFromTo value)
173− , benchIOSrc serially "intFromThenTo" (sourceIntFromThenTo value)
174− , benchIOSrc serially "integerFromStep" (sourceIntegerFromStep value)
175− , benchIOSrc serially "fracFromThenTo" (sourceFracFromThenTo value)
176− , benchIOSrc serially "fracFromTo" (sourceFracFromTo value)
177− , benchIOSrc serially "fromList" (sourceFromList value)
178− , benchPureSrc "IsList.fromList" (sourceIsList value)
179− , benchPureSrc "IsString.fromString" (sourceIsString value)
180− , benchIOSrc serially "fromListM" (sourceFromListM value)
181− , benchIOSrc serially "enumerateFrom" (enumerateFrom value)
182− , benchIOSrc serially "enumerateFromThen" (enumerateFromThen value)
183− , benchIOSrc serially "enumerate" (enumerate value)
184− , benchIOSrc serially "enumerateTo" (enumerateTo value)
185−
186− -- These essentially test cons and consM
187− , benchIOSrc serially "fromFoldable" (sourceFromFoldable value)
188− , benchIOSrc serially "fromFoldableM" (sourceFromFoldableM value)
189−
190− , benchIOSrc serially "absTimes" $ absTimes value
191− ]
192− ]
193−
194−o_n_heap_generation :: Int -> [Benchmark]
195−o_n_heap_generation value =
196− [ bgroup "buffered"
197− -- Buffers the output of show/read.
198− -- XXX can the outputs be streaming? Can we have special read/show
199− -- style type classes, readM/showM supporting streaming effects?
200− [ bench "readsPrec pure streams" $
201− nf readInstance (mkString value)
202− , bench "readsPrec Haskell lists" $
203− nf readInstanceList (mkListString value)
204− ]
205− ]
206−
207−-------------------------------------------------------------------------------
208−-- Elimination
209−-------------------------------------------------------------------------------
210−
211−-------------------------------------------------------------------------------
212−-- Foldable Instance
213−-------------------------------------------------------------------------------
214−
215−{-# INLINE foldableFoldl' #-}
216−foldableFoldl' :: Int -> Int -> Int
217−foldableFoldl' value n =
218− F.foldl' (+) 0 (sourceUnfoldr value n :: S.SerialT Identity Int)
219−
220−{-# INLINE foldableFoldrElem #-}
221−foldableFoldrElem :: Int -> Int -> Bool
222−foldableFoldrElem value n =
223− F.foldr (\x xs -> x == value || xs)
224− P.False
225− (sourceUnfoldr value n :: S.SerialT Identity Int)
226−
227−{-# INLINE foldableSum #-}
228−foldableSum :: Int -> Int -> Int
229−foldableSum value n =
230− P.sum (sourceUnfoldr value n :: S.SerialT Identity Int)
231−
232−{-# INLINE foldableProduct #-}
233−foldableProduct :: Int -> Int -> Int
234−foldableProduct value n =
235− P.product (sourceUnfoldr value n :: S.SerialT Identity Int)
236−
237−{-# INLINE _foldableNull #-}
238−_foldableNull :: Int -> Int -> Bool
239−_foldableNull value n =
240− P.null (sourceUnfoldr value n :: S.SerialT Identity Int)
241−
242−{-# INLINE foldableElem #-}
243−foldableElem :: Int -> Int -> Bool
244−foldableElem value n =
245− value `P.elem` (sourceUnfoldr value n :: S.SerialT Identity Int)
246−
247−{-# INLINE foldableNotElem #-}
248−foldableNotElem :: Int -> Int -> Bool
249−foldableNotElem value n =
250− value `P.notElem` (sourceUnfoldr value n :: S.SerialT Identity Int)
251−
252−{-# INLINE foldableFind #-}
253−foldableFind :: Int -> Int -> Maybe Int
254−foldableFind value n =
255− F.find (== (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)
256−
257−{-# INLINE foldableAll #-}
258−foldableAll :: Int -> Int -> Bool
259−foldableAll value n =
260− P.all (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)
261−
262−{-# INLINE foldableAny #-}
263−foldableAny :: Int -> Int -> Bool
264−foldableAny value n =
265− P.any (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)
266−
267−{-# INLINE foldableAnd #-}
268−foldableAnd :: Int -> Int -> Bool
269−foldableAnd value n =
270− P.and $ S.map
271− (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)
272−
273−{-# INLINE foldableOr #-}
274−foldableOr :: Int -> Int -> Bool
275−foldableOr value n =
276− P.or $ S.map
277− (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int)
278−
279−{-# INLINE foldableLength #-}
280−foldableLength :: Int -> Int -> Int
281−foldableLength value n =
282− P.length (sourceUnfoldr value n :: S.SerialT Identity Int)
283−
284−{-# INLINE foldableMin #-}
285−foldableMin :: Int -> Int -> Int
286−foldableMin value n =
287− P.minimum (sourceUnfoldr value n :: S.SerialT Identity Int)
288−
289−{-# INLINE ordInstanceMin #-}
290−ordInstanceMin :: SerialT Identity Int -> SerialT Identity Int
291−ordInstanceMin src = P.min src src
292−
293−{-# INLINE foldableMax #-}
294−foldableMax :: Int -> Int -> Int
295−foldableMax value n =
296− P.maximum (sourceUnfoldr value n :: S.SerialT Identity Int)
297−
298−{-# INLINE foldableMinBy #-}
299−foldableMinBy :: Int -> Int -> Int
300−foldableMinBy value n =
301− F.minimumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)
302−
303−{-# INLINE foldableListMinBy #-}
304−foldableListMinBy :: Int -> Int -> Int
305−foldableListMinBy value n = F.minimumBy compare [1..value+n]
306−
307−{-# INLINE foldableMaxBy #-}
308−foldableMaxBy :: Int -> Int -> Int
309−foldableMaxBy value n =
310− F.maximumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int)
311−
312−{-# INLINE foldableToList #-}
313−foldableToList :: Int -> Int -> [Int]
314−foldableToList value n =
315− F.toList (sourceUnfoldr value n :: S.SerialT Identity Int)
316−
317−{-# INLINE foldableMapM_ #-}
318−foldableMapM_ :: Monad m => Int -> Int -> m ()
319−foldableMapM_ value n =
320− F.mapM_ (\_ -> return ()) (sourceUnfoldr value n :: S.SerialT Identity Int)
321−
322−{-# INLINE foldableSequence_ #-}
323−foldableSequence_ :: Int -> Int -> IO ()
324−foldableSequence_ value n =
325− F.sequence_ (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))
326−
327−{-# INLINE _foldableMsum #-}
328−_foldableMsum :: Int -> Int -> IO Int
329−_foldableMsum value n =
330− F.msum (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int))
331−
332−{-# INLINE showInstance #-}
333−showInstance :: SerialT Identity Int -> P.String
334−showInstance = P.show
335−
336−o_1_space_elimination_foldable :: Int -> [Benchmark]
337−o_1_space_elimination_foldable value =
338− [ bgroup "foldable"
339− -- Foldable instance
340− [ bench "foldl'" $ nf (foldableFoldl' value) 1
341− , bench "foldrElem" $ nf (foldableFoldrElem value) 1
342− -- , bench "null" $ nf (_foldableNull value) 1
343− , bench "elem" $ nf (foldableElem value) 1
344− , bench "length" $ nf (foldableLength value) 1
345− , bench "sum" $ nf (foldableSum value) 1
346− , bench "product" $ nf (foldableProduct value) 1
347− , bench "minimum" $ nf (foldableMin value) 1
348− , benchPureSink value "min (ord)" ordInstanceMin
349− , bench "maximum" $ nf (foldableMax value) 1
350− , bench "length . toList" $ nf (P.length . foldableToList value) 1
351− , bench "notElem" $ nf (foldableNotElem value) 1
352− , bench "find" $ nf (foldableFind value) 1
353− , bench "all" $ nf (foldableAll value) 1
354− , bench "any" $ nf (foldableAny value) 1
355− , bench "and" $ nf (foldableAnd value) 1
356− , bench "or" $ nf (foldableOr value) 1
357−
358− -- Applicative and Traversable operations
359− -- TBD: traverse_
360− , benchIOSink1 "mapM_" (foldableMapM_ value)
361− -- TBD: for_
362− -- TBD: forM_
363− , benchIOSink1 "sequence_" (foldableSequence_ value)
364− -- TBD: sequenceA_
365− -- TBD: asum
366− -- XXX needs to be fixed, results are in ns
367− -- , benchIOSink1 "msum" (foldableMsum value)
368− ]
369− ]
370−
371−o_n_space_elimination_foldable :: Int -> [Benchmark]
372−o_n_space_elimination_foldable value =
373− -- Head recursive strict right folds.
374− [ bgroup "foldl"
375− -- XXX the definitions of minimumBy and maximumBy in Data.Foldable use
376− -- foldl1 which does not work in constant memory for our
377− -- implementation. It works in constant memory for lists but even for
378− -- lists it takes 15x more time compared to our foldl' based
379− -- implementation.
380− [ bench "minimumBy" $ nf (`foldableMinBy` 1) value
381− , bench "maximumBy" $ nf (`foldableMaxBy` 1) value
382− , bench "minimumByList" $ nf (`foldableListMinBy` 1) value
383− ]
384− ]
385−
386−-------------------------------------------------------------------------------
387−-- Stream folds
388−-------------------------------------------------------------------------------
389−
390−{-# INLINE benchPureSink #-}
391−benchPureSink :: NFData b
392− => Int -> String -> (SerialT Identity Int -> b) -> Benchmark
393−benchPureSink value name = benchPure name (sourceUnfoldr value)
394−
395−{-# INLINE benchHoistSink #-}
396−benchHoistSink
397− :: (IsStream t, NFData b)
398− => Int -> String -> (t Identity Int -> IO b) -> Benchmark
399−benchHoistSink value name f =
400− bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldr value
401−
402−-- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but
403−-- we can't use it as it requires MonadAsync constraint.
404−{-# INLINE benchIdentitySink #-}
405−benchIdentitySink
406− :: (IsStream t, NFData b)
407− => Int -> String -> (t Identity Int -> Identity b) -> Benchmark
408−benchIdentitySink value name f = bench name $ nf (f . sourceUnfoldr value) 1
409−
410−-------------------------------------------------------------------------------
411−-- Reductions
412−-------------------------------------------------------------------------------
413−
414−{-# INLINE uncons #-}
415−uncons :: Monad m => SerialT m Int -> m ()
416−uncons s = do
417− r <- S.uncons s
418− case r of
419− Nothing -> return ()
420− Just (_, t) -> uncons t
421−
422−{-# INLINE init #-}
423−init :: Monad m => SerialT m a -> m ()
424−init s = S.init s >>= P.mapM_ S.drain
425−
426−{-# INLINE mapM_ #-}
427−mapM_ :: Monad m => SerialT m Int -> m ()
428−mapM_ = S.mapM_ (\_ -> return ())
429−
430−{-# INLINE foldrMElem #-}
431−foldrMElem :: Monad m => Int -> SerialT m Int -> m Bool
432−foldrMElem e =
433− S.foldrM
434− (\x xs ->
435− if x == e
436− then return P.True
437− else xs)
438− (return P.False)
439−
440−{-# INLINE foldrToStream #-}
441−foldrToStream :: Monad m => SerialT m Int -> m (SerialT Identity Int)
442−foldrToStream = S.foldr S.cons S.nil
443−
444−{-# INLINE foldrMBuild #-}
445−foldrMBuild :: Monad m => SerialT m Int -> m [Int]
446−foldrMBuild = S.foldrM (\x xs -> (x :) <$> xs) (return [])
447−
448−{-# INLINE foldl'Reduce #-}
449−foldl'Reduce :: Monad m => SerialT m Int -> m Int
450−foldl'Reduce = S.foldl' (+) 0
451−
452−{-# INLINE foldl1'Reduce #-}
453−foldl1'Reduce :: Monad m => SerialT m Int -> m (Maybe Int)
454−foldl1'Reduce = S.foldl1' (+)
455−
456−{-# INLINE foldlM'Reduce #-}
457−foldlM'Reduce :: Monad m => SerialT m Int -> m Int
458−foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) (return 0)
459−
460−{-# INLINE last #-}
461−last :: Monad m => SerialT m Int -> m (Maybe Int)
462−last = S.last
463−
464−{-# INLINE _head #-}
465−_head :: Monad m => SerialT m Int -> m (Maybe Int)
466−_head = S.head
467−
468−{-# INLINE elem #-}
469−elem :: Monad m => Int -> SerialT m Int -> m Bool
470−elem value = S.elem (value + 1)
471−
472−{-# INLINE notElem #-}
473−notElem :: Monad m => Int -> SerialT m Int -> m Bool
474−notElem value = S.notElem (value + 1)
475−
476−{-# INLINE length #-}
477−length :: Monad m => SerialT m Int -> m Int
478−length = S.length
479−
480−{-# INLINE all #-}
481−all :: Monad m => Int -> SerialT m Int -> m Bool
482−all value = S.all (<= (value + 1))
483−
484−{-# INLINE any #-}
485−any :: Monad m => Int -> SerialT m Int -> m Bool
486−any value = S.any (> (value + 1))
487−
488−{-# INLINE and #-}
489−and :: Monad m => Int -> SerialT m Int -> m Bool
490−and value = S.and . S.map (<= (value + 1))
491−
492−{-# INLINE or #-}
493−or :: Monad m => Int -> SerialT m Int -> m Bool
494−or value = S.or . S.map (> (value + 1))
495−
496−{-# INLINE find #-}
497−find :: Monad m => Int -> SerialT m Int -> m (Maybe Int)
498−find value = S.find (== (value + 1))
499−
500−{-# INLINE findM #-}
501−findM :: Monad m => Int -> SerialT m Int -> m (Maybe Int)
502−findM value = S.findM (\z -> return $ z == (value + 1))
503−
504−{-# INLINE findIndex #-}
505−findIndex :: Monad m => Int -> SerialT m Int -> m (Maybe Int)
506−findIndex value = S.findIndex (== (value + 1))
507−
508−{-# INLINE elemIndex #-}
509−elemIndex :: Monad m => Int -> SerialT m Int -> m (Maybe Int)
510−elemIndex value = S.elemIndex (value + 1)
511−
512−{-# INLINE maximum #-}
513−maximum :: Monad m => SerialT m Int -> m (Maybe Int)
514−maximum = S.maximum
515−
516−{-# INLINE minimum #-}
517−minimum :: Monad m => SerialT m Int -> m (Maybe Int)
518−minimum = S.minimum
519−
520−{-# INLINE sum #-}
521−sum :: Monad m => SerialT m Int -> m Int
522−sum = S.sum
523−
524−{-# INLINE product #-}
525−product :: Monad m => SerialT m Int -> m Int
526−product = S.product
527−
528−{-# INLINE minimumBy #-}
529−minimumBy :: Monad m => SerialT m Int -> m (Maybe Int)
530−minimumBy = S.minimumBy compare
531−
532−{-# INLINE maximumBy #-}
533−maximumBy :: Monad m => SerialT m Int -> m (Maybe Int)
534−maximumBy = S.maximumBy compare
535−
536−{-# INLINE the #-}
537−the :: Monad m => SerialT m Int -> m (Maybe Int)
538−the = S.the
539−
540−{-# INLINE drainN #-}
541−drainN :: Monad m => Int -> SerialT m Int -> m ()
542−drainN val = S.drainN val
543−
544−{-# INLINE drainWhile #-}
545−drainWhile :: Monad m => SerialT m Int -> m ()
546−drainWhile = S.drainWhile (const True)
547−
548−{-# INLINE (!!) #-}
549−(!!) :: Monad m => Int -> SerialT m Int -> m (Maybe Int)
550−(!!) val = flip (Internal.!!) val
551−
552−{-# INLINE lookup #-}
553−lookup :: Monad m => Int -> SerialT m Int -> m (Maybe Int)
554−lookup val = S.lookup val . S.map (\x -> (x, x))
555−
556−o_1_space_elimination_folds :: Int -> [Benchmark]
557−o_1_space_elimination_folds value =
558− [ bgroup "elimination"
559− -- Basic folds
560− [ bgroup "reduce"
561− [ bgroup
562− "IO"
563− [ benchIOSink value "foldl'" foldl'Reduce
564− , benchIOSink value "foldl1'" foldl1'Reduce
565− , benchIOSink value "foldlM'" foldlM'Reduce
566− ]
567− , bgroup
568− "Identity"
569− [ benchIdentitySink value "foldl'" foldl'Reduce
570− , benchIdentitySink value "foldl1'" foldl1'Reduce
571− , benchIdentitySink value "foldlM'" foldlM'Reduce
572− ]
573− ]
574− , bgroup "build"
575− [ bgroup "IO"
576− [ benchIOSink value "foldrMElem" (foldrMElem value)
577− ]
578− , bgroup "Identity"
579− [ benchIdentitySink value "foldrMElem" (foldrMElem value)
580− , benchIdentitySink value "foldrToStreamLength"
581− (S.length . runIdentity . foldrToStream)
582− , benchPureSink value "foldrMToListLength"
583− (P.length . runIdentity . foldrMBuild)
584− ]
585− ]
586−
587− -- deconstruction
588− , benchIOSink value "uncons" uncons
589− , benchIOSink value "init" init
590−
591− -- draining
592− , benchIOSink value "drain" $ toNull serially
593− , benchIOSink value "drainN" $ drainN value
594− , benchIOSink value "drainWhile" $ drainWhile
595− , benchPureSink value "drain (pure)" P.id
596− , benchIOSink value "mapM_" mapM_
597−
598− -- this is too fast, causes all benchmarks reported in ns
599− -- , benchIOSink value "head" head
600− , benchIOSink value "last" last
601− , benchIOSink value "length" length
602− , benchHoistSink value "length . generally"
603− (length . Internal.generally)
604− , benchIOSink value "sum" sum
605− , benchIOSink value "product" product
606− , benchIOSink value "maximumBy" maximumBy
607− , benchIOSink value "maximum" maximum
608− , benchIOSink value "minimumBy" minimumBy
609− , benchIOSink value "minimum" minimum
610−
611− , bench "the" $ nfIO $ randomRIO (1,1) >>= the . repeat value
612− , benchIOSink value "find" (find value)
613− , benchIOSink value "findM" (findM value)
614− -- , benchIOSink value "lookupFirst" (lookup 1)
615− , benchIOSink value "lookupNever" (lookup (value + 1))
616− , benchIOSink value "(!!)" ((!!) value)
617− , benchIOSink value "findIndex" (findIndex value)
618− , benchIOSink value "elemIndex" (elemIndex value)
619− -- this is too fast, causes all benchmarks reported in ns
620− -- , benchIOSink value "null" S.null
621− , benchIOSink value "elem" (elem value)
622− , benchIOSink value "notElem" (notElem value)
623− , benchIOSink value "all" (all value)
624− , benchIOSink value "any" (any value)
625− , benchIOSink value "and" (and value)
626− , benchIOSink value "or" (or value)
627−
628− , benchPureSink value "showsPrec pure streams" showInstance
629− -- length is used to check for foldr/build fusion
630− , benchPureSink value "length . IsList.toList" (P.length . GHC.toList)
631− ]
632− ]
633−
634−-------------------------------------------------------------------------------
635−-- Buffered Transformations by fold
636−-------------------------------------------------------------------------------
637−
638−{-# INLINE foldl'Build #-}
639−foldl'Build :: Monad m => SerialT m Int -> m [Int]
640−foldl'Build = S.foldl' (flip (:)) []
641−
642−{-# INLINE foldlM'Build #-}
643−foldlM'Build :: Monad m => SerialT m Int -> m [Int]
644−foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) (return [])
645−
646−o_n_heap_elimination_foldl :: Int -> [Benchmark]
647−o_n_heap_elimination_foldl value =
648− [ bgroup "foldl"
649− -- Left folds for building a structure are inherently non-streaming
650− -- as the structure cannot be lazily consumed until fully built.
651− [ benchIOSink value "foldl'/build/IO" foldl'Build
652− , benchIdentitySink value "foldl'/build/Identity" foldl'Build
653− , benchIOSink value "foldlM'/build/IO" foldlM'Build
654− , benchIdentitySink value "foldlM'/build/Identity" foldlM'Build
655− ]
656− ]
657−
658−-- For comparisons
659−{-# INLINE showInstanceList #-}
660−showInstanceList :: [Int] -> P.String
661−showInstanceList = P.show
662−
663−o_n_heap_elimination_buffered :: Int -> [Benchmark]
664−o_n_heap_elimination_buffered value =
665− [ bgroup "buffered"
666− -- Buffers the output of show/read.
667− -- XXX can the outputs be streaming? Can we have special read/show
668− -- style type classes, readM/showM supporting streaming effects?
669− [ bench "showPrec Haskell lists" $ nf showInstanceList (mkList value)
670− ]
671− ]
672−
673−{-# INLINE foldrMReduce #-}
674−foldrMReduce :: Monad m => SerialT m Int -> m Int
675−foldrMReduce = S.foldrM (\x xs -> (x +) <$> xs) (return 0)
676−
677−o_n_space_elimination_foldr :: Int -> [Benchmark]
678−o_n_space_elimination_foldr value =
679− -- Head recursive strict right folds.
680− [ bgroup "foldr"
681− -- accumulation due to strictness of IO monad
682− [ benchIOSink value "foldrM/build/IO (toList)" foldrMBuild
683− -- Right folds for reducing are inherently non-streaming as the
684− -- expression needs to be fully built before it can be reduced.
685− , benchIdentitySink value "foldrM/reduce/Identity (sum)" foldrMReduce
686− , benchIOSink value "foldrM/reduce/IO (sum)" foldrMReduce
687− ]
688− ]
689−
690−o_n_heap_elimination_toList :: Int -> [Benchmark]
691−o_n_heap_elimination_toList value =
692− [ bgroup "toList"
693− -- Converting the stream to a list or pure stream in a strict monad
694− [ benchIOSink value "toListRev" Internal.toListRev
695− , benchIOSink value "toPureRev" Internal.toPureRev
696− ]
697− ]
698−
699−o_n_space_elimination_toList :: Int -> [Benchmark]
700−o_n_space_elimination_toList value =
701− [ bgroup "toList"
702− -- Converting the stream to a list or pure stream in a strict monad
703− [ benchIOSink value "toList" S.toList
704− , benchIOSink value "toPure" Internal.toPure
705− ]
706− ]
707−
708−-------------------------------------------------------------------------------
709−-- Multi-stream folds
710−-------------------------------------------------------------------------------
711−
712−-------------------------------------------------------------------------------
713−-- Multi-stream pure
714−-------------------------------------------------------------------------------
715−
716−{-# INLINE eqBy' #-}
717−eqBy' :: (Monad m, P.Eq a) => SerialT m a -> m P.Bool
718−eqBy' src = S.eqBy (==) src src
719−
720−{-# INLINE eqByPure #-}
721−eqByPure :: Int -> Int -> Identity Bool
722−eqByPure value n = eqBy' (sourceUnfoldr value n)
723−
724−#ifdef INSPECTION
725−inspect $ hasNoTypeClasses 'eqByPure
726−inspect $ 'eqByPure `hasNoType` ''SPEC
727−inspect $ 'eqByPure `hasNoType` ''D.Step
728−#endif
729−
730−{-# INLINE eqInstance #-}
731−eqInstance :: SerialT Identity Int -> Bool
732−eqInstance src = src == src
733−
734−{-# INLINE eqInstanceNotEq #-}
735−eqInstanceNotEq :: SerialT Identity Int -> Bool
736−eqInstanceNotEq src = src P./= src
737−
738−{-# INLINE cmpBy' #-}
739−cmpBy' :: (Monad m, P.Ord a) => SerialT m a -> m P.Ordering
740−cmpBy' src = S.cmpBy P.compare src src
741−
742−{-# INLINE cmpByPure #-}
743−cmpByPure :: Int -> Int -> Identity P.Ordering
744−cmpByPure value n = cmpBy' (sourceUnfoldr value n)
745−
746−#ifdef INSPECTION
747−inspect $ hasNoTypeClasses 'cmpByPure
748−inspect $ 'cmpByPure `hasNoType` ''SPEC
749−inspect $ 'cmpByPure `hasNoType` ''D.Step
750−#endif
751−
752−{-# INLINE ordInstance #-}
753−ordInstance :: SerialT Identity Int -> Bool
754−ordInstance src = src P.< src
755−
756−o_1_space_elimination_multi_stream_pure :: Int -> [Benchmark]
757−o_1_space_elimination_multi_stream_pure value =
758− [ bgroup "multi-stream-pure"
759− [ benchPureSink1 "eqBy" (eqByPure value)
760− , benchPureSink value "==" eqInstance
761− , benchPureSink value "/=" eqInstanceNotEq
762− , benchPureSink1 "cmpBy" (cmpByPure value)
763− , benchPureSink value "<" ordInstance
764− ]
765− ]
766−
767−{-# INLINE isPrefixOf #-}
768−isPrefixOf :: Monad m => SerialT m Int -> m Bool
769−isPrefixOf src = S.isPrefixOf src src
770−
771−{-# INLINE isSubsequenceOf #-}
772−isSubsequenceOf :: Monad m => SerialT m Int -> m Bool
773−isSubsequenceOf src = S.isSubsequenceOf src src
774−
775−{-# INLINE stripPrefix #-}
776−stripPrefix :: Monad m => SerialT m Int -> m ()
777−stripPrefix src = do
778− _ <- S.stripPrefix src src
779− return ()
780−
781−{-# INLINE eqBy #-}
782−eqBy :: Int -> Int -> IO Bool
783−eqBy value n = eqBy' (sourceUnfoldrM value n)
784−
785−#ifdef INSPECTION
786−inspect $ hasNoTypeClasses 'eqBy
787−inspect $ 'eqBy `hasNoType` ''SPEC
788−inspect $ 'eqBy `hasNoType` ''D.Step
789−#endif
790−
791−{-# INLINE cmpBy #-}
792−cmpBy :: Int -> Int -> IO P.Ordering
793−cmpBy value n = cmpBy' (sourceUnfoldrM value n)
794−
795−#ifdef INSPECTION
796−inspect $ hasNoTypeClasses 'cmpBy
797−inspect $ 'cmpBy `hasNoType` ''SPEC
798−inspect $ 'cmpBy `hasNoType` ''D.Step
799−#endif
800−
801−o_1_space_elimination_multi_stream :: Int -> [Benchmark]
802−o_1_space_elimination_multi_stream value =
803− [ bgroup "multi-stream"
804− [ benchIOSink1 "eqBy" (eqBy value)
805− , benchIOSink1 "cmpBy" (cmpBy value)
806− , benchIOSink value "isPrefixOf" isPrefixOf
807− , benchIOSink value "isSubsequenceOf" isSubsequenceOf
808− , benchIOSink value "stripPrefix" stripPrefix
809− ]
810− ]
811−
812−-------------------------------------------------------------------------------
813−-- Pipelines (stream-to-stream transformations)
814−-------------------------------------------------------------------------------
815−
816−-------------------------------------------------------------------------------
817−-- one-to-one transformations
818−-------------------------------------------------------------------------------
819−
820−-------------------------------------------------------------------------------
821−-- Traversable Instance
822−-------------------------------------------------------------------------------
823−
824−{-# INLINE traversableTraverse #-}
825−traversableTraverse :: SerialT Identity Int -> IO (SerialT Identity Int)
826−traversableTraverse = P.traverse return
827−
828−{-# INLINE traversableSequenceA #-}
829−traversableSequenceA :: SerialT Identity Int -> IO (SerialT Identity Int)
830−traversableSequenceA = P.sequenceA . P.fmap return
831−
832−{-# INLINE traversableMapM #-}
833−traversableMapM :: SerialT Identity Int -> IO (SerialT Identity Int)
834−traversableMapM = P.mapM return
835−
836−{-# INLINE traversableSequence #-}
837−traversableSequence :: SerialT Identity Int -> IO (SerialT Identity Int)
838−traversableSequence = P.sequence . P.fmap return
839−
840−{-# INLINE benchPureSinkIO #-}
841−benchPureSinkIO
842− :: NFData b
843− => Int -> String -> (SerialT Identity Int -> IO b) -> Benchmark
844−benchPureSinkIO value name f =
845− bench name $ nfIO $ randomRIO (1, 1) >>= f . sourceUnfoldr value
846−
847−o_n_space_traversable :: Int -> [Benchmark]
848−o_n_space_traversable value =
849− -- Buffering operations using heap proportional to number of elements.
850− [ bgroup "traversable"
851− -- Traversable instance
852− [ benchPureSinkIO value "traverse" traversableTraverse
853− , benchPureSinkIO value "sequenceA" traversableSequenceA
854− , benchPureSinkIO value "mapM" traversableMapM
855− , benchPureSinkIO value "sequence" traversableSequence
856− ]
857− ]
858−
859−-------------------------------------------------------------------------------
860−-- maps and scans
861−-------------------------------------------------------------------------------
862−
863−{-# INLINE scanl' #-}
864−scanl' :: MonadIO m => Int -> SerialT m Int -> m ()
865−scanl' n = composeN n $ S.scanl' (+) 0
866−
867−{-# INLINE scanlM' #-}
868−scanlM' :: MonadIO m => Int -> SerialT m Int -> m ()
869−scanlM' n = composeN n $ S.scanlM' (\b a -> return $ b + a) (return 0)
870−
871−{-# INLINE scanl1' #-}
872−scanl1' :: MonadIO m => Int -> SerialT m Int -> m ()
873−scanl1' n = composeN n $ S.scanl1' (+)
874−
875−{-# INLINE scanl1M' #-}
876−scanl1M' :: MonadIO m => Int -> SerialT m Int -> m ()
877−scanl1M' n = composeN n $ S.scanl1M' (\b a -> return $ b + a)
878−
879−{-# INLINE scan #-}
880−scan :: MonadIO m => Int -> SerialT m Int -> m ()
881−scan n = composeN n $ S.scan FL.sum
882−
883−{-# INLINE postscanl' #-}
884−postscanl' :: MonadIO m => Int -> SerialT m Int -> m ()
885−postscanl' n = composeN n $ S.postscanl' (+) 0
886−
887−{-# INLINE postscanlM' #-}
888−postscanlM' :: MonadIO m => Int -> SerialT m Int -> m ()
889−postscanlM' n = composeN n $ S.postscanlM' (\b a -> return $ b + a) (return 0)
890−
891−{-# INLINE postscan #-}
892−postscan :: MonadIO m => Int -> SerialT m Int -> m ()
893−postscan n = composeN n $ S.postscan FL.sum
894−
895−{-# INLINE sequence #-}
896−sequence ::
897− (S.IsStream t, S.MonadAsync m)
898− => (t m Int -> S.SerialT m Int)
899− -> t m (m Int)
900− -> m ()
901−sequence t = S.drain . t . S.sequence
902−
903−{-# INLINE tap #-}
904−tap :: MonadIO m => Int -> SerialT m Int -> m ()
905−tap n = composeN n $ S.tap FL.sum
906−
907−{-# INLINE tapRate #-}
908−tapRate :: Int -> SerialT IO Int -> IO ()
909−tapRate n str = do
910− cref <- newIORef 0
911− composeN n (Internal.tapRate 1 (\c -> modifyIORef' cref (c +))) str
912−
913−{-# INLINE pollCounts #-}
914−pollCounts :: Int -> SerialT IO Int -> IO ()
915−pollCounts n =
916− composeN n (Internal.pollCounts (P.const P.True) f FL.drain)
917−
918− where
919−
920− f = Internal.rollingMap (P.-) . Internal.delayPost 1
921−
922−{-# INLINE timestamped #-}
923−timestamped :: (S.MonadAsync m) => SerialT m Int -> m ()
924−timestamped = S.drain . Internal.timestamped
925−
926−{-# INLINE foldrS #-}
927−foldrS :: MonadIO m => Int -> SerialT m Int -> m ()
928−foldrS n = composeN n $ Internal.foldrS S.cons S.nil
929−
930−{-# INLINE foldrSMap #-}
931−foldrSMap :: MonadIO m => Int -> SerialT m Int -> m ()
932−foldrSMap n = composeN n $ Internal.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil
933−
934−{-# INLINE foldrT #-}
935−foldrT :: MonadIO m => Int -> SerialT m Int -> m ()
936−foldrT n = composeN n $ Internal.foldrT S.cons S.nil
937−
938−{-# INLINE foldrTMap #-}
939−foldrTMap :: MonadIO m => Int -> SerialT m Int -> m ()
940−foldrTMap n = composeN n $ Internal.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil
941−
942−
943−{-# INLINE trace #-}
944−trace :: MonadAsync m => Int -> SerialT m Int -> m ()
945−trace n = composeN n $ Internal.trace return
946−
947−o_1_space_mapping :: Int -> [Benchmark]
948−o_1_space_mapping value =
949− [ bgroup
950− "mapping"
951− [
952− -- Right folds
953− benchIOSink value "foldrS" (foldrS 1)
954− , benchIOSink value "foldrSMap" (foldrSMap 1)
955− , benchIOSink value "foldrT" (foldrT 1)
956− , benchIOSink value "foldrTMap" (foldrTMap 1)
957−
958− -- Mapping
959− , benchIOSink value "map" (mapN serially 1)
960− , bench "sequence" $ nfIO $ randomRIO (1, 1000) >>= \n ->
961− sequence serially (sourceUnfoldrAction value n)
962− , benchIOSink value "mapM" (mapM serially 1)
963− , benchIOSink value "tap" (tap 1)
964− , benchIOSink value "tapRate 1 second" (tapRate 1)
965− , benchIOSink value "pollCounts 1 second" (pollCounts 1)
966− , benchIOSink value "timestamped" timestamped
967−
968− -- Scanning
969− , benchIOSink value "scanl'" (scanl' 1)
970− , benchIOSink value "scanl1'" (scanl1' 1)
971− , benchIOSink value "scanlM'" (scanlM' 1)
972− , benchIOSink value "scanl1M'" (scanl1M' 1)
973− , benchIOSink value "postscanl'" (postscanl' 1)
974− , benchIOSink value "postscanlM'" (postscanlM' 1)
975−
976− , benchIOSink value "scan" (scan 1)
977− , benchIOSink value "postscan" (postscan 1)
978− ]
979− ]
980−
981−o_1_space_mappingX4 :: Int -> [Benchmark]
982−o_1_space_mappingX4 value =
983− [ bgroup "mappingX4"
984− [ benchIOSink value "map" (mapN serially 4)
985− , benchIOSink value "mapM" (mapM serially 4)
986− , benchIOSink value "trace" (trace 4)
987−
988− , benchIOSink value "scanl'" (scanl' 4)
989− , benchIOSink value "scanl1'" (scanl1' 4)
990− , benchIOSink value "scanlM'" (scanlM' 4)
991− , benchIOSink value "scanl1M'" (scanl1M' 4)
992− , benchIOSink value "postscanl'" (postscanl' 4)
993− , benchIOSink value "postscanlM'" (postscanlM' 4)
994−
995− ]
996− ]
997−
998−{-# INLINE sieveScan #-}
999−sieveScan :: Monad m => SerialT m Int -> SerialT m Int
1000−sieveScan =
1001− S.mapMaybe snd
1002− . S.scanlM' (\(primes, _) n -> do
1003− return $
1004− let ps = takeWhile (\p -> p * p <= n) primes
1005− in if P.all (\p -> n `mod` p /= 0) ps
1006− then (primes ++ [n], Just n)
1007− else (primes, Nothing)) (return ([2], Just 2))
1008−
1009−o_n_space_mapping :: Int -> [Benchmark]
1010−o_n_space_mapping value =
1011− [ bgroup "mapping"
1012− [ benchIO "naive prime sieve"
1013− (\n -> S.sum $ sieveScan $ S.enumerateFromTo 2 (value + n))
1014− ]
1015− ]
1016−
1017−-------------------------------------------------------------------------------
1018−-- Iteration/looping utilities
1019−-------------------------------------------------------------------------------
1020−
1021−{-# INLINE iterateN #-}
1022−iterateN :: (Int -> a -> a) -> a -> Int -> a
1023−iterateN g initial count = f count initial
1024−
1025− where
1026−
1027− f (0 :: Int) x = x
1028− f i x = f (i - 1) (g i x)
1029−
1030−-- Iterate a transformation over a singleton stream
1031−{-# INLINE iterateSingleton #-}
1032−iterateSingleton :: S.MonadAsync m
1033− => (Int -> SerialT m Int -> SerialT m Int)
1034− -> Int
1035− -> Int
1036− -> SerialT m Int
1037−iterateSingleton g count n = iterateN g (return n) count
1038−
1039−-- XXX need to check why this is slower than the explicit recursion above, even
1040−-- if the above code is written in a foldr like head recursive way. We also
1041−-- need to try this with foldlM' once #150 is fixed.
1042−-- However, it is perhaps best to keep the iteration benchmarks independent of
1043−-- foldrM and any related fusion issues.
1044−{-# INLINE _iterateSingleton #-}
1045−_iterateSingleton ::
1046− S.MonadAsync m
1047− => (Int -> SerialT m Int -> SerialT m Int)
1048− -> Int
1049− -> Int
1050− -> SerialT m Int
1051−_iterateSingleton g value n = S.foldrM g (return n) $ sourceIntFromTo value n
1052−
1053−-- Apply transformation g count times on a stream of length len
1054−{-# INLINE iterateSource #-}
1055−iterateSource ::
1056− S.MonadAsync m
1057− => (SerialT m Int -> SerialT m Int)
1058− -> Int
1059− -> Int
1060− -> Int
1061− -> SerialT m Int
1062−iterateSource g count len n = f count (sourceUnfoldrM len n)
1063−
1064− where
1065−
1066− f (0 :: Int) stream = stream
1067− f i stream = f (i - 1) (g stream)
1068−
1069−-------------------------------------------------------------------------------
1070−-- Functor
1071−-------------------------------------------------------------------------------
1072−
1073−o_1_space_functor :: Int -> [Benchmark]
1074−o_1_space_functor value =
1075− [ bgroup "Functor"
1076− [ benchIOSink value "fmap" (fmapN serially 1)
1077− , benchIOSink value "fmap x 4" (fmapN serially 4)
1078− ]
1079− ]
1080−
1081−o_n_space_functor :: Int -> [Benchmark]
1082−o_n_space_functor value =
1083− [ bgroup "Functor"
1084− [ benchIO "(+) (n times) (baseline)" $ \i0 ->
1085− iterateN (\i acc -> acc >>= \n -> return $ i + n) (return i0) value
1086− , benchIOSrc serially "(<$) (n times)" $
1087− iterateSingleton (<$) value
1088− , benchIOSrc serially "fmap (n times)" $
1089− iterateSingleton (P.fmap . (+)) value
1090− {-
1091− , benchIOSrc serially "_(<$) (n times)" $
1092− _iterateSingleton (<$) value
1093− , benchIOSrc serially "_fmap (n times)" $
1094− _iterateSingleton (P.fmap . (+)) value
1095− -}
1096− ]
1097− ]
1098−
1099−-------------------------------------------------------------------------------
1100−-- Size reducing transformations (filtering)
1101−-------------------------------------------------------------------------------
1102−
1103−{-# INLINE filterEven #-}
1104−filterEven :: MonadIO m => Int -> SerialT m Int -> m ()
1105−filterEven n = composeN n $ S.filter even
1106−
1107−{-# INLINE filterAllOut #-}
1108−filterAllOut :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1109−filterAllOut value n = composeN n $ S.filter (> (value + 1))
1110−
1111−{-# INLINE filterAllIn #-}
1112−filterAllIn :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1113−filterAllIn value n = composeN n $ S.filter (<= (value + 1))
1114−
1115−{-# INLINE filterMEven #-}
1116−filterMEven :: MonadIO m => Int -> SerialT m Int -> m ()
1117−filterMEven n = composeN n $ S.filterM (return . even)
1118−
1119−{-# INLINE filterMAllOut #-}
1120−filterMAllOut :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1121−filterMAllOut value n = composeN n $ S.filterM (\x -> return $ x > (value + 1))
1122−
1123−{-# INLINE filterMAllIn #-}
1124−filterMAllIn :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1125−filterMAllIn value n = composeN n $ S.filterM (\x -> return $ x <= (value + 1))
1126−
1127−{-# INLINE _takeOne #-}
1128−_takeOne :: MonadIO m => Int -> SerialT m Int -> m ()
1129−_takeOne n = composeN n $ S.take 1
1130−
1131−{-# INLINE takeAll #-}
1132−takeAll :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1133−takeAll value n = composeN n $ S.take (value + 1)
1134−
1135−{-# INLINE takeWhileTrue #-}
1136−takeWhileTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1137−takeWhileTrue value n = composeN n $ S.takeWhile (<= (value + 1))
1138−
1139−{-# INLINE takeWhileMTrue #-}
1140−takeWhileMTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1141−takeWhileMTrue value n = composeN n $ S.takeWhileM (return . (<= (value + 1)))
1142−
1143−{-# INLINE takeByTime #-}
1144−takeByTime :: NanoSecond64 -> Int -> SerialT IO Int -> IO ()
1145−takeByTime i n = composeN n (Internal.takeByTime i)
1146−
1147−#ifdef INSPECTION
1148−-- inspect $ hasNoType 'takeByTime ''SPEC
1149−inspect $ hasNoTypeClasses 'takeByTime
1150−-- inspect $ 'takeByTime `hasNoType` ''D.Step
1151−#endif
1152−
1153−{-# INLINE dropOne #-}
1154−dropOne :: MonadIO m => Int -> SerialT m Int -> m ()
1155−dropOne n = composeN n $ S.drop 1
1156−
1157−{-# INLINE dropAll #-}
1158−dropAll :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1159−dropAll value n = composeN n $ S.drop (value + 1)
1160−
1161−{-# INLINE dropWhileTrue #-}
1162−dropWhileTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1163−dropWhileTrue value n = composeN n $ S.dropWhile (<= (value + 1))
1164−
1165−{-# INLINE dropWhileMTrue #-}
1166−dropWhileMTrue :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1167−dropWhileMTrue value n = composeN n $ S.dropWhileM (return . (<= (value + 1)))
1168−
1169−{-# INLINE dropWhileFalse #-}
1170−dropWhileFalse :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1171−dropWhileFalse value n = composeN n $ S.dropWhile (> (value + 1))
1172−
1173−-- XXX Decide on the time interval
1174−{-# INLINE _intervalsOfSum #-}
1175−_intervalsOfSum :: MonadAsync m => Double -> Int -> SerialT m Int -> m ()
1176−_intervalsOfSum i n = composeN n (S.intervalsOf i FL.sum)
1177−
1178−{-# INLINE dropByTime #-}
1179−dropByTime :: NanoSecond64 -> Int -> SerialT IO Int -> IO ()
1180−dropByTime i n = composeN n (Internal.dropByTime i)
1181−
1182−#ifdef INSPECTION
1183−inspect $ hasNoTypeClasses 'dropByTime
1184−-- inspect $ 'dropByTime `hasNoType` ''D.Step
1185−#endif
1186−
1187−{-# INLINE findIndices #-}
1188−findIndices :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1189−findIndices value n = composeN n $ S.findIndices (== (value + 1))
1190−
1191−{-# INLINE elemIndices #-}
1192−elemIndices :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1193−elemIndices value n = composeN n $ S.elemIndices (value + 1)
1194−
1195−{-# INLINE deleteBy #-}
1196−deleteBy :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1197−deleteBy value n = composeN n $ S.deleteBy (>=) (value + 1)
1198−
1199−-- uniq . uniq == uniq, composeN 2 ~ composeN 1
1200−{-# INLINE uniq #-}
1201−uniq :: MonadIO m => Int -> SerialT m Int -> m ()
1202−uniq n = composeN n S.uniq
1203−
1204−{-# INLINE mapMaybe #-}
1205−mapMaybe :: MonadIO m => Int -> SerialT m Int -> m ()
1206−mapMaybe n =
1207− composeN n $
1208− S.mapMaybe
1209− (\x ->
1210− if P.odd x
1211− then Nothing
1212− else Just x)
1213−
1214−{-# INLINE mapMaybeM #-}
1215−mapMaybeM :: S.MonadAsync m => Int -> SerialT m Int -> m ()
1216−mapMaybeM n =
1217− composeN n $
1218− S.mapMaybeM
1219− (\x ->
1220− if P.odd x
1221− then return Nothing
1222− else return $ Just x)
1223−
1224−o_1_space_filtering :: Int -> [Benchmark]
1225−o_1_space_filtering value =
1226− [ bgroup "filtering"
1227− [ benchIOSink value "filter-even" (filterEven 1)
1228− , benchIOSink value "filter-all-out" (filterAllOut value 1)
1229− , benchIOSink value "filter-all-in" (filterAllIn value 1)
1230−
1231− , benchIOSink value "filterM-even" (filterMEven 1)
1232− , benchIOSink value "filterM-all-out" (filterMAllOut value 1)
1233− , benchIOSink value "filterM-all-in" (filterMAllIn value 1)
1234−
1235− -- Trimming
1236− , benchIOSink value "take-all" (takeAll value 1)
1237− , benchIOSink
1238− value
1239− "takeByTime-all"
1240− (takeByTime (NanoSecond64 maxBound) 1)
1241− , benchIOSink value "takeWhile-true" (takeWhileTrue value 1)
1242− -- , benchIOSink value "takeWhileM-true" (_takeWhileMTrue value 1)
1243− , benchIOSink value "drop-one" (dropOne 1)
1244− , benchIOSink value "drop-all" (dropAll value 1)
1245− , benchIOSink
1246− value
1247− "dropByTime-all"
1248− (dropByTime (NanoSecond64 maxBound) 1)
1249− , benchIOSink value "dropWhile-true" (dropWhileTrue value 1)
1250− -- , benchIOSink value "dropWhileM-true" (_dropWhileMTrue value 1)
1251− , benchIOSink
1252− value
1253− "dropWhile-false"
1254− (dropWhileFalse value 1)
1255− , benchIOSink value "deleteBy" (deleteBy value 1)
1256−
1257− , benchIOSink value "uniq" (uniq 1)
1258−
1259− -- Map and filter
1260− , benchIOSink value "mapMaybe" (mapMaybe 1)
1261− , benchIOSink value "mapMaybeM" (mapMaybeM 1)
1262−
1263− -- Searching (stateful map and filter)
1264− , benchIOSink value "findIndices" (findIndices value 1)
1265− , benchIOSink value "elemIndices" (elemIndices value 1)
1266− ]
1267− ]
1268−
1269−o_1_space_filteringX4 :: Int -> [Benchmark]
1270−o_1_space_filteringX4 value =
1271− [ bgroup "filteringX4"
1272− [ benchIOSink value "filter-even" (filterEven 4)
1273− , benchIOSink value "filter-all-out" (filterAllOut value 4)
1274− , benchIOSink value "filter-all-in" (filterAllIn value 4)
1275−
1276− , benchIOSink value "filterM-even" (filterMEven 4)
1277− , benchIOSink value "filterM-all-out" (filterMAllOut value 4)
1278− , benchIOSink value "filterM-all-in" (filterMAllIn value 4)
1279−
1280− -- trimming
1281− , benchIOSink value "take-all" (takeAll value 4)
1282− , benchIOSink value "takeWhile-true" (takeWhileTrue value 4)
1283− , benchIOSink value "takeWhileM-true" (takeWhileMTrue value 4)
1284− , benchIOSink value "drop-one" (dropOne 4)
1285− , benchIOSink value "drop-all" (dropAll value 4)
1286− , benchIOSink value "dropWhile-true" (dropWhileTrue value 4)
1287− , benchIOSink value "dropWhileM-true" (dropWhileMTrue value 4)
1288− , benchIOSink
1289− value
1290− "dropWhile-false"
1291− (dropWhileFalse value 4)
1292− , benchIOSink value "deleteBy" (deleteBy value 4)
1293−
1294− , benchIOSink value "uniq" (uniq 4)
1295−
1296− -- map and filter
1297− , benchIOSink value "mapMaybe" (mapMaybe 4)
1298− , benchIOSink value "mapMaybeM" (mapMaybeM 4)
1299−
1300− -- searching
1301− , benchIOSink value "findIndices" (findIndices value 4)
1302− , benchIOSink value "elemIndices" (elemIndices value 4)
1303− ]
1304− ]
1305−
1306−-------------------------------------------------------------------------------
1307−-- Grouping transformations
1308−-------------------------------------------------------------------------------
1309−
1310−{-# INLINE groups #-}
1311−groups :: MonadIO m => SerialT m Int -> m ()
1312−groups = S.drain . S.groups FL.drain
1313−
1314−-- XXX Change this test when the order of comparison is later changed
1315−{-# INLINE groupsByGT #-}
1316−groupsByGT :: MonadIO m => SerialT m Int -> m ()
1317−groupsByGT = S.drain . S.groupsBy (>) FL.drain
1318−
1319−{-# INLINE groupsByEq #-}
1320−groupsByEq :: MonadIO m => SerialT m Int -> m ()
1321−groupsByEq = S.drain . S.groupsBy (==) FL.drain
1322−
1323−{-# INLINE groupsByRollingLT #-}
1324−groupsByRollingLT :: MonadIO m => SerialT m Int -> m ()
1325−groupsByRollingLT =
1326− S.drain . S.groupsByRolling (<) FL.drain
1327−
1328−{-# INLINE groupsByRollingEq #-}
1329−groupsByRollingEq :: MonadIO m => SerialT m Int -> m ()
1330−groupsByRollingEq =
1331− S.drain . S.groupsByRolling (==) FL.drain
1332−
1333−o_1_space_grouping :: Int -> [Benchmark]
1334−o_1_space_grouping value =
1335− [ bgroup "grouping"
1336− [ benchIOSink value "groups" groups
1337− , benchIOSink value "groupsByGT" groupsByGT
1338− , benchIOSink value "groupsByEq" groupsByEq
1339− , benchIOSink value "groupsByRollingLT" groupsByRollingLT
1340− , benchIOSink value "groupsByRollingEq" groupsByRollingEq
1341− ]
1342− ]
1343−
1344−-------------------------------------------------------------------------------
1345−-- Size increasing transformations (insertions)
1346−-------------------------------------------------------------------------------
1347−
1348−{-# INLINE intersperse #-}
1349−intersperse :: S.MonadAsync m => Int -> Int -> SerialT m Int -> m ()
1350−intersperse value n = composeN n $ S.intersperse (value + 1)
1351−
1352−{-# INLINE intersperseM #-}
1353−intersperseM :: S.MonadAsync m => Int -> Int -> SerialT m Int -> m ()
1354−intersperseM value n = composeN n $ S.intersperseM (return $ value + 1)
1355−
1356−{-# INLINE insertBy #-}
1357−insertBy :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1358−insertBy value n = composeN n $ S.insertBy compare (value + 1)
1359−
1360−o_1_space_inserting :: Int -> [Benchmark]
1361−o_1_space_inserting value =
1362− [ bgroup "filtering"
1363− [ benchIOSink value "intersperse" (intersperse value 1)
1364− , benchIOSink value "intersperseM" (intersperseM value 1)
1365− , benchIOSink value "insertBy" (insertBy value 1)
1366− ]
1367− ]
1368−
1369−o_1_space_insertingX4 :: Int -> [Benchmark]
1370−o_1_space_insertingX4 value =
1371− [ bgroup "insertingX4"
1372− [ benchIOSink value "intersperse" (intersperse value 4)
1373− , benchIOSink value "insertBy" (insertBy value 4)
1374− ]
1375− ]
1376−
1377−-------------------------------------------------------------------------------
1378−-- Indexing
1379−-------------------------------------------------------------------------------
1380−
1381−{-# INLINE indexed #-}
1382−indexed :: MonadIO m => Int -> SerialT m Int -> m ()
1383−indexed n = composeN n (S.map snd . S.indexed)
1384−
1385−{-# INLINE indexedR #-}
1386−indexedR :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1387−indexedR value n = composeN n (S.map snd . S.indexedR value)
1388−
1389−o_1_space_indexing :: Int -> [Benchmark]
1390−o_1_space_indexing value =
1391− [ bgroup "indexing"
1392− [ benchIOSink value "indexed" (indexed 1)
1393− , benchIOSink value "indexedR" (indexedR value 1)
1394− ]
1395− ]
1396−
1397−o_1_space_indexingX4 :: Int -> [Benchmark]
1398−o_1_space_indexingX4 value =
1399− [ bgroup "indexingx4"
1400− [ benchIOSink value "indexed" (indexed 4)
1401− , benchIOSink value "indexedR" (indexedR value 4)
1402− ]
1403− ]
1404−
1405−-------------------------------------------------------------------------------
1406−-- Size conserving transformations (reordering, buffering, etc.)
1407−-------------------------------------------------------------------------------
1408−
1409−{-# INLINE reverse #-}
1410−reverse :: MonadIO m => Int -> SerialT m Int -> m ()
1411−reverse n = composeN n S.reverse
1412−
1413−{-# INLINE reverse' #-}
1414−reverse' :: MonadIO m => Int -> SerialT m Int -> m ()
1415−reverse' n = composeN n Internal.reverse'
1416−
1417−o_n_heap_buffering :: Int -> [Benchmark]
1418−o_n_heap_buffering value =
1419− [ bgroup "buffered"
1420− [
1421− -- Reversing/sorting a stream
1422− benchIOSink value "reverse" (reverse 1)
1423− , benchIOSink value "reverse'" (reverse' 1)
1424−
1425− , benchIOSink value "mkAsync" (mkAsync serially)
1426− ]
1427− ]
1428−
1429−-------------------------------------------------------------------------------
1430−-- Grouping/Splitting
1431−-------------------------------------------------------------------------------
1432−
1433−{-# INLINE classifySessionsOf #-}
1434−classifySessionsOf :: (S.MonadAsync m) => SerialT m Int -> m ()
1435−classifySessionsOf =
1436− S.drain
1437− . Internal.classifySessionsOf
1438− 3 (const (return False)) (P.fmap Right FL.drain)
1439− . S.map (\(ts,(k,a)) -> (k, a, ts))
1440− . Internal.timestamped
1441− . S.concatMap (\x -> S.map (x,) (S.enumerateFromTo 1 (10 :: Int)))
1442−
1443−o_n_space_grouping :: Int -> [Benchmark]
1444−o_n_space_grouping value =
1445− -- Buffering operations using heap proportional to group/window sizes.
1446− [ bgroup "grouping"
1447− [ benchIOSink (value `div` 10) "classifySessionsOf" classifySessionsOf
1448− ]
1449− ]
1450−
1451−-------------------------------------------------------------------------------
1452−-- Mixed Transformation
1453−-------------------------------------------------------------------------------
1454−
1455−{-# INLINE scanMap #-}
1456−scanMap :: MonadIO m => Int -> SerialT m Int -> m ()
1457−scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0
1458−
1459−{-# INLINE dropMap #-}
1460−dropMap :: MonadIO m => Int -> SerialT m Int -> m ()
1461−dropMap n = composeN n $ S.map (subtract 1) . S.drop 1
1462−
1463−{-# INLINE dropScan #-}
1464−dropScan :: MonadIO m => Int -> SerialT m Int -> m ()
1465−dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1
1466−
1467−{-# INLINE takeDrop #-}
1468−takeDrop :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1469−takeDrop value n = composeN n $ S.drop 1 . S.take (value + 1)
1470−
1471−{-# INLINE takeScan #-}
1472−takeScan :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1473−takeScan value n = composeN n $ S.scanl' (+) 0 . S.take (value + 1)
1474−
1475−{-# INLINE takeMap #-}
1476−takeMap :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1477−takeMap value n = composeN n $ S.map (subtract 1) . S.take (value + 1)
1478−
1479−{-# INLINE filterDrop #-}
1480−filterDrop :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1481−filterDrop value n = composeN n $ S.drop 1 . S.filter (<= (value + 1))
1482−
1483−{-# INLINE filterTake #-}
1484−filterTake :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1485−filterTake value n = composeN n $ S.take (value + 1) . S.filter (<= (value + 1))
1486−
1487−{-# INLINE filterScan #-}
1488−filterScan :: MonadIO m => Int -> SerialT m Int -> m ()
1489−filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)
1490−
1491−{-# INLINE filterScanl1 #-}
1492−filterScanl1 :: MonadIO m => Int -> SerialT m Int -> m ()
1493−filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)
1494−
1495−{-# INLINE filterMap #-}
1496−filterMap :: MonadIO m => Int -> Int -> SerialT m Int -> m ()
1497−filterMap value n = composeN n $ S.map (subtract 1) . S.filter (<= (value + 1))
1498−
1499−-------------------------------------------------------------------------------
1500−-- Scan and fold
1501−-------------------------------------------------------------------------------
1502−
1503−data Pair a b =
1504− Pair !a !b
1505− deriving (Generic, NFData)
1506−
1507−{-# INLINE sumProductFold #-}
1508−sumProductFold :: Monad m => SerialT m Int -> m (Int, Int)
1509−sumProductFold = S.foldl' (\(s, p) x -> (s + x, p P.* x)) (0, 1)
1510−
1511−{-# INLINE sumProductScan #-}
1512−sumProductScan :: Monad m => SerialT m Int -> m (Pair Int Int)
1513−sumProductScan =
1514− S.foldl' (\(Pair _ p) (s0, x) -> Pair s0 (p P.* x)) (Pair 0 1) .
1515− S.scanl' (\(s, _) x -> (s + x, x)) (0, 0)
1516−
1517−{-# INLINE foldl'ReduceMap #-}
1518−foldl'ReduceMap :: Monad m => SerialT m Int -> m Int
1519−foldl'ReduceMap = P.fmap (+ 1) . S.foldl' (+) 0
1520−
1521−o_1_space_transformations_mixed :: Int -> [Benchmark]
1522−o_1_space_transformations_mixed value =
1523− -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl
1524− -- library. If scan/fold followed by a map is efficient enough we may not
1525− -- need monolithic implementations of these.
1526− [ bgroup "mixed"
1527− [ benchIOSink value "scanl-map" (scanMap 1)
1528− , benchIOSink value "foldl-map" foldl'ReduceMap
1529− , benchIOSink value "sum-product-fold" sumProductFold
1530− , benchIOSink value "sum-product-scan" sumProductScan
1531− ]
1532− ]
1533−
1534−o_1_space_transformations_mixedX4 :: Int -> [Benchmark]
1535−o_1_space_transformations_mixedX4 value =
1536− [ bgroup "mixedX4"
1537− [ benchIOSink value "scan-map" (scanMap 4)
1538− , benchIOSink value "drop-map" (dropMap 4)
1539− , benchIOSink value "drop-scan" (dropScan 4)
1540− , benchIOSink value "take-drop" (takeDrop value 4)
1541− , benchIOSink value "take-scan" (takeScan value 4)
1542− , benchIOSink value "take-map" (takeMap value 4)
1543− , benchIOSink value "filter-drop" (filterDrop value 4)
1544− , benchIOSink value "filter-take" (filterTake value 4)
1545− , benchIOSink value "filter-scan" (filterScan 4)
1546− , benchIOSink value "filter-scanl1" (filterScanl1 4)
1547− , benchIOSink value "filter-map" (filterMap value 4)
1548− ]
1549− ]
1550−
1551−-------------------------------------------------------------------------------
1552−-- Iterating a transformation over and over again
1553−-------------------------------------------------------------------------------
1554−
1555−-- this is quadratic
1556−{-# INLINE iterateScan #-}
1557−iterateScan :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1558−iterateScan = iterateSource (S.scanl' (+) 0)
1559−
1560−-- this is quadratic
1561−{-# INLINE iterateScanl1 #-}
1562−iterateScanl1 :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1563−iterateScanl1 = iterateSource (S.scanl1' (+))
1564−
1565−{-# INLINE iterateMapM #-}
1566−iterateMapM :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1567−iterateMapM = iterateSource (S.mapM return)
1568−
1569−{-# INLINE iterateFilterEven #-}
1570−iterateFilterEven :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1571−iterateFilterEven = iterateSource (S.filter even)
1572−
1573−{-# INLINE iterateTakeAll #-}
1574−iterateTakeAll :: S.MonadAsync m => Int -> Int -> Int -> Int -> SerialT m Int
1575−iterateTakeAll value = iterateSource (S.take (value + 1))
1576−
1577−{-# INLINE iterateDropOne #-}
1578−iterateDropOne :: S.MonadAsync m => Int -> Int -> Int -> SerialT m Int
1579−iterateDropOne = iterateSource (S.drop 1)
1580−
1581−{-# INLINE iterateDropWhileFalse #-}
1582−iterateDropWhileFalse :: S.MonadAsync m
1583− => Int -> Int -> Int -> Int -> SerialT m Int
1584−iterateDropWhileFalse value = iterateSource (S.dropWhile (> (value + 1)))
1585−
1586−{-# INLINE iterateDropWhileTrue #-}
1587−iterateDropWhileTrue :: S.MonadAsync m
1588− => Int -> Int -> Int -> Int -> SerialT m Int
1589−iterateDropWhileTrue value = iterateSource (S.dropWhile (<= (value + 1)))
1590−
1591−{-# INLINE tail #-}
1592−tail :: Monad m => SerialT m a -> m ()
1593−tail s = S.tail s >>= P.mapM_ tail
1594−
1595−{-# INLINE nullHeadTail #-}
1596−nullHeadTail :: Monad m => SerialT m Int -> m ()
1597−nullHeadTail s = do
1598− r <- S.null s
1599− when (not r) $ do
1600− _ <- S.head s
1601− S.tail s >>= P.mapM_ nullHeadTail
1602−
1603−-- Head recursive operations.
1604−o_n_stack_iterated :: Int -> [Benchmark]
1605−o_n_stack_iterated value = by10 `seq` by100 `seq`
1606− [ bgroup "iterated"
1607− [ benchIOSrc serially "mapM (n/10 x 10)" $ iterateMapM by10 10
1608− , benchIOSrc serially "scanl' (quadratic) (n/100 x 100)" $
1609− iterateScan by100 100
1610− , benchIOSrc serially "scanl1' (n/10 x 10)" $ iterateScanl1 by10 10
1611− , benchIOSrc serially "filterEven (n/10 x 10)" $
1612− iterateFilterEven by10 10
1613− , benchIOSrc serially "takeAll (n/10 x 10)" $
1614− iterateTakeAll value by10 10
1615− , benchIOSrc serially "dropOne (n/10 x 10)" $ iterateDropOne by10 10
1616− , benchIOSrc serially "dropWhileFalse (n/10 x 10)" $
1617− iterateDropWhileFalse value by10 10
1618− , benchIOSrc serially "dropWhileTrue (n/10 x 10)" $
1619− iterateDropWhileTrue value by10 10
1620− , benchIOSink value "tail" tail
1621− , benchIOSink value "nullHeadTail" nullHeadTail
1622− ]
1623− ]
1624−
1625− where
1626−
1627− by10 = value `div` 10
1628− by100 = value `div` 100
1629−
1630−-------------------------------------------------------------------------------
1631−-- Pipes
1632−-------------------------------------------------------------------------------
1633−
1634−o_1_space_pipes :: Int -> [Benchmark]
1635−o_1_space_pipes value =
1636− [ bgroup "pipes"
1637− [ benchIOSink value "mapM" (transformMapM serially 1)
1638− , benchIOSink value "compose" (transformComposeMapM serially 1)
1639− , benchIOSink value "tee" (transformTeeMapM serially 1)
1640− , benchIOSink value "zip" (transformZipMapM serially 1)
1641− ]
1642− ]
1643−
1644−o_1_space_pipesX4 :: Int -> [Benchmark]
1645−o_1_space_pipesX4 value =
1646− [ bgroup "pipesX4"
1647− [ benchIOSink value "mapM" (transformMapM serially 4)
1648− , benchIOSink value "compose" (transformComposeMapM serially 4)
1649− , benchIOSink value "tee" (transformTeeMapM serially 4)
1650− , benchIOSink value "zip" (transformZipMapM serially 4)
1651− ]
1652− ]
1653−
1654−-------------------------------------------------------------------------------
1655−-- Multi-Stream
1656−-------------------------------------------------------------------------------
1657−
1658−-------------------------------------------------------------------------------
1659−-- Appending
1660−-------------------------------------------------------------------------------
1661−
1662−{-# INLINE serial2 #-}
1663−serial2 :: Int -> Int -> IO ()
1664−serial2 count n =
1665− S.drain $
1666− S.serial (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1))
1667−
1668−{-# INLINE serial4 #-}
1669−serial4 :: Int -> Int -> IO ()
1670−serial4 count n =
1671− S.drain $
1672− S.serial
1673− (S.serial (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1)))
1674− (S.serial
1675− (sourceUnfoldrM count (n + 2))
1676− (sourceUnfoldrM count (n + 3)))
1677−
1678−{-# INLINE append2 #-}
1679−append2 :: Int -> Int -> IO ()
1680−append2 count n =
1681− S.drain $
1682− Internal.append (sourceUnfoldrM count n) (sourceUnfoldrM count (n + 1))
1683−
1684−{-# INLINE append4 #-}
1685−append4 :: Int -> Int -> IO ()
1686−append4 count n =
1687− S.drain $
1688− Internal.append
1689− (Internal.append
1690− (sourceUnfoldrM count n)
1691− (sourceUnfoldrM count (n + 1)))
1692− (Internal.append
1693− (sourceUnfoldrM count (n + 2))
1694− (sourceUnfoldrM count (n + 3)))
1695−
1696−#ifdef INSPECTION
1697−inspect $ hasNoTypeClasses 'append2
1698−inspect $ 'append2 `hasNoType` ''SPEC
1699−inspect $ 'append2 `hasNoType` ''D.AppendState
1700−#endif
1701−
1702−-------------------------------------------------------------------------------
1703−-- Merging
1704−-------------------------------------------------------------------------------
1705−
1706−{-# INLINE mergeBy #-}
1707−mergeBy :: Int -> Int -> IO ()
1708−mergeBy count n =
1709− S.drain $
1710− S.mergeBy
1711− P.compare
1712− (sourceUnfoldrM count n)
1713− (sourceUnfoldrM count (n + 1))
1714−
1715−{-# INLINE mergeByM #-}
1716−mergeByM :: Int -> Int -> IO ()
1717−mergeByM count n =
1718− S.drain $
1719− S.mergeByM
1720− (\a b -> return $ P.compare a b)
1721− (sourceUnfoldrM count n)
1722− (sourceUnfoldrM count (n + 1))
1723−
1724−#ifdef INSPECTION
1725−inspect $ hasNoTypeClasses 'mergeBy
1726−inspect $ 'mergeBy `hasNoType` ''SPEC
1727−inspect $ 'mergeBy `hasNoType` ''D.Step
1728−
1729−inspect $ hasNoTypeClasses 'mergeByM
1730−inspect $ 'mergeByM `hasNoType` ''SPEC
1731−inspect $ 'mergeByM `hasNoType` ''D.Step
1732−#endif
1733−
1734−o_1_space_joining :: Int -> [Benchmark]
1735−o_1_space_joining value =
1736− [ bgroup "joining"
1737− [ benchIOSrc1 "serial (2,x/2)" (serial2 (value `div` 2))
1738− , benchIOSrc1 "append (2,x/2)" (append2 (value `div` 2))
1739− , benchIOSrc1 "serial (2,2,x/4)" (serial4 (value `div` 4))
1740− , benchIOSrc1 "append (2,2,x/4)" (append4 (value `div` 4))
1741− , benchIOSrc1 "mergeBy (2,x/2)" (mergeBy (value `div` 2))
1742− , benchIOSrc1 "mergeByM (2,x/2)" (mergeByM (value `div` 2))
1743− ]
1744− ]
1745−
1746−-------------------------------------------------------------------------------
1747−-- Concat Foldable containers
1748−-------------------------------------------------------------------------------
1749−
1750−o_1_space_concatFoldable :: Int -> [Benchmark]
1751−o_1_space_concatFoldable value =
1752− [ bgroup "concat-foldable"
1753− [ benchIOSrc serially "foldMapWith (<>) (List)"
1754− (sourceFoldMapWith value)
1755− , benchIOSrc serially "foldMapWith (<>) (Stream)"
1756− (sourceFoldMapWithStream value)
1757− , benchIOSrc serially "foldMapWithM (<>) (List)"
1758− (sourceFoldMapWithM value)
1759− , benchIOSrc serially "S.concatFoldableWith (<>) (List)"
1760− (concatFoldableWith value)
1761− , benchIOSrc serially "S.concatForFoldableWith (<>) (List)"
1762− (concatForFoldableWith value)
1763− , benchIOSrc serially "foldMapM (List)" (sourceFoldMapM value)
1764− ]
1765− ]
1766−
1767−-------------------------------------------------------------------------------
1768−-- Concat
1769−-------------------------------------------------------------------------------
1770−
1771−-- concatMap unfoldrM/unfoldrM
1772−
1773−{-# INLINE concatMap #-}
1774−concatMap :: Int -> Int -> Int -> IO ()
1775−concatMap outer inner n =
1776− S.drain $ S.concatMap
1777− (\_ -> sourceUnfoldrM inner n)
1778− (sourceUnfoldrM outer n)
1779−
1780−{-# INLINE concatMapM #-}
1781−concatMapM :: Int -> Int -> Int -> IO ()
1782−concatMapM outer inner n =
1783− S.drain $ S.concatMapM
1784− (\_ -> return $ sourceUnfoldrM inner n)
1785− (sourceUnfoldrM outer n)
1786−
1787−#ifdef INSPECTION
1788−inspect $ hasNoTypeClasses 'concatMap
1789−inspect $ 'concatMap `hasNoType` ''SPEC
1790−#endif
1791−
1792−-- concatMap unfoldr/unfoldr
1793−
1794−{-# INLINE concatMapPure #-}
1795−concatMapPure :: Int -> Int -> Int -> IO ()
1796−concatMapPure outer inner n =
1797− S.drain $ S.concatMap
1798− (\_ -> sourceUnfoldr inner n)
1799− (sourceUnfoldr outer n)
1800−
1801−#ifdef INSPECTION
1802−inspect $ hasNoTypeClasses 'concatMapPure
1803−inspect $ 'concatMapPure `hasNoType` ''SPEC
1804−#endif
1805−
1806−-- concatMap replicate/unfoldrM
1807−
1808−{-# INLINE concatMapRepl #-}
1809−concatMapRepl :: Int -> Int -> Int -> IO ()
1810−concatMapRepl outer inner n =
1811− S.drain $ S.concatMap (S.replicate inner) (sourceUnfoldrM outer n)
1812−
1813−#ifdef INSPECTION
1814−inspect $ hasNoTypeClasses 'concatMapRepl
1815−inspect $ 'concatMapRepl `hasNoType` ''SPEC
1816−#endif
1817−
1818−-- concatMapWith
1819−
1820−{-# INLINE concatMapWithSerial #-}
1821−concatMapWithSerial :: Int -> Int -> Int -> IO ()
1822−concatMapWithSerial = concatStreamsWith S.serial
1823−
1824−#ifdef INSPECTION
1825−inspect $ hasNoTypeClasses 'concatMapWithSerial
1826−inspect $ 'concatMapWithSerial `hasNoType` ''SPEC
1827−#endif
1828−
1829−{-# INLINE concatMapWithAppend #-}
1830−concatMapWithAppend :: Int -> Int -> Int -> IO ()
1831−concatMapWithAppend = concatStreamsWith Internal.append
1832−
1833−#ifdef INSPECTION
1834−inspect $ hasNoTypeClasses 'concatMapWithAppend
1835−inspect $ 'concatMapWithAppend `hasNoType` ''SPEC
1836−#endif
1837−
1838−-- concatUnfold
1839−
1840−-- concatUnfold replicate/unfoldrM
1841−
1842−{-# INLINE concatUnfoldRepl #-}
1843−concatUnfoldRepl :: Int -> Int -> Int -> IO ()
1844−concatUnfoldRepl outer inner n =
1845− S.drain
1846− $ S.concatUnfold
1847− (UF.lmap return (UF.replicateM inner))
1848− (sourceUnfoldrM outer n)
1849−
1850−#ifdef INSPECTION
1851−inspect $ hasNoTypeClasses 'concatUnfoldRepl
1852−inspect $ 'concatUnfoldRepl `hasNoType` ''D.ConcatMapUState
1853−inspect $ 'concatUnfoldRepl `hasNoType` ''SPEC
1854−#endif
1855−
1856−o_1_space_concat :: Int -> [Benchmark]
1857−o_1_space_concat value = sqrtVal `seq`
1858− [ bgroup "concat"
1859− [ benchIOSrc1 "concatMapPure (n of 1)"
1860− (concatMapPure value 1)
1861− , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)"
1862− (concatMapPure sqrtVal sqrtVal)
1863− , benchIOSrc1 "concatMapPure (1 of n)"
1864− (concatMapPure 1 value)
1865−
1866− -- This is for comparison with foldMapWith
1867− , benchIOSrc serially "concatMapId (n of 1) (fromFoldable)"
1868− (S.concatMap id . sourceConcatMapId value)
1869−
1870− , benchIOSrc1 "concatMap (n of 1)"
1871− (concatMap value 1)
1872− , benchIOSrc1 "concatMap (sqrt n of sqrt n)"
1873− (concatMap sqrtVal sqrtVal)
1874− , benchIOSrc1 "concatMap (1 of n)"
1875− (concatMap 1 value)
1876−
1877− , benchIOSrc1 "concatMapM (n of 1)"
1878− (concatMapM value 1)
1879− , benchIOSrc1 "concatMapM (sqrt n of sqrt n)"
1880− (concatMapM sqrtVal sqrtVal)
1881− , benchIOSrc1 "concatMapM (1 of n)"
1882− (concatMapM 1 value)
1883−
1884− -- This is for comparison with foldMapWith
1885− , benchIOSrc serially "concatMapWithId (n of 1) (fromFoldable)"
1886− (S.concatMapWith serial id . sourceConcatMapId value)
1887−
1888− , benchIOSrc1 "concatMapWith (n of 1)"
1889− (concatMapWithSerial value 1)
1890− , benchIOSrc1 "concatMapWith (sqrt n of sqrt n)"
1891− (concatMapWithSerial sqrtVal sqrtVal)
1892− , benchIOSrc1 "concatMapWith (1 of n)"
1893− (concatMapWithSerial 1 value)
1894−
1895− -- quadratic with number of outer streams
1896− , benchIOSrc1 "concatMapWithAppend (2 of n/2)"
1897− (concatMapWithAppend 2 (value `div` 2))
1898−
1899− -- concatMap vs concatUnfold
1900− , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)"
1901− (concatMapRepl sqrtVal sqrtVal)
1902− , benchIOSrc1 "concatUnfoldRepl (sqrt n of sqrt n)"
1903− (concatUnfoldRepl sqrtVal sqrtVal)
1904− ]
1905− ]
1906−
1907− where
1908−
1909− sqrtVal = round $ sqrt (fromIntegral value :: Double)
1910−
1911−-------------------------------------------------------------------------------
1912−-- Applicative
1913−-------------------------------------------------------------------------------
1914−
1915−o_1_space_applicative :: Int -> [Benchmark]
1916−o_1_space_applicative value =
1917− [ bgroup "Applicative"
1918− [ benchIO "(*>) (sqrt n x sqrt n)" $ apDiscardFst value serially
1919− , benchIO "(<*) (sqrt n x sqrt n)" $ apDiscardSnd value serially
1920− , benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp value serially
1921− , benchIO "liftA2 (sqrt n x sqrt n)" $ apLiftA2 value serially
1922− ]
1923− ]
1924−
1925−o_n_space_applicative :: Int -> [Benchmark]
1926−o_n_space_applicative value =
1927− [ bgroup "Applicative"
1928− [ benchIOSrc serially "(*>) (n times)" $
1929− iterateSingleton ((*>) . pure) value
1930− , benchIOSrc serially "(<*) (n times)" $
1931− iterateSingleton (\x xs -> xs <* pure x) value
1932− , benchIOSrc serially "(<*>) (n times)" $
1933− iterateSingleton (\x xs -> (P.fmap (+) (pure x) <*> xs)) value
1934− , benchIOSrc serially "liftA2 (n times)" $
1935− iterateSingleton (\x xs -> AP.liftA2 (+) (pure x) xs) value
1936− ]
1937− ]
1938−
1939−-------------------------------------------------------------------------------
1940−-- Monad
1941−-------------------------------------------------------------------------------
1942−
1943−o_1_space_monad :: Int -> [Benchmark]
1944−o_1_space_monad value =
1945− [ bgroup "Monad"
1946− [ benchIO "(>>) (sqrt n x sqrt n)" $ monadThen value serially
1947− , benchIO "(>>=) (sqrt n x sqrt n)" $ toNullM value serially
1948− , benchIO "(>>=) (sqrt n x sqrt n) (filterAllOut)" $
1949− filterAllOutM value serially
1950− , benchIO "(>>=) (sqrt n x sqrt n) (filterAllIn)" $
1951− filterAllInM value serially
1952− , benchIO "(>>=) (sqrt n x sqrt n) (filterSome)" $
1953− filterSome value serially
1954− , benchIO "(>>=) (sqrt n x sqrt n) (breakAfterSome)" $
1955− breakAfterSome value serially
1956− , benchIO "(>>=) (cubert n x cubert n x cubert n)" $
1957− toNullM3 value serially
1958− ]
1959− ]
1960−
1961−-- This is a good benchmark but inefficient way to compute primes. As we see a
1962−-- new prime we keep appending a division filter for all the future numbers.
1963−{-# INLINE sieve #-}
1964−sieve :: Monad m => SerialT m Int -> SerialT m Int
1965−sieve s = do
1966− r <- lift $ S.uncons s
1967− case r of
1968− Just (prime, rest) ->
1969− prime `S.cons` sieve (S.filter (\n -> n `mod` prime /= 0) rest)
1970− Nothing -> S.nil
1971−
1972−o_n_space_monad :: Int -> [Benchmark]
1973−o_n_space_monad value =
1974− [ bgroup "Monad"
1975− [ benchIOSrc serially "(>>) (n times)" $
1976− iterateSingleton ((>>) . pure) value
1977− , benchIOSrc serially "(>>=) (n times)" $
1978− iterateSingleton (\x xs -> xs >>= \y -> return (x + y)) value
1979− , benchIO "(>>=) (sqrt n x sqrt n) (toList)" $
1980− toListM value serially
1981− , benchIO "(>>=) (sqrt n x sqrt n) (toListSome)" $
1982− toListSome value serially
1983− , benchIO "naive prime sieve (n/4)"
1984− (\n -> S.sum $ sieve $ S.enumerateFromTo 2 (value `div` 4 + n))
1985− ]
1986− ]
1987−
1988−-------------------------------------------------------------------------------
1989−-- Monad transformation (hoisting etc.)
1990−-------------------------------------------------------------------------------
1991−
1992−{-# INLINE sourceUnfoldrState #-}
1993−sourceUnfoldrState :: (S.IsStream t, S.MonadAsync m)
1994− => Int -> Int -> t (StateT Int m) Int
1995−sourceUnfoldrState value n = S.unfoldrM step n
1996− where
1997− step cnt =
1998− if cnt > n + value
1999− then return Nothing
2000− else do
2001− s <- get
2002− put (s + 1)
2003− return (Just (s, cnt + 1))
2004−
2005−{-# INLINE evalStateT #-}
2006−evalStateT :: S.MonadAsync m => Int -> Int -> SerialT m Int
2007−evalStateT value n =
2008− Internal.evalStateT (return 0) (sourceUnfoldrState value n)
2009−
2010−{-# INLINE withState #-}
2011−withState :: S.MonadAsync m => Int -> Int -> SerialT m Int
2012−withState value n =
2013− Internal.evalStateT
2014− (return (0 :: Int)) (Internal.liftInner (sourceUnfoldrM value n))
2015−
2016−o_1_space_hoisting :: Int -> [Benchmark]
2017−o_1_space_hoisting value =
2018− [ bgroup "hoisting"
2019− [ benchIOSrc serially "evalState" (evalStateT value)
2020− , benchIOSrc serially "withState" (withState value)
2021− ]
2022− ]
2023−
2024−{-# INLINE iterateStateIO #-}
2025−iterateStateIO ::
2026− (S.MonadAsync m)
2027− => Int
2028− -> StateT Int m Int
2029−iterateStateIO n = do
2030− x <- get
2031− if x > n
2032− then do
2033− put (x - 1)
2034− iterateStateIO n
2035− else return x
2036−
2037−{-# INLINE iterateStateT #-}
2038−iterateStateT :: Int -> SerialT (StateT Int IO) Int
2039−iterateStateT n = do
2040− x <- lift get
2041− if x > n
2042− then do
2043− lift $ put (x - 1)
2044− iterateStateT n
2045− else return x
2046−
2047−{-# INLINE iterateState #-}
2048−iterateState ::
2049− (S.MonadAsync m, MonadState Int m)
2050− => Int
2051− -> SerialT m Int
2052−iterateState n = do
2053− x <- get
2054− if x > n
2055− then do
2056− put (x - 1)
2057− iterateState n
2058− else return x
2059−
2060−o_n_heap_transformer :: Int -> [Benchmark]
2061−o_n_heap_transformer value =
2062− [ bgroup "transformer"
2063− [ benchIO "StateT Int IO (n times) (baseline)" $ \n ->
2064− State.evalStateT (iterateStateIO n) value
2065− , benchIO "SerialT (StateT Int IO) (n times)" $ \n ->
2066− State.evalStateT (S.drain (iterateStateT n)) value
2067− , benchIO "MonadState Int m => SerialT m Int" $ \n ->
2068− State.evalStateT (S.drain (iterateState n)) value
2069− ]
2070− ]
2071−
2072−
207327-------------------------------------------------------------------------------
207428-- Main
207529-------------------------------------------------------------------------------
@@ -2084,71 +38,11 @@ main = do
208438
208539 where
208640
2087− allBenchmarks size =
2088− [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat
2089− [ o_1_space_generation size
2090−
2091− -- elimination
2092− , o_1_space_elimination_foldable size
2093− , o_1_space_elimination_folds size
2094− , o_1_space_elimination_multi_stream_pure size
2095− , o_1_space_elimination_multi_stream size
2096−
2097− -- transformation
2098− , o_1_space_functor size
2099− , o_1_space_mapping size
2100− , o_1_space_mappingX4 size
2101− , o_1_space_filtering size
2102− , o_1_space_filteringX4 size
2103− , o_1_space_inserting size
2104− , o_1_space_insertingX4 size
2105− , o_1_space_transformations_mixed size
2106− , o_1_space_transformations_mixedX4 size
2107− , o_1_space_indexing size
2108− , o_1_space_indexingX4 size
2109−
2110− -- grouping
2111− , o_1_space_grouping size
2112−
2113− -- pipes
2114− , o_1_space_pipes size
2115− , o_1_space_pipesX4 size
2116−
2117− -- multi-stream
2118− , o_1_space_joining size
2119− , o_1_space_concatFoldable size
2120− , o_1_space_concat size
2121−
2122− , o_1_space_applicative size
2123− , o_1_space_monad size
2124−
2125− -- Monad transformation
2126− , o_1_space_hoisting size
2127− ]
2128− , bgroup (o_n_stack_prefix moduleName) (o_n_stack_iterated size)
2129− , bgroup (o_n_heap_prefix moduleName) $ Prelude.concat
2130− [ o_n_heap_generation size
2131− , o_n_heap_elimination_foldl size
2132− , o_n_heap_elimination_toList size
2133− , o_n_heap_elimination_buffered size
2134−
2135− -- transformation
2136− , o_n_heap_buffering size
2137− , o_n_heap_transformer size
2138− ]
2139− , bgroup (o_n_space_prefix moduleName) $ Prelude.concat
2140− [ o_n_space_elimination_foldable size
2141− , o_n_space_elimination_toList size
2142− , o_n_space_elimination_foldr size
2143−
2144− -- transformation
2145− , o_n_space_traversable size
2146− , o_n_space_mapping size
2147− , o_n_space_grouping size
2148−
2149− -- multi-stream
2150− , o_n_space_functor size
2151− , o_n_space_applicative size
2152− , o_n_space_monad size
2153− ]
41+ allBenchmarks size = Prelude.concat
42+ [ Generation.benchmarks moduleName size
43+ , Elimination.benchmarks moduleName size
44+ , Transformation1.benchmarks moduleName size
45+ , Transformation2.benchmarks moduleName size
46+ , Transformation3.benchmarks moduleName size
47+ , Nested.benchmarks moduleName size
215448 ]