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

git.iko.soy/streamly

on 4eaeb10 help sign in

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

455 lines 16 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 (MonadThrow)

19import Data.Foldable (asum)

20import Data.Function ((&))

21import Data.Functor (($>))

22import Data.Maybe (fromMaybe)

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

24import System.Random (randomRIO)

25import Prelude hiding (any, all, take, sequence, sequenceA, sequence_, takeWhile, span)

27import qualified Data.Traversable as TR

28import qualified Data.Foldable as F

29import qualified Control.Applicative as AP

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

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

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

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

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

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

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

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

39import Gauge

40import Streamly.Benchmark.Common

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

43-- Utilities

44-------------------------------------------------------------------------------

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

48{-# INLINE sourceUnfoldrM #-}

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

50sourceUnfoldrM value n = Stream.unfoldrM step n

51 where

52 step cnt =

53 if cnt > n + value

54 then return Nothing

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

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

58{-# INLINE benchIOSink #-}

59benchIOSink

60 :: (NFData b)

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

62benchIOSink value name f =

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

65-------------------------------------------------------------------------------

66-- Parsers

67-------------------------------------------------------------------------------

69{-# INLINE eqBy #-}

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

71eqBy len = Stream.parseD (PR.eqBy (==) [1 .. len])

73{-# INLINE matchBy #-}

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

75matchBy len = Stream.parseD (PR.matchBy (==) (D.enumerateFromToIntegral 1 len))

77{-# INLINE drainWhile #-}

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

79drainWhile p = PR.takeWhile p Fold.drain

81{-# INLINE takeStartBy #-}

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

83takeStartBy value stream = do

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

85 let stream2 = value `Stream.cons` stream1

86 Stream.parseD (PR.takeStartBy (== value) Fold.drain) stream2

88{-# INLINE takeWhile #-}

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

90takeWhile value = Stream.parseD (drainWhile (<= value))

92{-# INLINE takeP #-}

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

94takeP value = Stream.parseD (PR.takeP value (PR.fromFold Fold.drain))

96{-# INLINE takeBetween #-}

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

98takeBetween value = Stream.parseD (PR.takeBetween 0 value Fold.drain)

100{-# INLINE groupBy #-}

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

102groupBy = Stream.parseD (PR.groupBy (<=) Fold.drain)

103

104{-# INLINE groupByRolling #-}

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

106groupByRolling = Stream.parseD (PR.groupByRolling (<=) Fold.drain)

107

108{-# INLINE wordBy #-}

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

110wordBy value = Stream.parseD (PR.wordBy (>= value) Fold.drain)

111

112{-# INLINE manyWordByEven #-}

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

114manyWordByEven =

115 Stream.parseD (PR.many (PR.wordBy (Prelude.even) Fold.drain) Fold.drain)

116

117{-# INLINE many #-}

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

119many = Stream.parseD (PR.many (PR.satisfy (> 0)) Fold.length)

120

121{-# INLINE manyAlt #-}

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

123manyAlt xs = do

124 x <- Stream.parseD (AP.many (PR.satisfy (> 0))) xs

125 return $ Prelude.length x

126

127{-# INLINE some #-}

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

129some = Stream.parseD (PR.some (PR.satisfy (> 0)) Fold.length)

130

131{-# INLINE someAlt #-}

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

133someAlt xs = do

134 x <- Stream.parseD (AP.some (PR.satisfy (> 0))) xs

135 return $ Prelude.length x

136

137{-#INLINE takeEndBy_ #-}

138takeEndBy_ :: MonadThrow m => Int -> Stream m Int -> m ()

139takeEndBy_ value = Stream.parseD (PR.takeEndBy_ (>= value) (PR.fromFold Fold.drain))

140

141{-# INLINE manyTill #-}

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

143manyTill value =

144 let p = PR.satisfy (> 0)

145 pcond = PR.satisfy (== value)

146 in Stream.parseD (PR.manyTill p pcond Fold.length)

147

148{-# INLINE serialWith #-}

149serialWith :: MonadThrow m

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

151serialWith value =

152 Stream.parseD

153 ((,)

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

155 <*> drainWhile (<= value)

156 )

157

158{-

159{-# INLINE teeAllAny #-}

160teeAllAny :: MonadThrow m

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

162teeAllAny value =

163 Stream.parseD

164 (PR.teeWith (,)

165 (drainWhile (<= value))

166 (drainWhile (<= value))

167 )

168

169{-# INLINE teeFstAllAny #-}

170teeFstAllAny :: MonadThrow m

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

172teeFstAllAny value =

173 Stream.parseD

174 (PR.teeWithFst (,)

175 (drainWhile (<= value))

176 (drainWhile (<= value))

177 )

178

179{-# INLINE shortestAllAny #-}

180shortestAllAny :: MonadThrow m

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

182shortestAllAny value =

183 Stream.parseD

184 (PR.shortest

185 (drainWhile (<= value))

186 (drainWhile (<= value))

187 )

188

189{-# INLINE longestAllAny #-}

190longestAllAny :: MonadThrow m

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

192longestAllAny value =

193 Stream.parseD

194 (PR.longest

195 (drainWhile (<= value))

196 (drainWhile (<= value))

197 )

198-}

199

200{-# INLINE sequenceParser #-}

201sequenceParser :: MonadThrow m => Stream m Int -> m ()

202sequenceParser = Stream.parseD (PR.sequence (D.repeat (PR.satisfy $ const True)) Fold.drain)

203

204-------------------------------------------------------------------------------

205-- Spanning

206-------------------------------------------------------------------------------

207

208{-# INLINE span #-}

209span :: MonadThrow m => Int -> Stream m Int -> m ((), ())

210span value = Stream.parseD (PR.span (<= (value `div` 2)) Fold.drain Fold.drain)

211

212{-# INLINE spanBy #-}

213spanBy :: MonadThrow m => Int -> Stream m Int -> m ((), ())

214spanBy value =

215 Stream.parseD (PR.spanBy (\_ i -> i <= (value `div` 2)) Fold.drain Fold.drain)

216

217{-# INLINE spanByRolling #-}

218spanByRolling :: MonadThrow m => Int -> Stream m Int -> m ((), ())

219spanByRolling value =

220 Stream.parseD (PR.spanByRolling (\_ i -> i <= value `div` 2) Fold.drain Fold.drain)

221

222-------------------------------------------------------------------------------

223-- Nested

224-------------------------------------------------------------------------------

225

226{-# INLINE parseMany #-}

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

228parseMany value = Stream.fold Fold.drain . Stream.parseManyD (drainWhile (<= value + 1))

229

230{-# INLINE parseManyGroups #-}

231parseManyGroups :: MonadThrow m => Bool -> Stream m Int -> m ()

232parseManyGroups b = Stream.fold Fold.drain . Stream.parseManyD (PR.groupBy (\_ _ -> b) Fold.drain)

233

234{-# INLINE parseManyGroupsRolling #-}

235parseManyGroupsRolling :: MonadThrow m => Bool -> Stream m Int -> m ()

236parseManyGroupsRolling b =

237 Stream.fold Fold.drain . Stream.parseManyD (PR.groupByRolling (\_ _ -> b) Fold.drain)

238

239{-# INLINE parseManyGroupsRollingEither #-}

240parseManyGroupsRollingEither :: MonadThrow m =>

241 (Int -> Int -> Bool) -> Int -> m ()

242parseManyGroupsRollingEither cmp value = do

243 sourceUnfoldrM value 1

244 & Stream.parseManyD (PR.groupByRollingEither cmp Fold.drain Fold.drain)

245 & Stream.fold Fold.drain

246

247{-# INLINE parseManyGroupsRollingEitherAlt #-}

248parseManyGroupsRollingEitherAlt :: MonadThrow m =>

249 (Int -> Int -> Bool) -> Int -> m ()

250parseManyGroupsRollingEitherAlt cmp value = do

251 sourceUnfoldrM value 1

252 -- Make the input unsorted.

253 & fmap (\x -> if even x then x + 2 else x)

254 & Stream.parseManyD (PR.groupByRollingEither cmp Fold.drain Fold.drain)

255 & Stream.fold Fold.drain

256

257-------------------------------------------------------------------------------

258-- Parsing with unfolds

259-------------------------------------------------------------------------------

260

261{-# INLINE parseManyUnfoldArrays #-}

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

263parseManyUnfoldArrays count arrays = do

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

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

266 let readSrc =

267 Source.producer

268 $ Producer.concat Producer.fromList Array.producer

269 let streamParser =

270 Producer.simplify (Source.parseManyD parser readSrc)

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

272

273-------------------------------------------------------------------------------

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

275-------------------------------------------------------------------------------

276

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

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

279-- not have to rely on it.

280--

281{-# INLINE lookAhead #-}

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

283lookAhead value =

284 Stream.parseD (PR.lookAhead (PR.takeWhile (<= value) Fold.drain) $> ())

285

286-- XXX The timing of this increased 3x after the stepify extract changes.

287{-# INLINE sequenceA_ #-}

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

289sequenceA_ value =

290 Stream.parseD (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))

291

292-- quadratic complexity

293{-# INLINE sequenceA #-}

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

295sequenceA value xs = do

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

297 return $ length x

298

299-- quadratic complexity

300{-# INLINE sequence #-}

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

302sequence value xs = do

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

304 return $ length x

305

306{-# INLINE sequence_ #-}

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

308sequence_ value xs =

309 Stream.parseD (foldr f (return ()) (replicate value (PR.takeBetween 0 1 Fold.drain))) xs

310

311 where

312

313 {-# INLINE f #-}

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

315

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

317-- quadratic performance complexity.

318--

319{-# INLINE choiceAsum #-}

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

321choiceAsum value =

322 Stream.parseD (asum (replicate value (PR.satisfy (< 0)))

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

324

325{-

326{-# INLINE choice #-}

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

328choice value =

329 Stream.parseD

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

331-}

332

333-------------------------------------------------------------------------------

334-- Benchmarks

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

336

337moduleName :: String

338moduleName = "Data.Parser.ParserD"

339

340o_1_space_serial :: Int -> [Benchmark]

341o_1_space_serial value =

342 [ benchIOSink value "takeWhile" $ takeWhile value

343 , benchIOSink value "takeP" $ takeP value

344 , benchIOSink value "takeBetween" $ takeBetween value

345 , benchIOSink value "takeStartBy" $ takeStartBy value

346 , benchIOSink value "groupBy" $ groupBy

347 , benchIOSink value "groupByRolling" $ groupByRolling

348 , benchIOSink value "wordBy" $ wordBy value

349 , benchIOSink value "serialWith" $ serialWith value

350 , benchIOSink value "many" many

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

352 , benchIOSink value "some" some

353 , benchIOSink value "takeEndBy_" $ takeEndBy_ value

354 , benchIOSink value "manyTill" $ manyTill value

355 {-

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

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

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

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

360 -}

361 , benchIOSink value "sequenceParser" sequenceParser

362 , benchIOSink value "eqBy" (eqBy value)

363 , benchIOSink value "matchBy" (matchBy value)

364 ]

365

366o_1_space_serial_spanning :: Int -> [Benchmark]

367o_1_space_serial_spanning value =

368 [ benchIOSink value "span" $ span value

369 , benchIOSink value "spanBy" $ spanBy value

370 , benchIOSink value "spanByRolling" $ spanByRolling value

371 ]

372

373o_1_space_serial_nested :: Int -> [Benchmark]

374o_1_space_serial_nested value =

375 [ benchIOSink value "parseMany" $ parseMany value

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

377 $ parseManyGroups False

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

379 $ parseManyGroupsRolling False

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

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

382 $ parseManyGroupsRolling True

383 , bench "parseMany groupRollingByEither (Left)"

384 $ nfIO $ parseManyGroupsRollingEitherLeft

385 , bench "parseMany groupRollingByEither (Right)"

386 $ nfIO $ parseManyGroupsRollingEitherRight

387 , bench "parseMany groupRollingByEither (Alternating)"

388 $ nfIO $ parseManyGroupsRollingEitherAlt1

389 ]

390

391 where

392

393 {-# NOINLINE parseManyGroupsRollingEitherLeft #-}

394 parseManyGroupsRollingEitherLeft = parseManyGroupsRollingEither (<) value

395

396 {-# NOINLINE parseManyGroupsRollingEitherRight #-}

397 parseManyGroupsRollingEitherRight = parseManyGroupsRollingEither (>) value

398

399 {-# NOINLINE parseManyGroupsRollingEitherAlt1 #-}

400 parseManyGroupsRollingEitherAlt1 =

401 parseManyGroupsRollingEitherAlt (>) value

402

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

404o_1_space_serial_unfold bound arrays =

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

406 $ nfIO $ parseManyUnfoldArrays bound arrays

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

408 $ nfIO $ parseManyUnfoldArrays 1 arrays

409 ]

410

411o_n_heap_serial :: Int -> [Benchmark]

412o_n_heap_serial value =

413 [

414 -- lookahead benchmark holds the entire input till end

415 benchIOSink value "lookAhead" $ lookAhead value

416

417 -- These show non-linear time complexity

418 -- They accumulate the results in a list.

419 , benchIOSink value "manyAlt" manyAlt

420 , benchIOSink value "someAlt" someAlt

421 ]

422

423-- accumulate results in a list in IO

424o_n_space_serial :: Int -> [Benchmark]

425o_n_space_serial value =

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

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

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

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

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

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

432 ]

433

434-------------------------------------------------------------------------------

435-- Driver

436-------------------------------------------------------------------------------

437

438main :: IO ()

439main = do

440 x <- randomRIO (1,1)

441 runWithCLIOptsEnv (defaultStreamSize + x) alloc allBenchmarks

442

443 where

444

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

446

447 allBenchmarks arraysSmall value =

448 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

449 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_spanning value)

450 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_nested value)

451 , bgroup (o_1_space_prefix moduleName)

452 (o_1_space_serial_unfold value arraysSmall)

453 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

454 , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)

455 ]