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

git.iko.soy/streamly

on 28fe29b help sign in

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

427 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 takeP #-}

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

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

103

104{-# INLINE groupBy #-}

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

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

107

108{-# INLINE groupByRolling #-}

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

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

111

112{-# INLINE wordBy #-}

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

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

115

116{-# INLINE manyWordByEven #-}

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

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

119

120{-# INLINE many #-}

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

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

123

124{-# INLINE manyAlt #-}

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

126manyAlt xs = do

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

128 return $ Prelude.length x

129

130{-# INLINE some #-}

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

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

133

134{-# INLINE someAlt #-}

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

136someAlt xs = do

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

138 return $ Prelude.length x

139

140{-# INLINE manyTill #-}

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

142manyTill value =

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

144

145{-# INLINE splitAp #-}

146splitAp :: MonadCatch m

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

148splitAp value =

149 IP.parse

150 ((,)

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

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

153 )

154

155{-# INLINE splitApBefore #-}

156splitApBefore :: MonadCatch m

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

158splitApBefore value =

159 IP.parse

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

161 *> PR.drainWhile (<= value)

162 )

163

164{-# INLINE splitApAfter #-}

165splitApAfter :: MonadCatch m

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

167splitApAfter value =

168 IP.parse

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

170 <* PR.drainWhile (<= value)

171 )

172

173{-# INLINE serialWith #-}

174serialWith :: MonadCatch m

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

176serialWith value =

177 IP.parse

178 (PR.serialWith (,)

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

180 (PR.drainWhile (<= value))

181 )

182

183{-# INLINE split_ #-}

184split_ :: MonadCatch m

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

186split_ value =

187 IP.parse

188 (PR.split_

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

190 (PR.drainWhile (<= value))

191 )

192

193{-# INLINE sliceSepByP #-}

194sliceSepByP :: MonadCatch m

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

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

197

198{-# INLINE teeAllAny #-}

199teeAllAny :: MonadCatch m

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

201teeAllAny value =

202 IP.parse

203 (PR.teeWith (,)

204 (PR.drainWhile (<= value))

205 (PR.drainWhile (<= value))

206 )

207

208{-# INLINE teeFstAllAny #-}

209teeFstAllAny :: MonadCatch m

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

211teeFstAllAny value =

212 IP.parse

213 (PR.teeWithFst (,)

214 (PR.drainWhile (<= value))

215 (PR.drainWhile (<= value))

216 )

217

218{-# INLINE shortestAllAny #-}

219shortestAllAny :: MonadCatch m

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

221shortestAllAny value =

222 IP.parse

223 (PR.shortest

224 (PR.drainWhile (<= value))

225 (PR.drainWhile (<= value))

226 )

227

228{-# INLINE longestAllAny #-}

229longestAllAny :: MonadCatch m

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

231longestAllAny value =

232 IP.parse

233 (PR.longest

234 (PR.drainWhile (<= value))

235 (PR.drainWhile (<= value))

236 )

237

238parseManyChunksOfSum :: Int -> Handle -> IO Int

239parseManyChunksOfSum n inh =

240 S.length

241 $ IP.parseMany

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

243 (S.unfold Handle.read inh)

244

245-------------------------------------------------------------------------------

246-- Parsing with unfolds

247-------------------------------------------------------------------------------

248

249{-# INLINE parseManyUnfoldArrays #-}

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

251parseManyUnfoldArrays count arrays = do

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

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

254 let readSrc =

255 Source.producer

256 $ Producer.concat Producer.fromList Array.producer

257 let streamParser =

258 Producer.simplify (Source.parseMany parser readSrc)

259 S.drain $ S.unfold streamParser src

260

261-------------------------------------------------------------------------------

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

263-------------------------------------------------------------------------------

264

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

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

267-- not have to rely on it.

268--

269{-# INLINE lookAhead #-}

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

271lookAhead value =

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

273

274{-# INLINE sequenceA #-}

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

276sequenceA value xs = do

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

278 return $ length x

279

280{-# INLINE sequenceA_ #-}

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

282sequenceA_ value =

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

284

285{-# INLINE sequence #-}

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

287sequence value xs = do

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

289 return $ length x

290

291{-# INLINE sequence_ #-}

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

293sequence_ value =

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

295

296{-# INLINE choiceAsum #-}

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

298choiceAsum value =

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

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

301

302{-# INLINE choice #-}

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

304choice value =

305 IP.parse

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

307

308-------------------------------------------------------------------------------

309-- Stream transformation

310-------------------------------------------------------------------------------

311

312{-# INLINE parseMany #-}

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

314parseMany n =

315 S.drain

316 . S.map getSum

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

318 . S.map Sum

319

320{-# INLINE parseIterate #-}

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

322parseIterate n =

323 S.drain

324 . S.map getSum

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

326 . S.map Sum

327

328-------------------------------------------------------------------------------

329-- Benchmarks

330-------------------------------------------------------------------------------

331

332moduleName :: String

333moduleName = "Data.Parser"

334

335o_1_space_serial :: Int -> [Benchmark]

336o_1_space_serial value =

337 [ benchIOSink value "takeBetween" $ takeBetween value

338 , benchIOSink value "takeEQ" $ takeEQ value

339 , benchIOSink value "takeWhile" $ takeWhile value

340 , benchIOSink value "takeP" $ takeP value

341 , benchIOSink value "drainWhile" $ drainWhile value

342 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

343 , benchIOSink value "groupBy" $ groupBy

344 , benchIOSink value "groupByRolling" $ groupByRolling

345 , benchIOSink value "wordBy" $ wordBy value

346 , benchIOSink value "splitAp" $ splitAp value

347 , benchIOSink value "splitApBefore" $ splitApBefore value

348 , benchIOSink value "splitApAfter" $ splitApAfter value

349 , benchIOSink value "serialWith" $ serialWith value

350 , benchIOSink value "sliceSepByP" $ sliceSepByP value

351 , benchIOSink value "many" many

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

353 , benchIOSink value "some" some

354 , benchIOSink value "manyTill" $ manyTill value

355 , benchIOSink value "tee" $ teeAllAny value

356 , benchIOSink value "teeFst" $ teeFstAllAny value

357 , benchIOSink value "shortest" $ shortestAllAny value

358 , benchIOSink value "longest" $ longestAllAny value

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

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

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

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

363 ]

364

365o_1_space_filesystem :: BenchEnv -> [Benchmark]

366o_1_space_filesystem env =

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

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

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

370 $ \inh _ -> inline parseManyChunksOfSum 1 inh

371 ]

372

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

374o_1_space_serial_unfold bound arrays =

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

376 $ nfIO $ parseManyUnfoldArrays bound arrays

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

378 $ nfIO $ parseManyUnfoldArrays 1 arrays

379 ]

380

381o_n_heap_serial :: Int -> [Benchmark]

382o_n_heap_serial value =

383 [

384 -- lookahead benchmark holds the entire input till end

385 benchIOSink value "lookAhead" $ lookAhead value

386

387 -- accumulates the results in a list

388 , benchIOSink value "sequence" $ sequence value

389 , benchIOSink value "sequenceA" $ sequenceA value

390

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

392 , benchIOSink value "sequence_" $ sequence_ value

393 , benchIOSink value "sequenceA_" $ sequenceA_ value

394 -- non-linear time complexity (parserD)

395 , benchIOSink value "split_" $ split_ value

396 -- XXX why O(n) heap?

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

398 , benchIOSink value "choice" $ choice value

399

400 -- These show non-linear time complexity.

401 -- They accumulate the results in a list.

402 , benchIOSink value "manyAlt" manyAlt

403 , benchIOSink value "someAlt" someAlt

404 ]

405

406-------------------------------------------------------------------------------

407-- Driver

408-------------------------------------------------------------------------------

409

410main :: IO ()

411main = do

412 env <- mkHandleBenchEnv

413 runWithCLIOptsEnv defaultStreamSize alloc (allBenchmarks env)

414

415 where

416

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

418

419 allBenchmarks env arrays value =

420 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

421 , bgroup

422 (o_1_space_prefix moduleName ++ "/filesystem")

423 (o_1_space_filesystem env)

424 , bgroup (o_1_space_prefix moduleName)

425 (o_1_space_serial_unfold value arrays)

426 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

427 ]