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

git.iko.soy/streamly

on a05abfc help sign in

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

412 lines 15 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.Array.Foreign as Array

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

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

32import qualified Streamly.Internal.Data.Producer as Producer

33import qualified Streamly.Internal.Data.Producer.Source as Source

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

36import Gauge

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

38import Streamly.Benchmark.Common

40-------------------------------------------------------------------------------

41-- Utilities

42-------------------------------------------------------------------------------

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

46{-# INLINE sourceUnfoldrM #-}

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

48sourceUnfoldrM value n = S.unfoldrM step n

49 where

50 step cnt =

51 if cnt > n + value

52 then return Nothing

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

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

56{-# INLINE benchIOSink #-}

57benchIOSink

58 :: (IsStream t, NFData b)

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

60benchIOSink value name f =

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

63-- Make the input unsorted.

64{-# INLINE benchIOSinkRandom #-}

65benchIOSinkRandom

66 :: (IsStream t, NFData b)

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

68benchIOSinkRandom value name f =

69 bench name $ nfIO $ randomRIO (1,1)

70 >>= f

71 . S.map (\x -> if even x then x + 2 else x)

72 . sourceUnfoldrM value

74-------------------------------------------------------------------------------

75-- Parsers

76-------------------------------------------------------------------------------

78{-# INLINE drainWhile #-}

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

80drainWhile p = PR.takeWhile p FL.drain

82{-# INLINE sliceBeginWith #-}

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

84sliceBeginWith value stream = do

85 stream1 <- return . fromMaybe (S.fromPure (value + 1)) =<< S.tail stream

86 let stream2 = value `S.cons` stream1

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

89{-# INLINE takeWhile #-}

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

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

93{-# INLINE takeP #-}

94takeP :: MonadThrow m => Int -> SerialT m a -> m ()

95takeP value = IP.parseD (PR.takeP value (PR.fromFold FL.drain))

97{-# INLINE groupBy #-}

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

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

100

101{-# INLINE groupByRolling #-}

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

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

104

105{-# INLINE wordBy #-}

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

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

108

109{-# INLINE manyWordByEven #-}

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

111manyWordByEven =

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

113

114{-# INLINE many #-}

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

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

117

118{-# INLINE manyAlt #-}

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

120manyAlt xs = do

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

122 return $ Prelude.length x

123

124{-# INLINE some #-}

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

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

127

128{-# INLINE someAlt #-}

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

130someAlt xs = do

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

132 return $ Prelude.length x

133

134{-#INLINE sliceSepByP #-}

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

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

137

138{-# INLINE manyTill #-}

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

140manyTill value =

141 let p = PR.satisfy (> 0)

142 pcond = PR.satisfy (== value)

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

144

145{-# INLINE serialWith #-}

146serialWith :: MonadThrow m

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

148serialWith value =

149 IP.parseD

150 ((,)

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

152 <*> drainWhile (<= value)

153 )

154

155{-# INLINE teeAllAny #-}

156teeAllAny :: MonadThrow m

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

158teeAllAny value =

159 IP.parseD

160 (PR.teeWith (,)

161 (drainWhile (<= value))

162 (drainWhile (<= value))

163 )

164

165{-# INLINE teeFstAllAny #-}

166teeFstAllAny :: MonadThrow m

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

168teeFstAllAny value =

169 IP.parseD

170 (PR.teeWithFst (,)

171 (drainWhile (<= value))

172 (drainWhile (<= value))

173 )

174

175{-# INLINE shortestAllAny #-}

176shortestAllAny :: MonadThrow m

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

178shortestAllAny value =

179 IP.parseD

180 (PR.shortest

181 (drainWhile (<= value))

182 (drainWhile (<= value))

183 )

184

185{-# INLINE longestAllAny #-}

186longestAllAny :: MonadCatch m

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

188longestAllAny value =

189 IP.parseD

190 (PR.longest

191 (drainWhile (<= value))

192 (drainWhile (<= value))

193 )

194

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

196-- Spanning

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

198

199{-# INLINE span #-}

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

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

202

203{-# INLINE spanBy #-}

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

205spanBy value =

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

207

208{-# INLINE spanByRolling #-}

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

210spanByRolling value =

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

212

213-------------------------------------------------------------------------------

214-- Nested

215-------------------------------------------------------------------------------

216

217{-# INLINE parseMany #-}

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

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

220

221{-# INLINE parseManyGroups #-}

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

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

224

225{-# INLINE parseManyGroupsRolling #-}

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

227parseManyGroupsRolling b =

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

229

230{-# INLINE parseManyGroupsRollingEither #-}

231parseManyGroupsRollingEither :: (MonadThrow m, MonadCatch m) =>

232 (Int -> Int -> Bool) -> SerialT m Int -> m ()

233parseManyGroupsRollingEither cmp =

234 IP.drain

235 . IP.parseManyD (PR.groupByRollingEither cmp FL.drain FL.drain)

236

237-------------------------------------------------------------------------------

238-- Parsing with unfolds

239-------------------------------------------------------------------------------

240

241{-# INLINE parseManyUnfoldArrays #-}

242parseManyUnfoldArrays :: Int -> [Array.Array Int] -> IO ()

243parseManyUnfoldArrays count arrays = do

244 let src = Source.source (Just (Producer.OuterLoop arrays))

245 let parser = PR.fromFold (FL.take count FL.drain)

246 let readSrc =

247 Source.producer

248 $ Producer.concat Producer.fromList Array.producer

249 let streamParser =

250 Producer.simplify (Source.parseManyD parser readSrc)

251 S.drain $ S.unfold streamParser src

252

253-------------------------------------------------------------------------------

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

255-------------------------------------------------------------------------------

256

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

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

259-- not have to rely on it.

260--

261{-# INLINE lookAhead #-}

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

263lookAhead value =

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

265

266{-# INLINE sequenceA_ #-}

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

268sequenceA_ value =

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

270

271-- quadratic complexity

272{-# INLINE sequenceA #-}

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

274sequenceA value xs = do

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

276 return $ length x

277

278-- quadratic complexity

279{-# INLINE sequence #-}

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

281sequence value xs = do

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

283 return $ length x

284

285{-# INLINE sequence_ #-}

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

287sequence_ value xs =

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

289

290 where

291

292 {-# INLINE f #-}

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

294

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

296-- quadratic performance complexity.

297--

298{-# INLINE choiceAsum #-}

299choiceAsum :: MonadCatch m => Int -> SerialT m Int -> m Int

300choiceAsum value =

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

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

303

304{-# INLINE choice #-}

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

306choice value =

307 IP.parseD

308 (PR.choice (replicate value (PR.satisfy (< 0))) AP.<|> PR.satisfy (> 0))

309

310-------------------------------------------------------------------------------

311-- Benchmarks

312-------------------------------------------------------------------------------

313

314moduleName :: String

315moduleName = "Data.Parser.ParserD"

316

317o_1_space_serial :: Int -> [Benchmark]

318o_1_space_serial value =

319 [ benchIOSink value "takeWhile" $ takeWhile value

320 , benchIOSink value "takeP" $ takeP value

321 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

322 , benchIOSink value "groupBy" $ groupBy

323 , benchIOSink value "groupByRolling" $ groupByRolling

324 , benchIOSink value "wordBy" $ wordBy value

325 , benchIOSink value "serialWith" $ serialWith value

326 , benchIOSink value "many" many

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

328 , benchIOSink value "some" some

329 , benchIOSink value "sliceSepByP" $ sliceSepByP value

330 , benchIOSink value "manyTill" $ manyTill value

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

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

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

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

335 ]

336

337o_1_space_serial_spanning :: Int -> [Benchmark]

338o_1_space_serial_spanning value =

339 [ benchIOSink value "span" $ span value

340 , benchIOSink value "spanBy" $ spanBy value

341 , benchIOSink value "spanByRolling" $ spanByRolling value

342 ]

343

344o_1_space_serial_nested :: Int -> [Benchmark]

345o_1_space_serial_nested value =

346 [ benchIOSink value "parseMany" $ parseMany value

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

348 $ parseManyGroups False

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

350 $ parseManyGroupsRolling False

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

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

353 $ parseManyGroupsRolling True

354 , benchIOSink value "parseMany groupRollingByEither (Left)"

355 $ parseManyGroupsRollingEither (<)

356 , benchIOSink value "parseMany groupRollingByEither (Right)"

357 $ parseManyGroupsRollingEither (>)

358 , benchIOSinkRandom value "parseMany groupRollingByEither (Alternating)"

359 $ parseManyGroupsRollingEither (>)

360 ]

361

362o_1_space_serial_unfold :: Int -> [Array.Array Int] -> [Benchmark]

363o_1_space_serial_unfold bound arrays =

364 [ bench "parseMany/Unfold/1000 arrays/1 parse"

365 $ nfIO $ parseManyUnfoldArrays bound arrays

366 , bench "parseMany/Unfold/1000 arrays/100000 parses"

367 $ nfIO $ parseManyUnfoldArrays 1 arrays

368 ]

369

370o_n_heap_serial :: Int -> [Benchmark]

371o_n_heap_serial value =

372 [

373 -- lookahead benchmark holds the entire input till end

374 benchIOSink value "lookAhead" $ lookAhead value

375

376 -- These show non-linear time complexity

377 -- They accumulate the results in a list.

378 , benchIOSink value "manyAlt" manyAlt

379 , benchIOSink value "someAlt" someAlt

380 ]

381

382-- accumulate results in a list in IO

383o_n_space_serial :: Int -> [Benchmark]

384o_n_space_serial value =

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

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

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

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

389 , benchIOSink value "choice (asum)/100" $ choiceAsum (value `div` 100)

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

391 ]

392

393-------------------------------------------------------------------------------

394-- Driver

395-------------------------------------------------------------------------------

396

397main :: IO ()

398main = runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks

399

400 where

401

402 alloc value = IP.toList $ IP.arraysOf 100 $ sourceUnfoldrM value 0

403

404 allBenchmarks arraysSmall value =

405 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

406 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_spanning value)

407 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_nested value)

408 , bgroup (o_1_space_prefix moduleName)

409 (o_1_space_serial_unfold value arraysSmall)

410 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

411 , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)

412 ]