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

git.iko.soy/streamly

on 4eaeb10 help sign in

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

550 lines 18 kB history raw

1-- |

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

4--

5-- License : BSD-3-Clause

6-- Maintainer : streamly@composewell.com

8{-# LANGUAGE CPP #-}

9{-# LANGUAGE FlexibleContexts #-}

10{-# LANGUAGE ScopedTypeVariables #-}

12module Main

13 (

14 main

15 ) where

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

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

19import Data.Foldable (asum)

20import Data.Functor (($>))

21import Data.Maybe (fromMaybe)

22import Data.Monoid (Sum(..))

23import GHC.Magic (inline)

24import GHC.Magic (noinline)

25import System.IO (Handle)

26import System.Random (randomRIO)

27import Prelude hiding

28 (any, all, take, sequence, sequence_, sequenceA, takeWhile, dropWhile)

30import qualified Data.Traversable as TR

31import qualified Data.Foldable as F

32import qualified Control.Applicative as AP

33import qualified Streamly.FileSystem.Handle as Handle

34import qualified Streamly.Internal.Data.Array.Unboxed as Array

35import qualified Streamly.Internal.Data.Fold as Fold

36import qualified Streamly.Internal.Data.Parser as PR

37import qualified Streamly.Internal.Data.Stream as Stream

38import qualified Streamly.Internal.Data.Stream.IsStream as IsStream (tail)

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

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

42import Gauge hiding (env)

43import Streamly.Internal.Data.Stream (Stream)

44import Streamly.Benchmark.Common

45import Streamly.Benchmark.Common.Handle

47-------------------------------------------------------------------------------

48-- Utilities

49-------------------------------------------------------------------------------

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

53{-# INLINE sourceUnfoldrM #-}

54sourceUnfoldrM :: Monad m => Int -> Int -> Stream m Int

55sourceUnfoldrM value n = Stream.unfoldrM step n

56 where

57 step cnt =

58 if cnt > n + value

59 then return Nothing

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

62-- | Generates something like this: { { \{ \{ } }. The stream consists of

63-- three parts, the first part is contains a sequence of `{`. The second part

64-- contains a sequence pf escaped values `\{`. The third part contains a

65-- sequence of `}`.

66{-# INLINE sourceEscapedFrames #-}

67sourceEscapedFrames ::

68 Monad m

69 => Int

70 -> Int

71 -> Stream m Char

72sourceEscapedFrames value n = Stream.unfoldrM step n

73 where

75 bs = '\\'

76 cbOpen = '{'

77 cbClose = '}'

78 value1 = value `div` 4

80 step cnt

81 | cnt > 4 * value1 = return Nothing

82 | cnt <= value1 = return $ Just (cbOpen, cnt + 1)

83 | cnt > 3 * value1 = return $ Just (cbClose, cnt + 1)

84 | otherwise =

85 return

86 $ Just

87 $ if (cnt - value1) `mod` 2 == 1

88 then (bs, cnt + 1)

89 else (cbOpen, cnt + 1)

91{-# INLINE benchIOSrc #-}

92benchIOSrc

93 :: NFData b

94 => (Int -> Int -> Stream IO a)

95 -> Int

96 -> String

97 -> (Stream IO a -> IO b)

98 -> Benchmark

99benchIOSrc src value name f =

100 bench name $ nfIO $ randomRIO (1,1) >>= f . src value

101

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

103{-# INLINE benchIOSink #-}

104benchIOSink

105 :: NFData b

106 => Int -> String -> (Stream IO Int -> IO b) -> Benchmark

107benchIOSink value name f =

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

109

110-------------------------------------------------------------------------------

111-- Parsers

112-------------------------------------------------------------------------------

113

114{-# INLINE one #-}

115one :: MonadThrow m => Int -> Stream m Int -> m (Maybe Int)

116one value = Stream.parse p

117

118 where

119

120 p = do

121 m <- PR.fromFold Fold.one

122 case m of

123 Just i -> if i >= value then pure m else p

124 Nothing -> pure Nothing

125

126{-# INLINE takeBetween #-}

127takeBetween :: MonadThrow m => Int -> Stream m a -> m ()

128takeBetween value = Stream.parse (PR.takeBetween 0 value Fold.drain)

129

130{-# INLINE takeEQ #-}

131takeEQ :: MonadThrow m => Int -> Stream m a -> m ()

132takeEQ value = Stream.parse (PR.takeEQ value Fold.drain)

133

134{-# INLINE dropWhile #-}

135dropWhile :: MonadThrow m => Int -> Stream m Int -> m ()

136dropWhile value = Stream.parse (PR.dropWhile (<= value))

137

138{-# INLINE takeStartBy #-}

139takeStartBy :: MonadThrow m => Int -> Stream m Int -> m ()

140takeStartBy value stream = do

141 stream1 <- return . fromMaybe (Stream.fromPure (value + 1)) =<< IsStream.tail stream

142 let stream2 = value `Stream.cons` stream1

143 Stream.parse (PR.takeStartBy (== value) Fold.drain) stream2

144

145takeFramedByEsc_ :: MonadThrow m => Int -> Stream m Char -> m ()

146takeFramedByEsc_ _ = Stream.parse parser

147

148 where

149

150 isEsc = (== '\\')

151 isBegin = (== '{')

152 isEnd = (== '}')

153

154 parser = PR.takeFramedByEsc_ isEsc isBegin isEnd Fold.drain

155

156{-# INLINE eqBy #-}

157eqBy :: Int -> Stream IO Int -> IO ()

158eqBy len = Stream.parse (PR.eqBy (==) [1 .. len])

159

160{-# INLINE matchBy #-}

161matchBy :: Int -> Stream IO Int -> IO ()

162matchBy len = Stream.parse (PR.matchBy (==) (Stream.enumerateFromTo 1 len))

163

164{-# INLINE takeWhile #-}

165takeWhile :: MonadThrow m => Int -> Stream m Int -> m ()

166takeWhile value = Stream.parse (PR.takeWhile (<= value) Fold.drain)

167

168takeWhileP :: MonadThrow m => Int -> Stream m Int -> m ()

169takeWhileP value =

170 Stream.parse (PR.takeWhileP (<= value) (PR.takeWhile (<= value - 1) Fold.drain))

171

172{-# INLINE takeP #-}

173takeP :: MonadThrow m => Int -> Stream m a -> m ()

174takeP value = Stream.parse (PR.takeP value (PR.fromFold Fold.drain))

175

176{-# INLINE groupBy #-}

177groupBy :: MonadThrow m => Stream m Int -> m ()

178groupBy = Stream.parse (PR.groupBy (<=) Fold.drain)

179

180{-# INLINE groupByRolling #-}

181groupByRolling :: MonadThrow m => Stream m Int -> m ()

182groupByRolling = Stream.parse (PR.groupByRolling (<=) Fold.drain)

183

184{-# INLINE wordBy #-}

185wordBy :: MonadThrow m => Int -> Stream m Int -> m ()

186wordBy value = Stream.parse (PR.wordBy (>= value) Fold.drain)

187

188{-# INLINE sepByWords #-}

189sepByWords :: MonadThrow m => Int -> Stream m Int -> m ()

190sepByWords _ = Stream.parse (wrds even Fold.drain)

191 where

192 wrds p = PR.sepBy (PR.takeWhile (not . p) Fold.drain) (PR.dropWhile p)

193

194{-# INLINE deintercalate #-}

195deintercalate :: MonadThrow m => Int -> Stream m Int -> m ()

196deintercalate _ = Stream.parse (partition even)

197

198 where

199

200 partition p =

201 PR.deintercalate

202 (PR.takeWhile (not . p) Fold.sum) (PR.takeWhile p Fold.sum) Fold.drain

203

204{-# INLINE manyWordByEven #-}

205manyWordByEven :: MonadThrow m => Stream m Int -> m ()

206manyWordByEven = Stream.parse (PR.many (PR.wordBy even Fold.drain) Fold.drain)

207

208{-# INLINE many #-}

209many :: MonadThrow m => Stream m Int -> m Int

210many = Stream.parse (PR.many (PR.satisfy (> 0)) Fold.length)

211

212{-# INLINE manyAlt #-}

213manyAlt :: MonadThrow m => Stream m Int -> m Int

214manyAlt xs = do

215 x <- Stream.parse (AP.many (PR.satisfy (> 0))) xs

216 return $ Prelude.length x

217

218{-# INLINE some #-}

219some :: MonadThrow m => Stream m Int -> m Int

220some = Stream.parse (PR.some (PR.satisfy (> 0)) Fold.length)

221

222{-# INLINE someAlt #-}

223someAlt :: MonadThrow m => Stream m Int -> m Int

224someAlt xs = do

225 x <- Stream.parse (AP.some (PR.satisfy (> 0))) xs

226 return $ Prelude.length x

227

228{-# INLINE manyTill #-}

229manyTill :: MonadThrow m => Int -> Stream m Int -> m Int

230manyTill value =

231 Stream.parse (PR.manyTill (PR.satisfy (> 0)) (PR.satisfy (== value)) Fold.length)

232

233{-# INLINE splitAp #-}

234splitAp :: MonadThrow m

235 => Int -> Stream m Int -> m ((), ())

236splitAp value =

237 Stream.parse

238 ((,)

239 <$> PR.dropWhile (<= (value `div` 2))

240 <*> PR.dropWhile (<= value)

241 )

242

243{-# INLINE splitApBefore #-}

244splitApBefore :: MonadThrow m

245 => Int -> Stream m Int -> m ()

246splitApBefore value =

247 Stream.parse

248 ( PR.dropWhile (<= (value `div` 2))

249 *> PR.dropWhile (<= value)

250 )

251

252{-# INLINE splitApAfter #-}

253splitApAfter :: MonadThrow m

254 => Int -> Stream m Int -> m ()

255splitApAfter value =

256 Stream.parse

257 ( PR.dropWhile (<= (value `div` 2))

258 <* PR.dropWhile (<= value)

259 )

260

261{-# INLINE serialWith #-}

262serialWith :: MonadThrow m

263 => Int -> Stream m Int -> m ((), ())

264serialWith value =

265 Stream.parse

266 (PR.serialWith (,)

267 (PR.dropWhile (<= (value `div` 2)))

268 (PR.dropWhile (<= value))

269 )

270

271{-# INLINE split_ #-}

272split_ :: MonadThrow m

273 => Int -> Stream m Int -> m ()

274split_ value =

275 Stream.parse

276 (PR.split_

277 (PR.dropWhile (<= (value `div` 2)))

278 (PR.dropWhile (<= value))

279 )

280

281{-# INLINE takeEndBy_ #-}

282takeEndBy_ :: MonadThrow m

283 => Int -> Stream m Int -> m()

284takeEndBy_ value = Stream.parse (PR.takeEndBy_ (>= value) (PR.fromFold Fold.drain))

285

286{-

287{-# INLINE teeAllAny #-}

288teeAllAny :: MonadThrow m

289 => Int -> Stream m Int -> m ((), ())

290teeAllAny value =

291 Stream.parse

292 (PR.teeWith (,)

293 (PR.dropWhile (<= value))

294 (PR.dropWhile (<= value))

295 )

296

297{-# INLINE teeFstAllAny #-}

298teeFstAllAny :: MonadThrow m

299 => Int -> Stream m Int -> m ((), ())

300teeFstAllAny value =

301 Stream.parse

302 (PR.teeWithFst (,)

303 (PR.dropWhile (<= value))

304 (PR.dropWhile (<= value))

305 )

306

307{-# INLINE shortestAllAny #-}

308shortestAllAny :: MonadThrow m

309 => Int -> Stream m Int -> m ()

310shortestAllAny value =

311 Stream.parse

312 (PR.shortest

313 (PR.dropWhile (<= value))

314 (PR.dropWhile (<= value))

315 )

316

317{-# INLINE longestAllAny #-}

318longestAllAny :: MonadThrow m

319 => Int -> Stream m Int -> m ()

320longestAllAny value =

321 Stream.parse

322 (PR.longest

323 (PR.dropWhile (<= value))

324 (PR.dropWhile (<= value))

325 )

326-}

327

328parseManyChunksOfSum :: Int -> Handle -> IO Int

329parseManyChunksOfSum n inh =

330 Stream.fold Fold.length

331 $ Stream.parseMany

332 (PR.fromFold $ Fold.take n Fold.sum)

333 (Stream.unfold Handle.read inh)

334

335-------------------------------------------------------------------------------

336-- Parsing with unfolds

337-------------------------------------------------------------------------------

338

339{-# INLINE parseManyUnfoldArrays #-}

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

341parseManyUnfoldArrays count arrays = do

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

343 let parser = PR.fromFold (Fold.take count Fold.drain)

344 let readSrc =

345 Source.producer

346 $ Producer.concat Producer.fromList Array.producer

347 let streamParser =

348 Producer.simplify (Source.parseMany parser readSrc)

349 Stream.fold Fold.drain $ Stream.unfold streamParser src

350

351-------------------------------------------------------------------------------

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

353-------------------------------------------------------------------------------

354

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

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

357-- not have to rely on it.

358--

359{-# INLINE lookAhead #-}

360lookAhead :: MonadThrow m => Int -> Stream m Int -> m ()

361lookAhead value =

362 Stream.parse (PR.lookAhead (PR.takeWhile (<= value) Fold.drain) $> ())

363

364{-# INLINE sequenceA #-}

365sequenceA :: MonadThrow m => Int -> Stream m Int -> m Int

366sequenceA value xs = do

367 x <- Stream.parse (TR.sequenceA (replicate value (PR.satisfy (> 0)))) xs

368 return $ length x

369

370{-# INLINE sequenceA_ #-}

371sequenceA_ :: MonadThrow m => Int -> Stream m Int -> m ()

372sequenceA_ value =

373 Stream.parse (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))

374

375{-# INLINE sequence #-}

376sequence :: MonadThrow m => Int -> Stream m Int -> m Int

377sequence value xs = do

378 x <- Stream.parse (TR.sequence (replicate value (PR.satisfy (> 0)))) xs

379 return $ length x

380

381{-# INLINE sequence_ #-}

382sequence_ :: MonadThrow m => Int -> Stream m Int -> m ()

383sequence_ value =

384 Stream.parse (F.sequence_ $ replicate value (PR.satisfy (> 0)))

385

386{-# INLINE choiceAsum #-}

387choiceAsum :: MonadThrow m => Int -> Stream m Int -> m Int

388choiceAsum value =

389 Stream.parse (asum (replicate value (PR.satisfy (< 0)))

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

391

392{-

393{-# INLINE choice #-}

394choice :: MonadThrow m => Int -> Stream m Int -> m Int

395choice value =

396 Stream.parse

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

398-}

399

400-------------------------------------------------------------------------------

401-- Stream transformation

402-------------------------------------------------------------------------------

403

404{-# INLINE parseMany #-}

405parseMany :: MonadThrow m => Int -> Stream m Int -> m ()

406parseMany n =

407 Stream.fold Fold.drain

408 . fmap getSum

409 . Stream.parseMany (PR.fromFold $ Fold.take n Fold.mconcat)

410 . fmap Sum

411

412{-# INLINE parseIterate #-}

413parseIterate :: MonadThrow m => Int -> Stream m Int -> m ()

414parseIterate n =

415 Stream.fold Fold.drain

416 . fmap getSum

417 . Stream.parseIterate (PR.fromFold . Fold.take n . Fold.sconcat) (Sum 0)

418 . fmap Sum

419

420{-# INLINE parseBreak #-}

421parseBreak :: MonadCatch m => Stream m Int -> m ()

422parseBreak s = do

423 r <- try $ Stream.parseBreak PR.one s

424 case r of

425 Left (_ :: SomeException) -> return ()

426 Right (_, s1) -> parseBreak s1

427

428{-# INLINE concatSequence #-}

429concatSequence :: MonadThrow m => Stream m Int -> m ()

430concatSequence = Stream.parse $ PR.concatSequence Fold.drain $ Stream.repeat PR.one

431

432{-# INLINE parseManyGroupBy #-}

433parseManyGroupBy :: MonadThrow m => (Int -> Int -> Bool) -> Stream m Int -> m ()

434parseManyGroupBy cmp =

435 Stream.fold Fold.drain . Stream.parseMany (PR.groupBy cmp Fold.drain)

436

437-------------------------------------------------------------------------------

438-- Benchmarks

439-------------------------------------------------------------------------------

440

441moduleName :: String

442moduleName = "Data.Parser"

443

444o_1_space_serial :: Int -> [Benchmark]

445o_1_space_serial value =

446 [ benchIOSink value "one (fold)" $ one value

447 , benchIOSink value "takeBetween" $ takeBetween value

448 , benchIOSink value "takeEQ" $ takeEQ value

449 , benchIOSink value "takeWhile" $ takeWhile value

450 , benchIOSink value "takeWhileP" $ takeWhileP value

451 , benchIOSink value "takeP" $ takeP value

452 , benchIOSink value "dropWhile" $ dropWhile value

453 , benchIOSink value "takeStartBy" $ takeStartBy value

454 , benchIOSrc sourceEscapedFrames value "takeFramedByEsc_"

455 $ takeFramedByEsc_ value

456 , benchIOSink value "groupBy" $ groupBy

457 , benchIOSink value "groupByRolling" $ groupByRolling

458 , benchIOSink value "wordBy" $ wordBy value

459 , benchIOSink value "sepBy (words)" $ sepByWords value

460 , benchIOSink value "deintercalate" $ deintercalate value

461 , benchIOSink value "splitAp" $ splitAp value

462 , benchIOSink value "splitApBefore" $ splitApBefore value

463 , benchIOSink value "splitApAfter" $ splitApAfter value

464 , benchIOSink value "serialWith" $ serialWith value

465 , benchIOSink value "takeEndBy_" $ takeEndBy_ value

466 , benchIOSink value "many" many

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

468 , benchIOSink value "some" some

469 , benchIOSink value "manyTill" $ manyTill value

470 {-

471 , benchIOSink value "tee" $ teeAllAny value

472 , benchIOSink value "teeFst" $ teeFstAllAny value

473 , benchIOSink value "shortest" $ shortestAllAny value

474 , benchIOSink value "longest" $ longestAllAny value

475 -}

476 , benchIOSink value "parseBreak (recursive)" parseBreak

477 , benchIOSink value "parseMany (take 1)" (parseMany 1)

478 , benchIOSink value "parseMany (take all)" (parseMany value)

479 , benchIOSink value "parseIterate (take 1)" (parseIterate 1)

480 , benchIOSink value "parseIterate (take all)" (parseIterate value)

481 , benchIOSink value "concatSequence" concatSequence

482 , benchIOSink value "parseMany (groupBy (<))" (parseManyGroupBy (<))

483 , benchIOSink value "parseMany (groupBy (==))" (parseManyGroupBy (==))

484 , benchIOSink value "eqBy" (eqBy value)

485 , benchIOSink value "matchBy" (matchBy value)

486 ]

487

488o_1_space_filesystem :: BenchEnv -> [Benchmark]

489o_1_space_filesystem env =

490 [ mkBench ("S.parseMany (Fold.take " ++ show (bigSize env) ++ " Fold.sum)") env

491 $ \inh _ -> noinline parseManyChunksOfSum (bigSize env) inh

492 , mkBench "S.parseMany (Fold.take 1 Fold.sum)" env

493 $ \inh _ -> inline parseManyChunksOfSum 1 inh

494 ]

495

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

497o_1_space_serial_unfold bound arrays =

498 [ bench "parseMany/Unfold/1000 arrays/take all"

499 $ nfIO $ parseManyUnfoldArrays bound arrays

500 , bench "parseMany/Unfold/1000 arrays/take 1"

501 $ nfIO $ parseManyUnfoldArrays 1 arrays

502 ]

503

504o_n_heap_serial :: Int -> [Benchmark]

505o_n_heap_serial value =

506 [

507 -- lookahead benchmark holds the entire input till end

508 benchIOSink value "lookAhead" $ lookAhead value

509

510 -- accumulates the results in a list

511 , benchIOSink value "sequence" $ sequence value

512 , benchIOSink value "sequenceA" $ sequenceA value

513

514 -- XXX why should this take O(n) heap, it discards the results?

515 , benchIOSink value "sequence_" $ sequence_ value

516 , benchIOSink value "sequenceA_" $ sequenceA_ value

517 -- non-linear time complexity (parserD)

518 , benchIOSink value "split_" $ split_ value

519 -- XXX why O(n) heap?

520 , benchIOSink value "choice (asum)" $ choiceAsum value

521 -- , benchIOSink value "choice" $ choice value

522

523 -- These show non-linear time complexity.

524 -- They accumulate the results in a list.

525 , benchIOSink value "manyAlt" manyAlt

526 , benchIOSink value "someAlt" someAlt

527 ]

528

529-------------------------------------------------------------------------------

530-- Driver

531-------------------------------------------------------------------------------

532

533main :: IO ()

534main = do

535 env <- mkHandleBenchEnv

536 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

537

538 where

539

540 alloc value = Stream.fold Fold.toList $ Stream.arraysOf 100 $ sourceUnfoldrM value 0

541

542 allBenchmarks env arrays value =

543 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

544 , bgroup

545 (o_1_space_prefix moduleName ++ "/filesystem")

546 (o_1_space_filesystem env)

547 , bgroup (o_1_space_prefix moduleName)

548 (o_1_space_serial_unfold value arrays)

549 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

550 ]