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

git.iko.soy/streamly

on a05abfc help sign in

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

438 lines 15 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)

23#if __GLASGOW_HASKELL__ >= 802

24import GHC.Magic (noinline)

25#else

26#define noinline

27#endif

28import System.IO (Handle)

29import System.Random (randomRIO)

30import Prelude

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

33import qualified Data.Traversable as TR

34import qualified Data.Foldable as F

35import qualified Control.Applicative as AP

36import qualified Streamly.FileSystem.Handle as Handle

37import qualified Streamly.Prelude as S

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

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

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

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

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

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

45import Gauge hiding (env)

46import Streamly.Prelude (SerialT)

47import Streamly.Benchmark.Common

48import Streamly.Benchmark.Common.Handle

50-------------------------------------------------------------------------------

51-- Utilities

52-------------------------------------------------------------------------------

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

56{-# INLINE sourceUnfoldrM #-}

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

58sourceUnfoldrM value n = S.unfoldrM step n

59 where

60 step cnt =

61 if cnt > n + value

62 then return Nothing

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

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

66{-# INLINE benchIOSink #-}

67benchIOSink

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

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

70benchIOSink value name f =

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

73-------------------------------------------------------------------------------

74-- Parsers

75-------------------------------------------------------------------------------

77{-# INLINE next #-}

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

79next value = IP.parse p

80 where

81 p = do

82 m <- PR.next

83 case m of

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

85 Nothing -> pure Nothing

87{-# INLINE takeBetween #-}

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

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

91{-# INLINE takeEQ #-}

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

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

95{-# INLINE drainWhile #-}

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

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

99{-# INLINE sliceBeginWith #-}

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

101sliceBeginWith value stream = do

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

103 let stream2 = value `S.cons` stream1

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

105

106{-# INLINE takeWhile #-}

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

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

109

110{-# INLINE takeP #-}

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

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

113

114{-# INLINE groupBy #-}

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

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

117

118{-# INLINE groupByRolling #-}

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

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

121

122{-# INLINE wordBy #-}

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

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

125

126{-# INLINE manyWordByEven #-}

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

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

129

130{-# INLINE many #-}

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

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

133

134{-# INLINE manyAlt #-}

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

136manyAlt xs = do

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

138 return $ Prelude.length x

139

140{-# INLINE some #-}

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

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

143

144{-# INLINE someAlt #-}

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

146someAlt xs = do

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

148 return $ Prelude.length x

149

150{-# INLINE manyTill #-}

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

152manyTill value =

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

154

155{-# INLINE splitAp #-}

156splitAp :: MonadCatch m

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

158splitAp value =

159 IP.parse

160 ((,)

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

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

163 )

164

165{-# INLINE splitApBefore #-}

166splitApBefore :: MonadCatch m

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

168splitApBefore value =

169 IP.parse

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

171 *> PR.drainWhile (<= value)

172 )

173

174{-# INLINE splitApAfter #-}

175splitApAfter :: MonadCatch m

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

177splitApAfter value =

178 IP.parse

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

180 <* PR.drainWhile (<= value)

181 )

182

183{-# INLINE serialWith #-}

184serialWith :: MonadCatch m

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

186serialWith value =

187 IP.parse

188 (PR.serialWith (,)

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

190 (PR.drainWhile (<= value))

191 )

192

193{-# INLINE split_ #-}

194split_ :: MonadCatch m

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

196split_ value =

197 IP.parse

198 (PR.split_

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

200 (PR.drainWhile (<= value))

201 )

202

203{-# INLINE sliceSepByP #-}

204sliceSepByP :: MonadCatch m

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

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

207

208{-# INLINE teeAllAny #-}

209teeAllAny :: MonadCatch m

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

211teeAllAny value =

212 IP.parse

213 (PR.teeWith (,)

214 (PR.drainWhile (<= value))

215 (PR.drainWhile (<= value))

216 )

217

218{-# INLINE teeFstAllAny #-}

219teeFstAllAny :: MonadCatch m

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

221teeFstAllAny value =

222 IP.parse

223 (PR.teeWithFst (,)

224 (PR.drainWhile (<= value))

225 (PR.drainWhile (<= value))

226 )

227

228{-# INLINE shortestAllAny #-}

229shortestAllAny :: MonadCatch m

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

231shortestAllAny value =

232 IP.parse

233 (PR.shortest

234 (PR.drainWhile (<= value))

235 (PR.drainWhile (<= value))

236 )

237

238{-# INLINE longestAllAny #-}

239longestAllAny :: MonadCatch m

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

241longestAllAny value =

242 IP.parse

243 (PR.longest

244 (PR.drainWhile (<= value))

245 (PR.drainWhile (<= value))

246 )

247

248parseManyChunksOfSum :: Int -> Handle -> IO Int

249parseManyChunksOfSum n inh =

250 S.length

251 $ IP.parseMany

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

253 (S.unfold Handle.read inh)

254

255-------------------------------------------------------------------------------

256-- Parsing with unfolds

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

258

259{-# INLINE parseManyUnfoldArrays #-}

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

261parseManyUnfoldArrays count arrays = do

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

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

264 let readSrc =

265 Source.producer

266 $ Producer.concat Producer.fromList Array.producer

267 let streamParser =

268 Producer.simplify (Source.parseMany parser readSrc)

269 S.drain $ S.unfold streamParser src

270

271-------------------------------------------------------------------------------

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

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

274

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

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

277-- not have to rely on it.

278--

279{-# INLINE lookAhead #-}

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

281lookAhead value =

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

283

284{-# INLINE sequenceA #-}

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

286sequenceA value xs = do

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

288 return $ length x

289

290{-# INLINE sequenceA_ #-}

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

292sequenceA_ value =

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

294

295{-# INLINE sequence #-}

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

297sequence value xs = do

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

299 return $ length x

300

301{-# INLINE sequence_ #-}

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

303sequence_ value =

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

305

306{-# INLINE choiceAsum #-}

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

308choiceAsum value =

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

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

311

312{-# INLINE choice #-}

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

314choice value =

315 IP.parse

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

317

318-------------------------------------------------------------------------------

319-- Stream transformation

320-------------------------------------------------------------------------------

321

322{-# INLINE parseMany #-}

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

324parseMany n =

325 S.drain

326 . S.map getSum

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

328 . S.map Sum

329

330{-# INLINE parseIterate #-}

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

332parseIterate n =

333 S.drain

334 . S.map getSum

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

336 . S.map Sum

337

338-------------------------------------------------------------------------------

339-- Benchmarks

340-------------------------------------------------------------------------------

341

342moduleName :: String

343moduleName = "Data.Parser"

344

345o_1_space_serial :: Int -> [Benchmark]

346o_1_space_serial value =

347 [ benchIOSink value "next" $ next value

348 , benchIOSink value "takeBetween" $ takeBetween value

349 , benchIOSink value "takeEQ" $ takeEQ value

350 , benchIOSink value "takeWhile" $ takeWhile value

351 , benchIOSink value "takeP" $ takeP value

352 , benchIOSink value "drainWhile" $ drainWhile value

353 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

354 , benchIOSink value "groupBy" $ groupBy

355 , benchIOSink value "groupByRolling" $ groupByRolling

356 , benchIOSink value "wordBy" $ wordBy value

357 , benchIOSink value "splitAp" $ splitAp value

358 , benchIOSink value "splitApBefore" $ splitApBefore value

359 , benchIOSink value "splitApAfter" $ splitApAfter value

360 , benchIOSink value "serialWith" $ serialWith value

361 , benchIOSink value "sliceSepByP" $ sliceSepByP value

362 , benchIOSink value "many" many

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

364 , benchIOSink value "some" some

365 , benchIOSink value "manyTill" $ manyTill value

366 , benchIOSink value "tee" $ teeAllAny value

367 , benchIOSink value "teeFst" $ teeFstAllAny value

368 , benchIOSink value "shortest" $ shortestAllAny value

369 , benchIOSink value "longest" $ longestAllAny value

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

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

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

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

374 ]

375

376o_1_space_filesystem :: BenchEnv -> [Benchmark]

377o_1_space_filesystem env =

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

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

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

381 $ \inh _ -> inline parseManyChunksOfSum 1 inh

382 ]

383

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

385o_1_space_serial_unfold bound arrays =

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

387 $ nfIO $ parseManyUnfoldArrays bound arrays

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

389 $ nfIO $ parseManyUnfoldArrays 1 arrays

390 ]

391

392o_n_heap_serial :: Int -> [Benchmark]

393o_n_heap_serial value =

394 [

395 -- lookahead benchmark holds the entire input till end

396 benchIOSink value "lookAhead" $ lookAhead value

397

398 -- accumulates the results in a list

399 , benchIOSink value "sequence" $ sequence value

400 , benchIOSink value "sequenceA" $ sequenceA value

401

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

403 , benchIOSink value "sequence_" $ sequence_ value

404 , benchIOSink value "sequenceA_" $ sequenceA_ value

405 -- non-linear time complexity (parserD)

406 , benchIOSink value "split_" $ split_ value

407 -- XXX why O(n) heap?

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

409 , benchIOSink value "choice" $ choice value

410

411 -- These show non-linear time complexity.

412 -- They accumulate the results in a list.

413 , benchIOSink value "manyAlt" manyAlt

414 , benchIOSink value "someAlt" someAlt

415 ]

416

417-------------------------------------------------------------------------------

418-- Driver

419-------------------------------------------------------------------------------

420

421main :: IO ()

422main = do

423 env <- mkHandleBenchEnv

424 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

425

426 where

427

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

429

430 allBenchmarks env arrays value =

431 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

432 , bgroup

433 (o_1_space_prefix moduleName ++ "/filesystem")

434 (o_1_space_filesystem env)

435 , bgroup (o_1_space_prefix moduleName)

436 (o_1_space_serial_unfold value arrays)

437 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

438 ]