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

git.iko.soy/streamly

on 3a90efb help sign in

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

540 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 takeWhile #-}

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

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

159

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

161takeWhileP value =

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

163

164{-# INLINE takeP #-}

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

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

167

168{-# INLINE groupBy #-}

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

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

171

172{-# INLINE groupByRolling #-}

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

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

175

176{-# INLINE wordBy #-}

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

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

179

180{-# INLINE sepByWords #-}

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

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

183 where

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

185

186{-# INLINE deintercalate #-}

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

188deintercalate _ = Stream.parse (partition even)

189

190 where

191

192 partition p =

193 PR.deintercalate

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

195

196{-# INLINE manyWordByEven #-}

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

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

199

200{-# INLINE many #-}

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

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

203

204{-# INLINE manyAlt #-}

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

206manyAlt xs = do

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

208 return $ Prelude.length x

209

210{-# INLINE some #-}

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

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

213

214{-# INLINE someAlt #-}

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

216someAlt xs = do

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

218 return $ Prelude.length x

219

220{-# INLINE manyTill #-}

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

222manyTill value =

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

224

225{-# INLINE splitAp #-}

226splitAp :: MonadThrow m

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

228splitAp value =

229 Stream.parse

230 ((,)

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

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

233 )

234

235{-# INLINE splitApBefore #-}

236splitApBefore :: MonadThrow m

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

238splitApBefore value =

239 Stream.parse

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

241 *> PR.dropWhile (<= value)

242 )

243

244{-# INLINE splitApAfter #-}

245splitApAfter :: MonadThrow m

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

247splitApAfter value =

248 Stream.parse

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

250 <* PR.dropWhile (<= value)

251 )

252

253{-# INLINE serialWith #-}

254serialWith :: MonadThrow m

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

256serialWith value =

257 Stream.parse

258 (PR.serialWith (,)

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

260 (PR.dropWhile (<= value))

261 )

262

263{-# INLINE split_ #-}

264split_ :: MonadThrow m

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

266split_ value =

267 Stream.parse

268 (PR.split_

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

270 (PR.dropWhile (<= value))

271 )

272

273{-# INLINE takeEndBy_ #-}

274takeEndBy_ :: MonadThrow m

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

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

277

278{-

279{-# INLINE teeAllAny #-}

280teeAllAny :: MonadThrow m

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

282teeAllAny value =

283 Stream.parse

284 (PR.teeWith (,)

285 (PR.dropWhile (<= value))

286 (PR.dropWhile (<= value))

287 )

288

289{-# INLINE teeFstAllAny #-}

290teeFstAllAny :: MonadThrow m

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

292teeFstAllAny value =

293 Stream.parse

294 (PR.teeWithFst (,)

295 (PR.dropWhile (<= value))

296 (PR.dropWhile (<= value))

297 )

298

299{-# INLINE shortestAllAny #-}

300shortestAllAny :: MonadThrow m

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

302shortestAllAny value =

303 Stream.parse

304 (PR.shortest

305 (PR.dropWhile (<= value))

306 (PR.dropWhile (<= value))

307 )

308

309{-# INLINE longestAllAny #-}

310longestAllAny :: MonadThrow m

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

312longestAllAny value =

313 Stream.parse

314 (PR.longest

315 (PR.dropWhile (<= value))

316 (PR.dropWhile (<= value))

317 )

318-}

319

320parseManyChunksOfSum :: Int -> Handle -> IO Int

321parseManyChunksOfSum n inh =

322 Stream.fold Fold.length

323 $ Stream.parseMany

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

325 (Stream.unfold Handle.read inh)

326

327-------------------------------------------------------------------------------

328-- Parsing with unfolds

329-------------------------------------------------------------------------------

330

331{-# INLINE parseManyUnfoldArrays #-}

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

333parseManyUnfoldArrays count arrays = do

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

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

336 let readSrc =

337 Source.producer

338 $ Producer.concat Producer.fromList Array.producer

339 let streamParser =

340 Producer.simplify (Source.parseMany parser readSrc)

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

342

343-------------------------------------------------------------------------------

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

345-------------------------------------------------------------------------------

346

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

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

349-- not have to rely on it.

350--

351{-# INLINE lookAhead #-}

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

353lookAhead value =

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

355

356{-# INLINE sequenceA #-}

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

358sequenceA value xs = do

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

360 return $ length x

361

362{-# INLINE sequenceA_ #-}

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

364sequenceA_ value =

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

366

367{-# INLINE sequence #-}

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

369sequence value xs = do

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

371 return $ length x

372

373{-# INLINE sequence_ #-}

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

375sequence_ value =

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

377

378{-# INLINE choiceAsum #-}

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

380choiceAsum value =

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

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

383

384{-

385{-# INLINE choice #-}

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

387choice value =

388 Stream.parse

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

390-}

391

392-------------------------------------------------------------------------------

393-- Stream transformation

394-------------------------------------------------------------------------------

395

396{-# INLINE parseMany #-}

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

398parseMany n =

399 Stream.fold Fold.drain

400 . fmap getSum

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

402 . fmap Sum

403

404{-# INLINE parseIterate #-}

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

406parseIterate n =

407 Stream.fold Fold.drain

408 . fmap getSum

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

410 . fmap Sum

411

412{-# INLINE parseBreak #-}

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

414parseBreak s = do

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

416 case r of

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

418 Right (_, s1) -> parseBreak s1

419

420{-# INLINE concatSequence #-}

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

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

423

424{-# INLINE parseManyGroupBy #-}

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

426parseManyGroupBy cmp =

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

428

429-------------------------------------------------------------------------------

430-- Benchmarks

431-------------------------------------------------------------------------------

432

433moduleName :: String

434moduleName = "Data.Parser"

435

436o_1_space_serial :: Int -> [Benchmark]

437o_1_space_serial value =

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

439 , benchIOSink value "takeBetween" $ takeBetween value

440 , benchIOSink value "takeEQ" $ takeEQ value

441 , benchIOSink value "takeWhile" $ takeWhile value

442 , benchIOSink value "takeWhileP" $ takeWhileP value

443 , benchIOSink value "takeP" $ takeP value

444 , benchIOSink value "dropWhile" $ dropWhile value

445 , benchIOSink value "takeStartBy" $ takeStartBy value

446 , benchIOSrc sourceEscapedFrames value "takeFramedByEsc_"

447 $ takeFramedByEsc_ value

448 , benchIOSink value "groupBy" $ groupBy

449 , benchIOSink value "groupByRolling" $ groupByRolling

450 , benchIOSink value "wordBy" $ wordBy value

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

452 , benchIOSink value "deintercalate" $ deintercalate value

453 , benchIOSink value "splitAp" $ splitAp value

454 , benchIOSink value "splitApBefore" $ splitApBefore value

455 , benchIOSink value "splitApAfter" $ splitApAfter value

456 , benchIOSink value "serialWith" $ serialWith value

457 , benchIOSink value "takeEndBy_" $ takeEndBy_ value

458 , benchIOSink value "many" many

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

460 , benchIOSink value "some" some

461 , benchIOSink value "manyTill" $ manyTill value

462 {-

463 , benchIOSink value "tee" $ teeAllAny value

464 , benchIOSink value "teeFst" $ teeFstAllAny value

465 , benchIOSink value "shortest" $ shortestAllAny value

466 , benchIOSink value "longest" $ longestAllAny value

467 -}

468 , benchIOSink value "parseBreak (recursive)" parseBreak

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

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

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

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

473 , benchIOSink value "concatSequence" concatSequence

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

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

476 ]

477

478o_1_space_filesystem :: BenchEnv -> [Benchmark]

479o_1_space_filesystem env =

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

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

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

483 $ \inh _ -> inline parseManyChunksOfSum 1 inh

484 ]

485

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

487o_1_space_serial_unfold bound arrays =

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

489 $ nfIO $ parseManyUnfoldArrays bound arrays

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

491 $ nfIO $ parseManyUnfoldArrays 1 arrays

492 ]

493

494o_n_heap_serial :: Int -> [Benchmark]

495o_n_heap_serial value =

496 [

497 -- lookahead benchmark holds the entire input till end

498 benchIOSink value "lookAhead" $ lookAhead value

499

500 -- accumulates the results in a list

501 , benchIOSink value "sequence" $ sequence value

502 , benchIOSink value "sequenceA" $ sequenceA value

503

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

505 , benchIOSink value "sequence_" $ sequence_ value

506 , benchIOSink value "sequenceA_" $ sequenceA_ value

507 -- non-linear time complexity (parserD)

508 , benchIOSink value "split_" $ split_ value

509 -- XXX why O(n) heap?

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

511 -- , benchIOSink value "choice" $ choice value

512

513 -- These show non-linear time complexity.

514 -- They accumulate the results in a list.

515 , benchIOSink value "manyAlt" manyAlt

516 , benchIOSink value "someAlt" someAlt

517 ]

518

519-------------------------------------------------------------------------------

520-- Driver

521-------------------------------------------------------------------------------

522

523main :: IO ()

524main = do

525 env <- mkHandleBenchEnv

526 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

527

528 where

529

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

531

532 allBenchmarks env arrays value =

533 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

534 , bgroup

535 (o_1_space_prefix moduleName ++ "/filesystem")

536 (o_1_space_filesystem env)

537 , bgroup (o_1_space_prefix moduleName)

538 (o_1_space_serial_unfold value arrays)

539 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

540 ]