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

git.iko.soy/streamly

on 3947fee help sign in

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

347 lines 12 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{-# LANGUAGE ScopedTypeVariables #-}

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

12module Main

13 (

14 main

15 ) where

17import Control.DeepSeq (NFData(..))

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

19import Data.Foldable (asum)

20import Data.Functor (($>))

21import Data.Maybe (fromMaybe)

22import System.Random (randomRIO)

23import Prelude hiding (any, all, take, sequence, sequenceA, sequence_, takeWhile, span)

25import qualified Data.Traversable as TR

26import qualified Data.Foldable as F

27import qualified Control.Applicative as AP

28import qualified Streamly.Prelude as S

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

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

31import qualified Streamly.Internal.Data.Stream.IsStream as IP

33import Gauge

34import Streamly.Prelude (SerialT, MonadAsync, IsStream)

35import Streamly.Benchmark.Common

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

38-- Utilities

39-------------------------------------------------------------------------------

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

43{-# INLINE sourceUnfoldrM #-}

44sourceUnfoldrM :: (IsStream t, MonadAsync m) => Int -> Int -> t m Int

45sourceUnfoldrM value n = S.unfoldrM step n

46 where

47 step cnt =

48 if cnt > n + value

49 then return Nothing

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

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

53{-# INLINE benchIOSink #-}

54benchIOSink

55 :: (IsStream t, NFData b)

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

57benchIOSink value name f =

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

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

61-- Parsers

62-------------------------------------------------------------------------------

64{-# INLINE drainWhile #-}

65drainWhile :: MonadThrow m => (a -> Bool) -> PR.Parser m a ()

66drainWhile p = PR.takeWhile p FL.drain

68{-# INLINE sliceBeginWith #-}

69sliceBeginWith :: MonadCatch m => Int -> SerialT m Int -> m ()

70sliceBeginWith value stream = do

71 stream1 <- return . fromMaybe (S.yield (value + 1)) =<< S.tail stream

72 let stream2 = value `S.cons` stream1

73 IP.parseD (PR.sliceBeginWith (== value) FL.drain) stream2

75{-# INLINE takeWhile #-}

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

77takeWhile value = IP.parseD (drainWhile (<= value))

79{-# INLINE groupBy #-}

80groupBy :: MonadThrow m => SerialT m Int -> m ()

81groupBy = IP.parseD (PR.groupBy (<=) FL.drain)

83{-# INLINE groupByRolling #-}

84groupByRolling :: MonadThrow m => SerialT m Int -> m ()

85groupByRolling = IP.parseD (PR.groupByRolling (<=) FL.drain)

87{-# INLINE wordBy #-}

88wordBy :: MonadThrow m => Int -> SerialT m Int -> m ()

89wordBy value = IP.parseD (PR.wordBy (>= value) FL.drain)

91{-# INLINE manyWordByEven #-}

92manyWordByEven :: MonadCatch m => SerialT m Int -> m ()

93manyWordByEven =

94 IP.parseD (PR.many FL.drain (PR.wordBy (Prelude.even) FL.drain))

96{-# INLINE many #-}

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

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

100{-# INLINE manyAlt #-}

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

102manyAlt xs = do

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

104 return $ Prelude.length x

105

106{-# INLINE some #-}

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

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

109

110{-# INLINE someAlt #-}

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

112someAlt xs = do

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

114 return $ Prelude.length x

115

116{-#INLINE sliceSepByP #-}

117sliceSepByP :: MonadCatch m => Int -> SerialT m Int -> m ()

118sliceSepByP value = IP.parseD (PR.sliceSepByP (>= value) (PR.fromFold FL.drain))

119

120{-# INLINE manyTill #-}

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

122manyTill value =

123 let p = PR.satisfy (> 0)

124 pcond = PR.satisfy (== value)

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

126

127{-# INLINE splitWith #-}

128splitWith :: MonadThrow m

129 => Int -> SerialT m Int -> m ((), ())

130splitWith value =

131 IP.parseD

132 ((,)

133 <$> drainWhile (<= (value `div` 2))

134 <*> drainWhile (<= value)

135 )

136

137{-# INLINE teeAllAny #-}

138teeAllAny :: MonadThrow m

139 => Int -> SerialT m Int -> m ((), ())

140teeAllAny value =

141 IP.parseD

142 (PR.teeWith (,)

143 (drainWhile (<= value))

144 (drainWhile (<= value))

145 )

146

147{-# INLINE teeFstAllAny #-}

148teeFstAllAny :: MonadThrow m

149 => Int -> SerialT m Int -> m ((), ())

150teeFstAllAny value =

151 IP.parseD

152 (PR.teeWithFst (,)

153 (drainWhile (<= value))

154 (drainWhile (<= value))

155 )

156

157{-# INLINE shortestAllAny #-}

158shortestAllAny :: MonadThrow m

159 => Int -> SerialT m Int -> m ()

160shortestAllAny value =

161 IP.parseD

162 (PR.shortest

163 (drainWhile (<= value))

164 (drainWhile (<= value))

165 )

166

167{-# INLINE longestAllAny #-}

168longestAllAny :: MonadCatch m

169 => Int -> SerialT m Int -> m ()

170longestAllAny value =

171 IP.parseD

172 (PR.longest

173 (drainWhile (<= value))

174 (drainWhile (<= value))

175 )

176

177-------------------------------------------------------------------------------

178-- Spanning

179-------------------------------------------------------------------------------

180

181{-# INLINE span #-}

182span :: MonadThrow m => Int -> SerialT m Int -> m ((), ())

183span value = IP.parseD (PR.span (<= (value `div` 2)) FL.drain FL.drain)

184

185{-# INLINE spanBy #-}

186spanBy :: MonadThrow m => Int -> SerialT m Int -> m ((), ())

187spanBy value =

188 IP.parseD (PR.spanBy (\_ i -> i <= (value `div` 2)) FL.drain FL.drain)

189

190{-# INLINE spanByRolling #-}

191spanByRolling :: MonadThrow m => Int -> SerialT m Int -> m ((), ())

192spanByRolling value =

193 IP.parseD (PR.spanByRolling (\_ i -> i <= value `div` 2) FL.drain FL.drain)

194

195-------------------------------------------------------------------------------

196-- Nested

197-------------------------------------------------------------------------------

198

199{-# INLINE parseMany #-}

200parseMany :: MonadThrow m => Int -> SerialT m Int -> m ()

201parseMany value = IP.drain . IP.parseManyD (drainWhile (<= value + 1))

202

203{-# INLINE parseManyGroups #-}

204parseManyGroups :: MonadThrow m => Bool -> SerialT m Int -> m ()

205parseManyGroups b = IP.drain . IP.parseManyD (PR.groupBy (\_ _ -> b) FL.drain)

206

207{-# INLINE parseManyGroupsRolling #-}

208parseManyGroupsRolling :: MonadThrow m => Bool -> SerialT m Int -> m ()

209parseManyGroupsRolling b =

210 IP.drain . IP.parseManyD (PR.groupByRolling (\_ _ -> b) FL.drain)

211

212-------------------------------------------------------------------------------

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

214-------------------------------------------------------------------------------

215

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

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

218-- not have to rely on it.

219--

220{-# INLINE lookAhead #-}

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

222lookAhead value =

223 IP.parseD (PR.lookAhead (PR.takeWhile (<= value) FL.drain) $> ())

224

225{-# INLINE sequenceA_ #-}

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

227sequenceA_ value =

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

229

230-- quadratic complexity

231{-# INLINE sequenceA #-}

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

233sequenceA value xs = do

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

235 return $ length x

236

237-- quadratic complexity

238{-# INLINE sequence #-}

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

240sequence value xs = do

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

242 return $ length x

243

244{-# INLINE sequence_ #-}

245sequence_ :: MonadCatch m => Int -> SerialT m Int -> m ()

246sequence_ value xs =

247 IP.parseD (foldr f (return ()) (replicate value (PR.takeBetween 0 1 FL.drain))) xs

248

249 where

250

251 {-# INLINE f #-}

252 f m k = m >>= (\_ -> k)

253

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

255-- quadratic performance complexity.

256--

257{-# INLINE choice #-}

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

259choice value =

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

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

262

263-------------------------------------------------------------------------------

264-- Benchmarks

265-------------------------------------------------------------------------------

266

267moduleName :: String

268moduleName = "Data.Parser.ParserD"

269

270o_1_space_serial :: Int -> [Benchmark]

271o_1_space_serial value =

272 [ benchIOSink value "takeWhile" $ takeWhile value

273 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

274 , benchIOSink value "groupBy" $ groupBy

275 , benchIOSink value "groupByRolling" $ groupByRolling

276 , benchIOSink value "wordBy" $ wordBy value

277 , benchIOSink value "splitWith" $ splitWith value

278 , benchIOSink value "many" many

279 , benchIOSink value "many (wordBy even)" $ manyWordByEven

280 , benchIOSink value "some" some

281 , benchIOSink value "sliceSepByP" $ sliceSepByP value

282 , benchIOSink value "manyTill" $ manyTill value

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

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

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

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

287 ]

288

289o_1_space_serial_spanning :: Int -> [Benchmark]

290o_1_space_serial_spanning value =

291 [ benchIOSink value "span" $ span value

292 , benchIOSink value "spanBy" $ spanBy value

293 , benchIOSink value "spanByRolling" $ spanByRolling value

294 ]

295

296o_1_space_serial_nested :: Int -> [Benchmark]

297o_1_space_serial_nested value =

298 [ benchIOSink value "parseMany" $ parseMany value

299 , benchIOSink value "parseMany groupBy (bound groups)"

300 $ (parseManyGroups False)

301 , benchIOSink value "parseMany groupRollingBy (bound groups)"

302 $ (parseManyGroupsRolling False)

303 , benchIOSink value "parseMany groupBy (1 group)" $ (parseManyGroups True)

304 , benchIOSink value "parseMany groupRollingBy (1 group)"

305 $ (parseManyGroupsRolling True)

306 ]

307

308o_n_heap_serial :: Int -> [Benchmark]

309o_n_heap_serial value =

310 [

311 -- lookahead benchmark holds the entire input till end

312 benchIOSink value "lookAhead" $ lookAhead value

313

314 -- These show non-linear time complexity

315 -- They accumulate the results in a list.

316 , benchIOSink value "manyAlt" manyAlt

317 , benchIOSink value "someAlt" someAlt

318 ]

319

320-- accumulate results in a list in IO

321o_n_space_serial :: Int -> [Benchmark]

322o_n_space_serial value =

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

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

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

326 , benchIOSink value "sequence_/100" $ sequence_ (value `div` 100)

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

328 ]

329

330-------------------------------------------------------------------------------

331-- Driver

332-------------------------------------------------------------------------------

333

334main :: IO ()

335main = do

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

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

338

339 where

340

341 allBenchmarks value =

342 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

343 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_spanning value)

344 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_nested value)

345 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

346 , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)

347 ]