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

git.iko.soy/streamly

on fe28607 help sign in

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

552 lines 18 kB history raw

1{-# OPTIONS_GHC -Wno-deprecations #-}

3-- |

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

6--

7-- License : BSD-3-Clause

8-- Maintainer : streamly@composewell.com

10{-# LANGUAGE CPP #-}

11{-# LANGUAGE FlexibleContexts #-}

12{-# LANGUAGE ScopedTypeVariables #-}

14module Main

15 (

16 main

17 ) where

19import Control.DeepSeq (NFData(..))

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

21import Data.Foldable (asum)

22import Data.Functor (($>))

23import Data.Maybe (fromMaybe)

24import Data.Monoid (Sum(..))

25import GHC.Magic (inline)

26import GHC.Magic (noinline)

27import System.IO (Handle)

28import System.Random (randomRIO)

29import Prelude hiding

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

32import qualified Data.Traversable as TR

33import qualified Data.Foldable as F

34import qualified Control.Applicative as AP

35import qualified Streamly.FileSystem.Handle as Handle

36import qualified Streamly.Internal.Data.Array as Array

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

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

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

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

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

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

44import Gauge hiding (env)

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

46import Streamly.Benchmark.Common

47import Streamly.Benchmark.Common.Handle

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

50-- Utilities

51-------------------------------------------------------------------------------

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

55{-# INLINE sourceUnfoldrM #-}

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

57sourceUnfoldrM value n = Stream.unfoldrM step n

58 where

59 step cnt =

60 if cnt > n + value

61 then return Nothing

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

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

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

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

67-- sequence of `}`.

68{-# INLINE sourceEscapedFrames #-}

69sourceEscapedFrames ::

70 Monad m

71 => Int

72 -> Int

73 -> Stream m Char

74sourceEscapedFrames value n = Stream.unfoldrM step n

75 where

77 bs = '\\'

78 cbOpen = '{'

79 cbClose = '}'

80 value1 = value `div` 4

82 step cnt

83 | cnt > 4 * value1 = return Nothing

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

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

86 | otherwise =

87 return

88 $ Just

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

90 then (bs, cnt + 1)

91 else (cbOpen, cnt + 1)

93{-# INLINE benchIOSrc #-}

94benchIOSrc

95 :: NFData b

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

97 -> Int

98 -> String

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

100 -> Benchmark

101benchIOSrc src value name f =

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

103

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

105{-# INLINE benchIOSink #-}

106benchIOSink

107 :: NFData b

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

109benchIOSink value name f =

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

111

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

113-- Parsers

114-------------------------------------------------------------------------------

115

116{-# INLINE one #-}

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

118one value = Stream.parse p

119

120 where

121

122 p = do

123 m <- PR.fromFold Fold.one

124 case m of

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

126 Nothing -> pure Nothing

127

128{-# INLINE takeBetween #-}

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

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

131

132{-# INLINE takeEQ #-}

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

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

135

136{-# INLINE dropWhile #-}

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

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

139

140{-# INLINE takeStartBy #-}

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

142takeStartBy value stream = do

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

144 let stream2 = value `Stream.cons` stream1

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

146

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

148takeFramedByEsc_ _ = Stream.parse parser

149

150 where

151

152 isEsc = (== '\\')

153 isBegin = (== '{')

154 isEnd = (== '}')

155

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

157

158{-# INLINE listEqBy #-}

159listEqBy :: Int -> Stream IO Int -> IO [Int]

160listEqBy len = Stream.parse (PR.listEqBy (==) [1 .. len])

161

162{-# INLINE eqBy #-}

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

164eqBy len = Stream.parse (PR.eqBy (==) (Stream.enumerateFromTo 1 len))

165

166{-# INLINE takeWhile #-}

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

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

169

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

171takeWhileP value =

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

173

174{-# INLINE takeP #-}

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

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

177

178{-# INLINE groupBy #-}

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

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

181

182{-# INLINE groupByRolling #-}

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

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

185

186{-# INLINE wordBy #-}

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

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

189

190{-# INLINE sepByWords #-}

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

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

193 where

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

195

196{-# INLINE deintercalate #-}

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

198deintercalate _ = Stream.parse (partition even)

199

200 where

201

202 partition p =

203 PR.deintercalate

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

205

206{-# INLINE manyWordByEven #-}

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

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

209

210{-# INLINE many #-}

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

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

213

214{-# INLINE manyAlt #-}

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

216manyAlt xs = do

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

218 return $ Prelude.length x

219

220{-# INLINE some #-}

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

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

223

224{-# INLINE someAlt #-}

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

226someAlt xs = do

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

228 return $ Prelude.length x

229

230{-# INLINE manyTill #-}

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

232manyTill value =

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

234

235{-# INLINE splitAp #-}

236splitAp :: MonadThrow m

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

238splitAp value =

239 Stream.parse

240 ((,)

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

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

243 )

244

245{-# INLINE splitApBefore #-}

246splitApBefore :: MonadThrow m

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

248splitApBefore value =

249 Stream.parse

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

251 *> PR.dropWhile (<= value)

252 )

253

254{-# INLINE splitApAfter #-}

255splitApAfter :: MonadThrow m

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

257splitApAfter value =

258 Stream.parse

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

260 <* PR.dropWhile (<= value)

261 )

262

263{-# INLINE splitWith #-}

264splitWith :: MonadThrow m

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

266splitWith value =

267 Stream.parse

268 (PR.splitWith (,)

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

270 (PR.dropWhile (<= value))

271 )

272

273{-# INLINE split_ #-}

274split_ :: MonadThrow m

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

276split_ value =

277 Stream.parse

278 (PR.split_

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

280 (PR.dropWhile (<= value))

281 )

282

283{-# INLINE takeEndBy_ #-}

284takeEndBy_ :: MonadThrow m

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

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

287

288{-

289{-# INLINE teeAllAny #-}

290teeAllAny :: MonadThrow m

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

292teeAllAny value =

293 Stream.parse

294 (PR.teeWith (,)

295 (PR.dropWhile (<= value))

296 (PR.dropWhile (<= value))

297 )

298

299{-# INLINE teeFstAllAny #-}

300teeFstAllAny :: MonadThrow m

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

302teeFstAllAny value =

303 Stream.parse

304 (PR.teeWithFst (,)

305 (PR.dropWhile (<= value))

306 (PR.dropWhile (<= value))

307 )

308

309{-# INLINE shortestAllAny #-}

310shortestAllAny :: MonadThrow m

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

312shortestAllAny value =

313 Stream.parse

314 (PR.shortest

315 (PR.dropWhile (<= value))

316 (PR.dropWhile (<= value))

317 )

318

319{-# INLINE longestAllAny #-}

320longestAllAny :: MonadThrow m

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

322longestAllAny value =

323 Stream.parse

324 (PR.longest

325 (PR.dropWhile (<= value))

326 (PR.dropWhile (<= value))

327 )

328-}

329

330parseManyChunksOfSum :: Int -> Handle -> IO Int

331parseManyChunksOfSum n inh =

332 Stream.fold Fold.length

333 $ Stream.parseMany

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

335 (Stream.unfold Handle.reader inh)

336

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

338-- Parsing with unfolds

339-------------------------------------------------------------------------------

340

341{-# INLINE parseManyUnfoldArrays #-}

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

343parseManyUnfoldArrays count arrays = do

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

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

346 let readSrc =

347 Source.producer

348 $ Producer.concat Producer.fromList Array.producer

349 let streamParser =

350 Producer.simplify (Source.parseMany parser readSrc)

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

352

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

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

355-------------------------------------------------------------------------------

356

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

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

359-- not have to rely on it.

360--

361{-# INLINE lookAhead #-}

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

363lookAhead value =

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

365

366{-# INLINE sequenceA #-}

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

368sequenceA value xs = do

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

370 return $ length x

371

372{-# INLINE sequenceA_ #-}

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

374sequenceA_ value =

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

376

377{-# INLINE sequence #-}

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

379sequence value xs = do

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

381 return $ length x

382

383{-# INLINE sequence_ #-}

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

385sequence_ value =

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

387

388{-# INLINE choiceAsum #-}

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

390choiceAsum value =

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

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

393

394{-

395{-# INLINE choice #-}

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

397choice value =

398 Stream.parse

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

400-}

401

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

403-- Stream transformation

404-------------------------------------------------------------------------------

405

406{-# INLINE parseMany #-}

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

408parseMany n =

409 Stream.fold Fold.drain

410 . fmap getSum

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

412 . fmap Sum

413

414{-# INLINE parseIterate #-}

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

416parseIterate n =

417 Stream.fold Fold.drain

418 . fmap getSum

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

420 . fmap Sum

421

422{-# INLINE parseBreak #-}

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

424parseBreak s = do

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

426 case r of

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

428 Right (_, s1) -> parseBreak s1

429

430{-# INLINE concatSequence #-}

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

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

433

434{-# INLINE parseManyGroupBy #-}

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

436parseManyGroupBy cmp =

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

438

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

440-- Benchmarks

441-------------------------------------------------------------------------------

442

443moduleName :: String

444moduleName = "Data.Parser"

445

446o_1_space_serial :: Int -> [Benchmark]

447o_1_space_serial value =

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

449 , benchIOSink value "takeBetween" $ takeBetween value

450 , benchIOSink value "takeEQ" $ takeEQ value

451 , benchIOSink value "takeWhile" $ takeWhile value

452 , benchIOSink value "takeWhileP" $ takeWhileP value

453 , benchIOSink value "takeP" $ takeP value

454 , benchIOSink value "dropWhile" $ dropWhile value

455 , benchIOSink value "takeStartBy" $ takeStartBy value

456 , benchIOSrc sourceEscapedFrames value "takeFramedByEsc_"

457 $ takeFramedByEsc_ value

458 , benchIOSink value "groupBy" $ groupBy

459 , benchIOSink value "groupByRolling" $ groupByRolling

460 , benchIOSink value "wordBy" $ wordBy value

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

462 , benchIOSink value "deintercalate" $ deintercalate value

463 , benchIOSink value "splitAp" $ splitAp value

464 , benchIOSink value "splitApBefore" $ splitApBefore value

465 , benchIOSink value "splitApAfter" $ splitApAfter value

466 , benchIOSink value "splitWith" $ splitWith value

467 , benchIOSink value "takeEndBy_" $ takeEndBy_ value

468 , benchIOSink value "many" many

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

470 , benchIOSink value "some" some

471 , benchIOSink value "manyTill" $ manyTill value

472 {-

473 , benchIOSink value "tee" $ teeAllAny value

474 , benchIOSink value "teeFst" $ teeFstAllAny value

475 , benchIOSink value "shortest" $ shortestAllAny value

476 , benchIOSink value "longest" $ longestAllAny value

477 -}

478 , benchIOSink value "parseBreak (recursive)" parseBreak

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

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

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

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

483 , benchIOSink value "concatSequence" concatSequence

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

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

486 , benchIOSink value "listEqBy" (listEqBy value)

487 , benchIOSink value "eqBy" (eqBy value)

488 ]

489

490o_1_space_filesystem :: BenchEnv -> [Benchmark]

491o_1_space_filesystem env =

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

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

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

495 $ \inh _ -> inline parseManyChunksOfSum 1 inh

496 ]

497

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

499o_1_space_serial_unfold bound arrays =

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

501 $ nfIO $ parseManyUnfoldArrays bound arrays

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

503 $ nfIO $ parseManyUnfoldArrays 1 arrays

504 ]

505

506o_n_heap_serial :: Int -> [Benchmark]

507o_n_heap_serial value =

508 [

509 -- lookahead benchmark holds the entire input till end

510 benchIOSink value "lookAhead" $ lookAhead value

511

512 -- accumulates the results in a list

513 , benchIOSink value "sequence" $ sequence value

514 , benchIOSink value "sequenceA" $ sequenceA value

515

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

517 , benchIOSink value "sequence_" $ sequence_ value

518 , benchIOSink value "sequenceA_" $ sequenceA_ value

519 -- non-linear time complexity (parserD)

520 , benchIOSink value "split_" $ split_ value

521 -- XXX why O(n) heap?

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

523 -- , benchIOSink value "choice" $ choice value

524

525 -- These show non-linear time complexity.

526 -- They accumulate the results in a list.

527 , benchIOSink value "manyAlt" manyAlt

528 , benchIOSink value "someAlt" someAlt

529 ]

530

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

532-- Driver

533-------------------------------------------------------------------------------

534

535main :: IO ()

536main = do

537 env <- mkHandleBenchEnv

538 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

539

540 where

541

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

543

544 allBenchmarks env arrays value =

545 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

546 , bgroup

547 (o_1_space_prefix moduleName ++ "/filesystem")

548 (o_1_space_filesystem env)

549 , bgroup (o_1_space_prefix moduleName)

550 (o_1_space_serial_unfold value arrays)

551 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

552 ]