streamly-0.9.0: benchmark/Streamly/Benchmark/Prelude/WSerial.hs
{-# OPTIONS_GHC -Wno-deprecations #-}
-- |
-- Module : Main
-- Copyright : (c) 2018 Composewell Technologies
--
-- License : BSD3
-- Maintainer : streamly@composewell.com
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
#ifdef __HADDOCK_VERSION__
#undef INSPECTION
#endif
#ifdef INSPECTION
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
#endif
import Streamly.Prelude (wSerial, fromWSerial)
import qualified Streamly.Prelude as S
import qualified Streamly.Internal.Data.Stream.IsStream as Internal
import qualified Streamly.Internal.Data.Unfold as UF
import Streamly.Benchmark.Common
import Streamly.Benchmark.Prelude
import Gauge
#ifdef INSPECTION
import GHC.Types (SPEC(..))
import Test.Inspection
import qualified Streamly.Internal.Data.Stream.StreamD as D
#endif
moduleName :: String
moduleName = "Prelude.WSerial"
-------------------------------------------------------------------------------
-- Mapping
-------------------------------------------------------------------------------
o_1_space_mapping :: Int -> [Benchmark]
o_1_space_mapping value =
[ bgroup "mapping"
[ benchIOSink value "fmap" $ fmapN fromWSerial 1 ]
]
-------------------------------------------------------------------------------
-- Interleaving
-------------------------------------------------------------------------------
{-# INLINE wSerial2 #-}
wSerial2 :: Int -> Int -> IO ()
wSerial2 value n =
S.drain $ wSerial
(sourceUnfoldrM (value `div` 2) n)
(sourceUnfoldrM (value `div` 2) (n + 1))
{-# INLINE interleave2 #-}
interleave2 :: Int -> Int -> IO ()
interleave2 value n =
S.drain $
Internal.interleave
(sourceUnfoldrM (value `div` 2) n)
(sourceUnfoldrM (value `div` 2) (n + 1))
#ifdef INSPECTION
inspect $ hasNoTypeClasses 'interleave2
inspect $ 'interleave2 `hasNoType` ''SPEC
inspect $ 'interleave2 `hasNoType` ''D.InterleaveState
#endif
{-# INLINE roundRobin2 #-}
roundRobin2 :: Int -> Int -> IO ()
roundRobin2 value n =
S.drain $
Internal.roundrobin
(sourceUnfoldrM (value `div` 2) n)
(sourceUnfoldrM (value `div` 2) (n + 1))
#ifdef INSPECTION
inspect $ hasNoTypeClasses 'roundRobin2
inspect $ 'roundRobin2 `hasNoType` ''SPEC
inspect $ 'roundRobin2 `hasNoType` ''D.InterleaveState
#endif
{-# INLINE sourceUnfoldrMUF #-}
-- (count, value)
sourceUnfoldrMUF :: Monad m => Int -> UF.Unfold m (Int, Int) Int
sourceUnfoldrMUF count = UF.unfoldrM step
where
step (cnt, start) =
return $
if cnt > start + count
then Nothing
else Just (cnt, (cnt + 1, start))
{-# INLINE unfoldManyInterleave #-}
unfoldManyInterleave :: Int -> Int -> Int -> IO ()
unfoldManyInterleave outer inner n =
S.drain $ Internal.unfoldManyInterleave
-- (UF.lmap return (UF.replicateM inner))
(UF.lmap (\x -> (x,x)) (sourceUnfoldrMUF inner))
(sourceUnfoldrM outer n)
#ifdef INSPECTION
inspect $ hasNoTypeClasses 'unfoldManyInterleave
-- inspect $ 'unfoldManyInterleave `hasNoType` ''SPEC
-- inspect $ 'unfoldManyInterleave `hasNoType`
-- ''D.ConcatUnfoldInterleaveState
#endif
{-# INLINE unfoldManyRoundRobin #-}
unfoldManyRoundRobin :: Int -> Int -> Int -> IO ()
unfoldManyRoundRobin outer inner n =
S.drain $ Internal.unfoldManyRoundRobin
-- (UF.lmap return (UF.replicateM inner))
(UF.lmap (\x -> (x,x)) (sourceUnfoldrMUF inner))
(sourceUnfoldrM outer n)
#ifdef INSPECTION
inspect $ hasNoTypeClasses 'unfoldManyRoundRobin
-- inspect $ 'unfoldManyRoundRobin `hasNoType` ''SPEC
-- inspect $ 'unfoldManyRoundRobin `hasNoType`
-- ''D.ConcatUnfoldInterleaveState
#endif
{-# INLINE concatPairsWithWSerial #-}
concatPairsWithWSerial :: Int -> Int -> Int -> IO ()
concatPairsWithWSerial = concatPairsWith Internal.wSerial
{-# INLINE concatPairsWithRoundrobin #-}
concatPairsWithRoundrobin :: Int -> Int -> Int -> IO ()
concatPairsWithRoundrobin = concatPairsWith Internal.roundrobin
{-# INLINE concatMapWithWSerial #-}
concatMapWithWSerial :: Int -> Int -> Int -> IO ()
concatMapWithWSerial = concatStreamsWith wSerial
#ifdef INSPECTION
inspect $ hasNoTypeClasses 'concatMapWithWSerial
inspect $ 'concatMapWithWSerial `hasNoType` ''SPEC
#endif
o_1_space_joining :: Int -> [Benchmark]
o_1_space_joining value =
[ bgroup "joining (2 of n/2)"
[ benchIOSrc1 "wSerial" (wSerial2 value)
, benchIOSrc1 "interleave" (interleave2 value)
, benchIOSrc1 "roundRobin" (roundRobin2 value)
, benchIOSrc1
"concatMapWithWSerial"
(concatMapWithWSerial 2 (value `div` 2))
, benchIOSrc1
"concatMapWithInterleave"
(concatStreamsWith Internal.interleave 2 (value `div` 2))
, benchIOSrc1
"concatMapWithRoundrobin"
(concatStreamsWith Internal.roundrobin 2 (value `div` 2))
, benchIOSrc1
"unfoldManyInterleave"
(unfoldManyInterleave 2 (value `div` 2))
, benchIOSrc1
"concatPairsWithWSerial"
(concatPairsWithWSerial 2 (value `div` 2))
, benchIOSrc1
"concatPairsWithRoundrobin"
(concatPairsWithRoundrobin 2 (value `div` 2))
]
]
-------------------------------------------------------------------------------
-- Concat
-------------------------------------------------------------------------------
o_1_space_concat :: Int -> [Benchmark]
o_1_space_concat value =
[ bgroup "concatMapWith"
[ benchIOSrc1
"concatMapWithWSerial (n of 1)"
(concatStreamsWith wSerial value 1)
, benchIOSrc1
"concatMapWithWSerial (sqrtVal of sqrtVal)"
(concatStreamsWith wSerial sqrtVal sqrtVal)
]
]
where
sqrtVal = round $ sqrt (fromIntegral value :: Double)
o_n_space_concat :: Int -> [Benchmark]
o_n_space_concat value =
[ bgroup "concatMapWith"
[
-- concatMapWith using StreamD versions of interleave operations are
-- all quadratic, we just measure the sqrtVal benchmark for comparison.
benchIOSrc1
"concatMapWithInterleave (sqrtVal of 1)"
(concatStreamsWith Internal.interleave sqrtVal 1)
, benchIOSrc1
"concatMapWithInterleave (sqrtVal of sqrtVal)"
(concatStreamsWith Internal.interleave sqrtVal sqrtVal)
, benchIOSrc1
"concatMapWithRoundrobin (sqrtVal of sqrtVal)"
(concatStreamsWith Internal.roundrobin sqrtVal sqrtVal)
]
]
where
sqrtVal = round $ sqrt (fromIntegral value :: Double)
{-# INLINE concatPairsWithInterleave #-}
concatPairsWithInterleave :: Int -> Int -> Int -> IO ()
concatPairsWithInterleave = concatPairsWith Internal.interleave
{-# INLINE concatPairsWithInterleaveSuffix #-}
concatPairsWithInterleaveSuffix :: Int -> Int -> Int -> IO ()
concatPairsWithInterleaveSuffix = concatPairsWith Internal.interleaveSuffix
{-# INLINE concatPairsWithInterleaveInfix #-}
concatPairsWithInterleaveInfix :: Int -> Int -> Int -> IO ()
concatPairsWithInterleaveInfix = concatPairsWith Internal.interleaveInfix
{-# INLINE concatPairsWithInterleaveMin #-}
concatPairsWithInterleaveMin :: Int -> Int -> Int -> IO ()
concatPairsWithInterleaveMin = concatPairsWith Internal.interleaveMin
o_n_heap_concat :: Int -> [Benchmark]
o_n_heap_concat value =
[ bgroup "concatPairsWith"
[
benchIOSrc1
"unfoldManyInterleave (n of 1)"
(unfoldManyInterleave value 1)
, benchIOSrc1
"unfoldManyInterleave (sqrtVal of sqrtVal)"
(unfoldManyInterleave sqrtVal sqrtVal)
, benchIOSrc1
"unfoldManyRoundRobin (n of 1)"
(unfoldManyRoundRobin value 1)
, benchIOSrc1
"unfoldManyRoundRobin (sqrtVal of sqrtVal)"
(unfoldManyRoundRobin sqrtVal sqrtVal)
, benchIOSrc1
"concatPairsWithWSerial (n of 1)"
(concatPairsWithWSerial value 1)
, benchIOSrc1
"concatPairsWithWSerial (sqrtVal of sqrtVal)"
(concatPairsWithWSerial sqrtVal sqrtVal)
, benchIOSrc1
"concatPairsWithInterleave (n of 1)"
(concatPairsWithInterleave value 1)
, benchIOSrc1
"concatPairsWithInterleave (sqrtVal of sqrtVal)"
(concatPairsWithInterleave sqrtVal sqrtVal)
, benchIOSrc1
"concatPairsWithInterleaveSuffix (n of 1)"
(concatPairsWithInterleaveSuffix value 1)
, benchIOSrc1
"concatPairsWithInterleaveSuffix (sqrtVal of sqrtVal)"
(concatPairsWithInterleaveSuffix sqrtVal sqrtVal)
, benchIOSrc1
"concatPairsWithInterleaveInfix (n of 1)"
(concatPairsWithInterleaveInfix value 1)
, benchIOSrc1
"concatPairsWithInterleaveInfix (sqrtVal of sqrtVal)"
(concatPairsWithInterleaveInfix sqrtVal sqrtVal)
, benchIOSrc1
"concatPairsWithInterleaveMin (n of 1)"
(concatPairsWithInterleaveMin value 1)
, benchIOSrc1
"concatPairsWithInterleaveMin (sqrtVal of sqrtVal)"
(concatPairsWithInterleaveMin sqrtVal sqrtVal)
, benchIOSrc1
"concatPairsWithRoundrobin (n of 1)"
(concatPairsWithRoundrobin value 1)
, benchIOSrc1
"concatPairsWithRoundrobin (sqrtVal of sqrtVal)"
(concatPairsWithRoundrobin sqrtVal sqrtVal)
]
]
where
sqrtVal = round $ sqrt (fromIntegral value :: Double)
-------------------------------------------------------------------------------
-- Monad
-------------------------------------------------------------------------------
o_1_space_outerProduct :: Int -> [Benchmark]
o_1_space_outerProduct value =
[ bgroup "outer-product"
[ benchIO
"drain applicative (+) (sqrtVal of sqrtVal)"
(toNullAp value fromWSerial)
, benchIO
"drain monad (+) (sqrtVal of sqrtVal)"
(toNullM value fromWSerial)
, benchIO
"drain monad (+) (cbrtVal of cbrtVal of cbrtVal)"
(toNullM3 value fromWSerial)
, benchIO
"filterAllOut monad (+) (sqrtVal of sqrtVal)"
(filterAllOutM value fromWSerial)
, benchIO
"filterAllIn monad (+) (sqrtVal of sqrtVal)"
(filterAllInM value fromWSerial)
, benchIO
"filterSome monad (+) (sqrtVal of sqrtVal)"
(filterSome value fromWSerial)
, benchIO
"breakAfterSome monad (+) (sqrtVal of sqrtVal)"
(breakAfterSome value fromWSerial)
]
]
o_n_space_outerProduct :: Int -> [Benchmark]
o_n_space_outerProduct value =
[ bgroup
"outer-product"
[ benchIO
"toList monad (+) (sqrtVal of sqrtVal)"
(toListM value fromWSerial)
, benchIO
"toListSome monad (+) (sqrtVal of sqrtVal)"
(toListSome value fromWSerial)
]
]
-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------
-- In addition to gauge options, the number of elements in the stream can be
-- passed using the --stream-size option.
--
main :: IO ()
main = runWithCLIOpts defaultStreamSize allBenchmarks
where
allBenchmarks size =
[ bgroup (o_1_space_prefix moduleName) $ concat
[ o_1_space_mapping size
, o_1_space_joining size
, o_1_space_concat size
, o_1_space_outerProduct size
]
, bgroup (o_n_heap_prefix moduleName) (o_n_heap_concat size)
, bgroup (o_n_space_prefix moduleName) $
o_n_space_outerProduct size ++ o_n_space_concat size
]