benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs · streamly

git.iko.soy/streamly

on 294aa21 help sign in

streamly/benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs

244 lines 8.1 kB history raw

1-- |

2-- Module : Streamly.Benchmark.Data.ParserD

4--

5-- License : BSD-3-Clause

6-- Maintainer : streamly@composewell.com

8{-# LANGUAGE FlexibleContexts #-}

9{-# OPTIONS_GHC -fspec-constr-recursive=4 #-}

11module Main

12 (

13 main

14 ) where

16import Control.DeepSeq (NFData(..))

17import Control.Monad.Catch (MonadCatch, MonadThrow)

18import Data.Foldable (asum)

19import System.Random (randomRIO)

20import Prelude hiding (any, all, take, sequence, sequenceA, takeWhile)

22import qualified Data.Traversable as TR

23import qualified Data.Foldable as F

24import qualified Control.Applicative as AP

25import qualified Streamly as S hiding (runStream)

26import qualified Streamly.Prelude as S

27import qualified Streamly.Internal.Data.Fold as FL

28import qualified Streamly.Internal.Data.Parser.ParserD as PR

29import qualified Streamly.Internal.Prelude as IP

31import Gauge

32import Streamly hiding (runStream)

33import Streamly.Benchmark.Common

35-------------------------------------------------------------------------------

36-- Utilities

37-------------------------------------------------------------------------------

39-- XXX these can be moved to the common module

41{-# INLINE sourceUnfoldrM #-}

42sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int

43sourceUnfoldrM value n = S.unfoldrM step n

44 where

45 step cnt =

46 if cnt > n + value

47 then return Nothing

48 else return (Just (cnt, cnt + 1))

50-- | Takes a fold method, and uses it with a default source.

51{-# INLINE benchIOSink #-}

52benchIOSink

53 :: (IsStream t, NFData b)

54 => Int -> String -> (t IO Int -> IO b) -> Benchmark

55benchIOSink value name f =

56 bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value

58-------------------------------------------------------------------------------

59-- Parsers

60-------------------------------------------------------------------------------

62{-# INLINE any #-}

63any :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool

64any value = IP.parseD (PR.any (> value))

66{-# INLINE all #-}

67all :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool

68all value = IP.parseD (PR.all (<= value))

70{-# INLINE take #-}

71take :: MonadThrow m => Int -> SerialT m a -> m ()

72take value = IP.parseD (PR.take value FL.drain)

74{-# INLINE takeWhile #-}

75takeWhile :: MonadThrow m => Int -> SerialT m Int -> m ()

76takeWhile value = IP.parseD (PR.takeWhile (<= value) FL.drain)

78{-# INLINE many #-}

79many :: MonadCatch m => SerialT m Int -> m Int

80many = IP.parseD (PR.many FL.length (PR.satisfy (> 0)))

82{-# INLINE manyAlt #-}

83manyAlt :: MonadCatch m => SerialT m Int -> m Int

84manyAlt xs = do

85 x <- IP.parseD (AP.many (PR.satisfy (> 0))) xs

86 return $ Prelude.length x

88{-# INLINE some #-}

89some :: MonadCatch m => SerialT m Int -> m Int

90some = IP.parseD (PR.some FL.length (PR.satisfy (> 0)))

92{-# INLINE someAlt #-}

93someAlt :: MonadCatch m => SerialT m Int -> m Int

94someAlt xs = do

95 x <- IP.parseD (AP.some (PR.satisfy (> 0))) xs

96 return $ Prelude.length x

98{-# INLINE manyTill #-}

99manyTill :: MonadCatch m => Int -> SerialT m Int -> m Int

100manyTill value =

101 let p = PR.satisfy (> 0)

102 pcond = PR.satisfy (== value)

103 in IP.parseD (PR.manyTill FL.length p pcond)

104

105{-# INLINE splitAllAny #-}

106splitAllAny :: MonadThrow m

107 => Int -> SerialT m Int -> m (Bool, Bool)

108splitAllAny value =

109 IP.parseD ((,) <$> PR.all (<= (value `div` 2)) <*> PR.any (> value))

110

111{-# INLINE teeAllAny #-}

112teeAllAny :: (MonadThrow m, Ord a)

113 => a -> SerialT m a -> m (Bool, Bool)

114teeAllAny value =

115 IP.parseD (PR.teeWith (,) (PR.all (<= value)) (PR.any (> value)))

116

117{-# INLINE teeFstAllAny #-}

118teeFstAllAny :: (MonadThrow m, Ord a)

119 => a -> SerialT m a -> m (Bool, Bool)

120teeFstAllAny value =

121 IP.parseD (PR.teeWithFst (,) (PR.all (<= value)) (PR.any (> value)))

122

123{-# INLINE shortestAllAny #-}

124shortestAllAny :: (MonadThrow m, Ord a)

125 => a -> SerialT m a -> m Bool

126shortestAllAny value =

127 IP.parseD (PR.shortest (PR.all (<= value)) (PR.any (> value)))

128

129{-# INLINE longestAllAny #-}

130longestAllAny :: (MonadCatch m, Ord a)

131 => a -> SerialT m a -> m Bool

132longestAllAny value =

133 IP.parseD (PR.longest (PR.all (<= value)) (PR.any (> value)))

134

135-------------------------------------------------------------------------------

136-- Parsers in which -fspec-constr-recursive=16 is problematic

137-------------------------------------------------------------------------------

138

139-- XXX -fspec-constr-recursive=16 makes GHC go beserk when compiling these.

140-- We need to fix GHC so that we can have better control over that option or do

141-- not have to rely on it.

142--

143{-# INLINE lookAhead #-}

144lookAhead :: MonadThrow m => Int -> SerialT m Int -> m ()

145lookAhead value =

146 IP.parseD (PR.lookAhead (PR.takeWhile (<= value) FL.drain) *> pure ())

147

148{-# INLINE sequenceA_ #-}

149sequenceA_ :: MonadThrow m => Int -> SerialT m Int -> m ()

150sequenceA_ value =

151 IP.parseD (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))

152

153-- quadratic complexity

154{-# INLINE sequenceA #-}

155sequenceA :: MonadThrow m => Int -> SerialT m Int -> m Int

156sequenceA value xs = do

157 x <- IP.parseD (TR.sequenceA (replicate value (PR.satisfy (> 0)))) xs

158 return $ length x

159

160-- quadratic complexity

161{-# INLINE sequence #-}

162sequence :: MonadThrow m => Int -> SerialT m Int -> m Int

163sequence value xs = do

164 x <- IP.parseD (TR.sequence (replicate value (PR.satisfy (> 0)))) xs

165 return $ length x

166

167-- choice using the "Alternative" instance with direct style parser type has

168-- quadratic performance complexity.

169--

170{-# INLINE choice #-}

171choice :: MonadCatch m => Int -> SerialT m Int -> m Int

172choice value =

173 IP.parseD (asum (replicate value (PR.satisfy (< 0)))

174 AP.<|> PR.satisfy (> 0))

175

176-------------------------------------------------------------------------------

177-- Benchmarks

178-------------------------------------------------------------------------------

179

180moduleName :: String

181moduleName = "Data.Parser.ParserD"

182

183o_1_space_serial :: Int -> [Benchmark]

184o_1_space_serial value =

185 [ benchIOSink value "any" $ any value

186 , benchIOSink value "all" $ all value

187 , benchIOSink value "take" $ take value

188 , benchIOSink value "takeWhile" $ takeWhile value

189 , benchIOSink value "split (all,any)" $ splitAllAny value

190 , benchIOSink value "many" many

191 , benchIOSink value "some" some

192 , benchIOSink value "manyTill" $ manyTill value

193 , benchIOSink value "tee (all,any)" $ teeAllAny value

194 , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value

195 , benchIOSink value "shortest (all,any)" $ shortestAllAny value

196 , benchIOSink value "longest (all,any)" $ longestAllAny value

197 ]

198

199o_n_heap_serial :: Int -> [Benchmark]

200o_n_heap_serial value =

201 [

202 -- lookahead benchmark holds the entire input till end

203 benchIOSink value "lookAhead" $ lookAhead value

204

205 -- These show non-linear time complexity

206 -- They accumulate the results in a list.

207 , benchIOSink value "manyAlt" manyAlt

208 , benchIOSink value "someAlt" someAlt

209 ]

210

211-- accumulate results in a list in IO

212o_n_space_serial :: Int -> [Benchmark]

213o_n_space_serial value =

214 [ benchIOSink value "sequenceA/100" $ sequenceA (value `div` 100)

215 , benchIOSink value "sequenceA_/100" $ sequenceA_ (value `div` 100)

216 , benchIOSink value "sequence/100" $ sequence (value `div` 100)

217 , benchIOSink value "choice/100" $ choice (value `div` 100)

218 ]

219

220-------------------------------------------------------------------------------

221-- Driver

222-------------------------------------------------------------------------------

223

224main :: IO ()

225main = do

226 (value, cfg, benches) <- parseCLIOpts defaultStreamSize

227 value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)

228

229 where

230

231 allBenchmarks value =

232 [ bgroup (o_1_space_prefix moduleName) $ concat

233 [

234 o_1_space_serial value

235 ]

236 , bgroup (o_n_heap_prefix moduleName) $ concat

237 [

238 o_n_heap_serial value

239 ]

240 , bgroup (o_n_space_prefix moduleName) $ concat

241 [

242 o_n_space_serial value

243 ]

244 ]