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

git.iko.soy/streamly

on 4e604ef help sign in

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

434 lines 14 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 #-}

11module Main

12 (

13 main

14 ) where

16import Control.DeepSeq (NFData(..))

17import Control.Monad.Catch (MonadCatch)

18import Data.Foldable (asum)

19import Data.Functor (($>))

20import Data.Maybe (fromMaybe)

21import Data.Monoid (Sum(..))

22import GHC.Magic (inline)

23import GHC.Magic (noinline)

24import System.IO (Handle)

25import System.Random (randomRIO)

26import Prelude

27 hiding (any, all, take, sequence, sequence_, sequenceA, takeWhile)

29import qualified Data.Traversable as TR

30import qualified Data.Foldable as F

31import qualified Control.Applicative as AP

32import qualified Streamly.FileSystem.Handle as Handle

33import qualified Streamly.Prelude as S

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

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

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

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

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

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

41import Gauge hiding (env)

42import Streamly.Prelude (SerialT)

43import Streamly.Benchmark.Common

44import Streamly.Benchmark.Common.Handle

46-------------------------------------------------------------------------------

47-- Utilities

48-------------------------------------------------------------------------------

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

52{-# INLINE sourceUnfoldrM #-}

53sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int

54sourceUnfoldrM value n = S.unfoldrM step n

55 where

56 step cnt =

57 if cnt > n + value

58 then return Nothing

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

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

62{-# INLINE benchIOSink #-}

63benchIOSink

64 :: (S.IsStream t, NFData b)

65 => Int -> String -> (t IO Int -> IO b) -> Benchmark

66benchIOSink value name f =

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

69-------------------------------------------------------------------------------

70-- Parsers

71-------------------------------------------------------------------------------

73{-# INLINE next #-}

74next :: MonadCatch m => Int -> SerialT m Int -> m (Maybe Int)

75next value = IP.parse p

76 where

77 p = do

78 m <- PR.next

79 case m of

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

81 Nothing -> pure Nothing

83{-# INLINE takeBetween #-}

84takeBetween :: MonadCatch m => Int -> SerialT m a -> m ()

85takeBetween value = IP.parse (PR.takeBetween 0 value FL.drain)

87{-# INLINE takeEQ #-}

88takeEQ :: MonadCatch m => Int -> SerialT m a -> m ()

89takeEQ value = IP.parse (PR.takeEQ value FL.drain)

91{-# INLINE drainWhile #-}

92drainWhile :: MonadCatch m => Int -> SerialT m Int -> m ()

93drainWhile value = IP.parse (PR.drainWhile (<= value))

95{-# INLINE sliceBeginWith #-}

96sliceBeginWith :: MonadCatch m => Int -> SerialT m Int -> m ()

97sliceBeginWith value stream = do

98 stream1 <- return . fromMaybe (S.fromPure (value + 1)) =<< S.tail stream

99 let stream2 = value `S.cons` stream1

100 IP.parse (PR.sliceBeginWith (== value) FL.drain) stream2

101

102{-# INLINE takeWhile #-}

103takeWhile :: MonadCatch m => Int -> SerialT m Int -> m ()

104takeWhile value = IP.parse (PR.takeWhile (<= value) FL.drain)

105

106{-# INLINE takeP #-}

107takeP :: MonadCatch m => Int -> SerialT m a -> m ()

108takeP value = IP.parse (PR.takeP value (PR.fromFold FL.drain))

109

110{-# INLINE groupBy #-}

111groupBy :: MonadCatch m => SerialT m Int -> m ()

112groupBy = IP.parse (PR.groupBy (<=) FL.drain)

113

114{-# INLINE groupByRolling #-}

115groupByRolling :: MonadCatch m => SerialT m Int -> m ()

116groupByRolling = IP.parse (PR.groupByRolling (<=) FL.drain)

117

118{-# INLINE wordBy #-}

119wordBy :: MonadCatch m => Int -> SerialT m Int -> m ()

120wordBy value = IP.parse (PR.wordBy (>= value) FL.drain)

121

122{-# INLINE manyWordByEven #-}

123manyWordByEven :: MonadCatch m => SerialT m Int -> m ()

124manyWordByEven = IP.parse (PR.many (PR.wordBy (Prelude.even) FL.drain) FL.drain)

125

126{-# INLINE many #-}

127many :: MonadCatch m => SerialT m Int -> m Int

128many = IP.parse (PR.many (PR.satisfy (> 0)) FL.length)

129

130{-# INLINE manyAlt #-}

131manyAlt :: MonadCatch m => SerialT m Int -> m Int

132manyAlt xs = do

133 x <- IP.parse (AP.many (PR.satisfy (> 0))) xs

134 return $ Prelude.length x

135

136{-# INLINE some #-}

137some :: MonadCatch m => SerialT m Int -> m Int

138some = IP.parse (PR.some (PR.satisfy (> 0)) FL.length)

139

140{-# INLINE someAlt #-}

141someAlt :: MonadCatch m => SerialT m Int -> m Int

142someAlt xs = do

143 x <- IP.parse (AP.some (PR.satisfy (> 0))) xs

144 return $ Prelude.length x

145

146{-# INLINE manyTill #-}

147manyTill :: MonadCatch m => Int -> SerialT m Int -> m Int

148manyTill value =

149 IP.parse (PR.manyTill (PR.satisfy (> 0)) (PR.satisfy (== value)) FL.length)

150

151{-# INLINE splitAp #-}

152splitAp :: MonadCatch m

153 => Int -> SerialT m Int -> m ((), ())

154splitAp value =

155 IP.parse

156 ((,)

157 <$> PR.drainWhile (<= (value `div` 2))

158 <*> PR.drainWhile (<= value)

159 )

160

161{-# INLINE splitApBefore #-}

162splitApBefore :: MonadCatch m

163 => Int -> SerialT m Int -> m ()

164splitApBefore value =

165 IP.parse

166 ( PR.drainWhile (<= (value `div` 2))

167 *> PR.drainWhile (<= value)

168 )

169

170{-# INLINE splitApAfter #-}

171splitApAfter :: MonadCatch m

172 => Int -> SerialT m Int -> m ()

173splitApAfter value =

174 IP.parse

175 ( PR.drainWhile (<= (value `div` 2))

176 <* PR.drainWhile (<= value)

177 )

178

179{-# INLINE serialWith #-}

180serialWith :: MonadCatch m

181 => Int -> SerialT m Int -> m ((), ())

182serialWith value =

183 IP.parse

184 (PR.serialWith (,)

185 (PR.drainWhile (<= (value `div` 2)))

186 (PR.drainWhile (<= value))

187 )

188

189{-# INLINE split_ #-}

190split_ :: MonadCatch m

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

192split_ value =

193 IP.parse

194 (PR.split_

195 (PR.drainWhile (<= (value `div` 2)))

196 (PR.drainWhile (<= value))

197 )

198

199{-# INLINE sliceSepByP #-}

200sliceSepByP :: MonadCatch m

201 => Int -> SerialT m Int -> m()

202sliceSepByP value = IP.parse (PR.sliceSepByP (>= value) (PR.fromFold FL.drain))

203

204{-# INLINE teeAllAny #-}

205teeAllAny :: MonadCatch m

206 => Int -> SerialT m Int -> m ((), ())

207teeAllAny value =

208 IP.parse

209 (PR.teeWith (,)

210 (PR.drainWhile (<= value))

211 (PR.drainWhile (<= value))

212 )

213

214{-# INLINE teeFstAllAny #-}

215teeFstAllAny :: MonadCatch m

216 => Int -> SerialT m Int -> m ((), ())

217teeFstAllAny value =

218 IP.parse

219 (PR.teeWithFst (,)

220 (PR.drainWhile (<= value))

221 (PR.drainWhile (<= value))

222 )

223

224{-# INLINE shortestAllAny #-}

225shortestAllAny :: MonadCatch m

226 => Int -> SerialT m Int -> m ()

227shortestAllAny value =

228 IP.parse

229 (PR.shortest

230 (PR.drainWhile (<= value))

231 (PR.drainWhile (<= value))

232 )

233

234{-# INLINE longestAllAny #-}

235longestAllAny :: MonadCatch m

236 => Int -> SerialT m Int -> m ()

237longestAllAny value =

238 IP.parse

239 (PR.longest

240 (PR.drainWhile (<= value))

241 (PR.drainWhile (<= value))

242 )

243

244parseManyChunksOfSum :: Int -> Handle -> IO Int

245parseManyChunksOfSum n inh =

246 S.length

247 $ IP.parseMany

248 (PR.fromFold $ FL.take n FL.sum)

249 (S.unfold Handle.read inh)

250

251-------------------------------------------------------------------------------

252-- Parsing with unfolds

253-------------------------------------------------------------------------------

254

255{-# INLINE parseManyUnfoldArrays #-}

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

257parseManyUnfoldArrays count arrays = do

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

259 let parser = PR.fromFold (FL.take count FL.drain)

260 let readSrc =

261 Source.producer

262 $ Producer.concat Producer.fromList Array.producer

263 let streamParser =

264 Producer.simplify (Source.parseMany parser readSrc)

265 S.drain $ S.unfold streamParser src

266

267-------------------------------------------------------------------------------

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

269-------------------------------------------------------------------------------

270

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

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

273-- not have to rely on it.

274--

275{-# INLINE lookAhead #-}

276lookAhead :: MonadCatch m => Int -> SerialT m Int -> m ()

277lookAhead value =

278 IP.parse (PR.lookAhead (PR.takeWhile (<= value) FL.drain) $> ())

279

280{-# INLINE sequenceA #-}

281sequenceA :: MonadCatch m => Int -> SerialT m Int -> m Int

282sequenceA value xs = do

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

284 return $ length x

285

286{-# INLINE sequenceA_ #-}

287sequenceA_ :: MonadCatch m => Int -> SerialT m Int -> m ()

288sequenceA_ value =

289 IP.parse (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))

290

291{-# INLINE sequence #-}

292sequence :: MonadCatch m => Int -> SerialT m Int -> m Int

293sequence value xs = do

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

295 return $ length x

296

297{-# INLINE sequence_ #-}

298sequence_ :: MonadCatch m => Int -> SerialT m Int -> m ()

299sequence_ value =

300 IP.parse (F.sequence_ $ replicate value (PR.satisfy (> 0)))

301

302{-# INLINE choiceAsum #-}

303choiceAsum :: MonadCatch m => Int -> SerialT m Int -> m Int

304choiceAsum value =

305 IP.parse (asum (replicate value (PR.satisfy (< 0)))

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

307

308{-# INLINE choice #-}

309choice :: MonadCatch m => Int -> SerialT m Int -> m Int

310choice value =

311 IP.parse

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

313

314-------------------------------------------------------------------------------

315-- Stream transformation

316-------------------------------------------------------------------------------

317

318{-# INLINE parseMany #-}

319parseMany :: MonadCatch m => Int -> SerialT m Int -> m ()

320parseMany n =

321 S.drain

322 . S.map getSum

323 . IP.parseMany (PR.fromFold $ FL.take n FL.mconcat)

324 . S.map Sum

325

326{-# INLINE parseIterate #-}

327parseIterate :: MonadCatch m => Int -> SerialT m Int -> m ()

328parseIterate n =

329 S.drain

330 . S.map getSum

331 . IP.parseIterate (PR.fromFold . FL.take n . FL.sconcat) (Sum 0)

332 . S.map Sum

333

334-------------------------------------------------------------------------------

335-- Benchmarks

336-------------------------------------------------------------------------------

337

338moduleName :: String

339moduleName = "Data.Parser"

340

341o_1_space_serial :: Int -> [Benchmark]

342o_1_space_serial value =

343 [ benchIOSink value "next" $ next value

344 , benchIOSink value "takeBetween" $ takeBetween value

345 , benchIOSink value "takeEQ" $ takeEQ value

346 , benchIOSink value "takeWhile" $ takeWhile value

347 , benchIOSink value "takeP" $ takeP value

348 , benchIOSink value "drainWhile" $ drainWhile value

349 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

350 , benchIOSink value "groupBy" $ groupBy

351 , benchIOSink value "groupByRolling" $ groupByRolling

352 , benchIOSink value "wordBy" $ wordBy value

353 , benchIOSink value "splitAp" $ splitAp value

354 , benchIOSink value "splitApBefore" $ splitApBefore value

355 , benchIOSink value "splitApAfter" $ splitApAfter value

356 , benchIOSink value "serialWith" $ serialWith value

357 , benchIOSink value "sliceSepByP" $ sliceSepByP value

358 , benchIOSink value "many" many

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

360 , benchIOSink value "some" some

361 , benchIOSink value "manyTill" $ manyTill value

362 , benchIOSink value "tee" $ teeAllAny value

363 , benchIOSink value "teeFst" $ teeFstAllAny value

364 , benchIOSink value "shortest" $ shortestAllAny value

365 , benchIOSink value "longest" $ longestAllAny value

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

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

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

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

370 ]

371

372o_1_space_filesystem :: BenchEnv -> [Benchmark]

373o_1_space_filesystem env =

374 [ mkBench ("S.parseMany (FL.take " ++ show (bigSize env) ++ " FL.sum)") env

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

376 , mkBench "S.parseMany (FL.take 1 FL.sum)" env

377 $ \inh _ -> inline parseManyChunksOfSum 1 inh

378 ]

379

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

381o_1_space_serial_unfold bound arrays =

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

383 $ nfIO $ parseManyUnfoldArrays bound arrays

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

385 $ nfIO $ parseManyUnfoldArrays 1 arrays

386 ]

387

388o_n_heap_serial :: Int -> [Benchmark]

389o_n_heap_serial value =

390 [

391 -- lookahead benchmark holds the entire input till end

392 benchIOSink value "lookAhead" $ lookAhead value

393

394 -- accumulates the results in a list

395 , benchIOSink value "sequence" $ sequence value

396 , benchIOSink value "sequenceA" $ sequenceA value

397

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

399 , benchIOSink value "sequence_" $ sequence_ value

400 , benchIOSink value "sequenceA_" $ sequenceA_ value

401 -- non-linear time complexity (parserD)

402 , benchIOSink value "split_" $ split_ value

403 -- XXX why O(n) heap?

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

405 , benchIOSink value "choice" $ choice value

406

407 -- These show non-linear time complexity.

408 -- They accumulate the results in a list.

409 , benchIOSink value "manyAlt" manyAlt

410 , benchIOSink value "someAlt" someAlt

411 ]

412

413-------------------------------------------------------------------------------

414-- Driver

415-------------------------------------------------------------------------------

416

417main :: IO ()

418main = do

419 env <- mkHandleBenchEnv

420 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

421

422 where

423

424 alloc value = IP.toList $ IP.arraysOf 100 $ sourceUnfoldrM value 0

425

426 allBenchmarks env arrays value =

427 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

428 , bgroup

429 (o_1_space_prefix moduleName ++ "/filesystem")

430 (o_1_space_filesystem env)

431 , bgroup (o_1_space_prefix moduleName)

432 (o_1_space_serial_unfold value arrays)

433 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

434 ]