{-# 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 ]