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

git.iko.soy/streamly

on 03218ad help sign in

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

415 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)

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 takeBetween #-}

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

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

81{-# INLINE takeEQ #-}

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

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

85{-# INLINE drainWhile #-}

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

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

89{-# INLINE sliceBeginWith #-}

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

91sliceBeginWith value stream = do

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

93 let stream2 = value `S.cons` stream1

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

96{-# INLINE takeWhile #-}

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

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

100{-# INLINE groupBy #-}

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

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

103

104{-# INLINE groupByRolling #-}

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

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

107

108{-# INLINE wordBy #-}

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

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

111

112{-# INLINE manyWordByEven #-}

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

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

115

116{-# INLINE many #-}

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

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

119

120{-# INLINE manyAlt #-}

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

122manyAlt xs = do

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

124 return $ Prelude.length x

125

126{-# INLINE some #-}

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

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

129

130{-# INLINE someAlt #-}

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

132someAlt xs = do

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

134 return $ Prelude.length x

135

136{-# INLINE manyTill #-}

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

138manyTill value =

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

140

141{-# INLINE splitAp #-}

142splitAp :: MonadCatch m

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

144splitAp value =

145 IP.parse

146 ((,)

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

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

149 )

150

151{-# INLINE splitApBefore #-}

152splitApBefore :: MonadCatch m

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

154splitApBefore value =

155 IP.parse

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

157 *> PR.drainWhile (<= value)

158 )

159

160{-# INLINE splitApAfter #-}

161splitApAfter :: MonadCatch m

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

163splitApAfter value =

164 IP.parse

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

166 <* PR.drainWhile (<= value)

167 )

168

169{-# INLINE serialWith #-}

170serialWith :: MonadCatch m

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

172serialWith value =

173 IP.parse

174 (PR.serialWith (,)

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

176 (PR.drainWhile (<= value))

177 )

178

179{-# INLINE split_ #-}

180split_ :: MonadCatch m

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

182split_ value =

183 IP.parse

184 (PR.split_

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

186 (PR.drainWhile (<= value))

187 )

188

189{-# INLINE sliceSepByP #-}

190sliceSepByP :: MonadCatch m

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

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

193

194{-# INLINE teeAllAny #-}

195teeAllAny :: MonadCatch m

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

197teeAllAny value =

198 IP.parse

199 (PR.teeWith (,)

200 (PR.drainWhile (<= value))

201 (PR.drainWhile (<= value))

202 )

203

204{-# INLINE teeFstAllAny #-}

205teeFstAllAny :: MonadCatch m

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

207teeFstAllAny value =

208 IP.parse

209 (PR.teeWithFst (,)

210 (PR.drainWhile (<= value))

211 (PR.drainWhile (<= value))

212 )

213

214{-# INLINE shortestAllAny #-}

215shortestAllAny :: MonadCatch m

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

217shortestAllAny value =

218 IP.parse

219 (PR.shortest

220 (PR.drainWhile (<= value))

221 (PR.drainWhile (<= value))

222 )

223

224{-# INLINE longestAllAny #-}

225longestAllAny :: MonadCatch m

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

227longestAllAny value =

228 IP.parse

229 (PR.longest

230 (PR.drainWhile (<= value))

231 (PR.drainWhile (<= value))

232 )

233

234parseManyChunksOfSum :: Int -> Handle -> IO Int

235parseManyChunksOfSum n inh =

236 S.length

237 $ IP.parseMany

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

239 (S.unfold Handle.read inh)

240

241-------------------------------------------------------------------------------

242-- Parsing with unfolds

243-------------------------------------------------------------------------------

244

245{-# INLINE parseManyUnfoldArrays #-}

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

247parseManyUnfoldArrays count arrays = do

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

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

250 let readSrc =

251 Source.producer

252 $ Producer.concat Producer.fromList Array.producer

253 let streamParser =

254 Producer.simplify (Source.parseMany parser readSrc)

255 S.drain $ S.unfold streamParser src

256

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

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

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

260

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

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

263-- not have to rely on it.

264--

265{-# INLINE lookAhead #-}

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

267lookAhead value =

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

269

270{-# INLINE sequenceA #-}

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

272sequenceA value xs = do

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

274 return $ length x

275

276{-# INLINE sequenceA_ #-}

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

278sequenceA_ value =

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

280

281{-# INLINE sequence #-}

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

283sequence value xs = do

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

285 return $ length x

286

287{-# INLINE sequence_ #-}

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

289sequence_ value =

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

291

292{-# INLINE choice #-}

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

294choice value =

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

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

297

298-------------------------------------------------------------------------------

299-- Stream transformation

300-------------------------------------------------------------------------------

301

302{-# INLINE parseMany #-}

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

304parseMany n =

305 S.drain

306 . S.map getSum

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

308 . S.map Sum

309

310{-# INLINE parseIterate #-}

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

312parseIterate n =

313 S.drain

314 . S.map getSum

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

316 . S.map Sum

317

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

319-- Benchmarks

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

321

322moduleName :: String

323moduleName = "Data.Parser"

324

325o_1_space_serial :: Int -> [Benchmark]

326o_1_space_serial value =

327 [ benchIOSink value "takeBetween" $ takeBetween value

328 , benchIOSink value "takeEQ" $ takeEQ value

329 , benchIOSink value "takeWhile" $ takeWhile value

330 , benchIOSink value "drainWhile" $ drainWhile value

331 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

332 , benchIOSink value "groupBy" $ groupBy

333 , benchIOSink value "groupByRolling" $ groupByRolling

334 , benchIOSink value "wordBy" $ wordBy value

335 , benchIOSink value "splitAp" $ splitAp value

336 , benchIOSink value "splitApBefore" $ splitApBefore value

337 , benchIOSink value "splitApAfter" $ splitApAfter value

338 , benchIOSink value "serialWith" $ serialWith value

339 , benchIOSink value "sliceSepByP" $ sliceSepByP value

340 , benchIOSink value "many" many

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

342 , benchIOSink value "some" some

343 , benchIOSink value "manyTill" $ manyTill value

344 , benchIOSink value "tee" $ teeAllAny value

345 , benchIOSink value "teeFst" $ teeFstAllAny value

346 , benchIOSink value "shortest" $ shortestAllAny value

347 , benchIOSink value "longest" $ longestAllAny value

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

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

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

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

352 ]

353

354o_1_space_filesystem :: BenchEnv -> [Benchmark]

355o_1_space_filesystem env =

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

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

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

359 $ \inh _ -> inline parseManyChunksOfSum 1 inh

360 ]

361

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

363o_1_space_serial_unfold bound arrays =

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

365 $ nfIO $ parseManyUnfoldArrays bound arrays

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

367 $ nfIO $ parseManyUnfoldArrays 1 arrays

368 ]

369

370o_n_heap_serial :: Int -> [Benchmark]

371o_n_heap_serial value =

372 [

373 -- lookahead benchmark holds the entire input till end

374 benchIOSink value "lookAhead" $ lookAhead value

375

376 -- accumulates the results in a list

377 , benchIOSink value "sequence" $ sequence value

378 , benchIOSink value "sequenceA" $ sequenceA value

379

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

381 , benchIOSink value "sequence_" $ sequence_ value

382 , benchIOSink value "sequenceA_" $ sequenceA_ value

383 -- non-linear time complexity (parserD)

384 , benchIOSink value "split_" $ split_ value

385 -- XXX why O(n) heap?

386 , benchIOSink value "choice" $ choice value

387

388 -- These show non-linear time complexity.

389 -- They accumulate the results in a list.

390 , benchIOSink value "manyAlt" manyAlt

391 , benchIOSink value "someAlt" someAlt

392 ]

393

394-------------------------------------------------------------------------------

395-- Driver

396-------------------------------------------------------------------------------

397

398main :: IO ()

399main = do

400 env <- mkHandleBenchEnv

401 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

402

403 where

404

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

406

407 allBenchmarks env arrays value =

408 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

409 , bgroup

410 (o_1_space_prefix moduleName ++ "/filesystem")

411 (o_1_space_filesystem env)

412 , bgroup (o_1_space_prefix moduleName)

413 (o_1_space_serial_unfold value arrays)

414 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

415 ]