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

git.iko.soy/streamly

on cd67584 help sign in

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

533 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-------------------------------------------------------------------------------

425-- Benchmarks

426-------------------------------------------------------------------------------

427

428moduleName :: String

429moduleName = "Data.Parser"

430

431o_1_space_serial :: Int -> [Benchmark]

432o_1_space_serial value =

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

434 , benchIOSink value "takeBetween" $ takeBetween value

435 , benchIOSink value "takeEQ" $ takeEQ value

436 , benchIOSink value "takeWhile" $ takeWhile value

437 , benchIOSink value "takeWhileP" $ takeWhileP value

438 , benchIOSink value "takeP" $ takeP value

439 , benchIOSink value "dropWhile" $ dropWhile value

440 , benchIOSink value "takeStartBy" $ takeStartBy value

441 , benchIOSrc sourceEscapedFrames value "takeFramedByEsc_"

442 $ takeFramedByEsc_ value

443 , benchIOSink value "groupBy" $ groupBy

444 , benchIOSink value "groupByRolling" $ groupByRolling

445 , benchIOSink value "wordBy" $ wordBy value

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

447 , benchIOSink value "deintercalate" $ deintercalate value

448 , benchIOSink value "splitAp" $ splitAp value

449 , benchIOSink value "splitApBefore" $ splitApBefore value

450 , benchIOSink value "splitApAfter" $ splitApAfter value

451 , benchIOSink value "serialWith" $ serialWith value

452 , benchIOSink value "takeEndBy_" $ takeEndBy_ value

453 , benchIOSink value "many" many

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

455 , benchIOSink value "some" some

456 , benchIOSink value "manyTill" $ manyTill value

457 {-

458 , benchIOSink value "tee" $ teeAllAny value

459 , benchIOSink value "teeFst" $ teeFstAllAny value

460 , benchIOSink value "shortest" $ shortestAllAny value

461 , benchIOSink value "longest" $ longestAllAny value

462 -}

463 , benchIOSink value "parseBreak (recursive)" parseBreak

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

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

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

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

468 , benchIOSink value "concatSequence" concatSequence

469 ]

470

471o_1_space_filesystem :: BenchEnv -> [Benchmark]

472o_1_space_filesystem env =

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

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

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

476 $ \inh _ -> inline parseManyChunksOfSum 1 inh

477 ]

478

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

480o_1_space_serial_unfold bound arrays =

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

482 $ nfIO $ parseManyUnfoldArrays bound arrays

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

484 $ nfIO $ parseManyUnfoldArrays 1 arrays

485 ]

486

487o_n_heap_serial :: Int -> [Benchmark]

488o_n_heap_serial value =

489 [

490 -- lookahead benchmark holds the entire input till end

491 benchIOSink value "lookAhead" $ lookAhead value

492

493 -- accumulates the results in a list

494 , benchIOSink value "sequence" $ sequence value

495 , benchIOSink value "sequenceA" $ sequenceA value

496

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

498 , benchIOSink value "sequence_" $ sequence_ value

499 , benchIOSink value "sequenceA_" $ sequenceA_ value

500 -- non-linear time complexity (parserD)

501 , benchIOSink value "split_" $ split_ value

502 -- XXX why O(n) heap?

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

504 -- , benchIOSink value "choice" $ choice value

505

506 -- These show non-linear time complexity.

507 -- They accumulate the results in a list.

508 , benchIOSink value "manyAlt" manyAlt

509 , benchIOSink value "someAlt" someAlt

510 ]

511

512-------------------------------------------------------------------------------

513-- Driver

514-------------------------------------------------------------------------------

515

516main :: IO ()

517main = do

518 env <- mkHandleBenchEnv

519 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

520

521 where

522

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

524

525 allBenchmarks env arrays value =

526 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

527 , bgroup

528 (o_1_space_prefix moduleName ++ "/filesystem")

529 (o_1_space_filesystem env)

530 , bgroup (o_1_space_prefix moduleName)

531 (o_1_space_serial_unfold value arrays)

532 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

533 ]