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

git.iko.soy/streamly

on 3947fee help sign in

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

383 lines 12 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.Fold as FL

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

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

42import Gauge hiding (env)

43import Streamly.Prelude (SerialT)

44import Streamly.Benchmark.Common

45import Streamly.Benchmark.Common.Handle

47-------------------------------------------------------------------------------

48-- Utilities

49-------------------------------------------------------------------------------

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

53{-# INLINE sourceUnfoldrM #-}

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

55sourceUnfoldrM value n = S.unfoldrM step n

56 where

57 step cnt =

58 if cnt > n + value

59 then return Nothing

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

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

63{-# INLINE benchIOSink #-}

64benchIOSink

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

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

67benchIOSink value name f =

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

70-------------------------------------------------------------------------------

71-- Parsers

72-------------------------------------------------------------------------------

74{-# INLINE takeBetween #-}

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

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

78{-# INLINE takeEQ #-}

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

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

82{-# INLINE drainWhile #-}

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

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

86{-# INLINE sliceBeginWith #-}

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

88sliceBeginWith value stream = do

89 stream1 <- return . fromMaybe (S.yield (value + 1)) =<< S.tail stream

90 let stream2 = value `S.cons` stream1

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

93{-# INLINE takeWhile #-}

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

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

97{-# INLINE groupBy #-}

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

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

100

101{-# INLINE groupByRolling #-}

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

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

104

105{-# INLINE wordBy #-}

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

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

108

109{-# INLINE manyWordByEven #-}

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

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

112

113{-# INLINE many #-}

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

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

116

117{-# INLINE manyAlt #-}

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

119manyAlt xs = do

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

121 return $ Prelude.length x

122

123{-# INLINE some #-}

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

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

126

127{-# INLINE someAlt #-}

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

129someAlt xs = do

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

131 return $ Prelude.length x

132

133{-# INLINE manyTill #-}

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

135manyTill value =

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

137

138{-# INLINE splitAp #-}

139splitAp :: MonadCatch m

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

141splitAp value =

142 IP.parse

143 ((,)

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

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

146 )

147

148{-# INLINE splitApBefore #-}

149splitApBefore :: MonadCatch m

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

151splitApBefore value =

152 IP.parse

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

154 *> PR.drainWhile (<= value)

155 )

156

157{-# INLINE splitApAfter #-}

158splitApAfter :: MonadCatch m

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

160splitApAfter value =

161 IP.parse

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

163 <* PR.drainWhile (<= value)

164 )

165

166{-# INLINE splitWith #-}

167splitWith :: MonadCatch m

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

169splitWith value =

170 IP.parse

171 (PR.splitWith (,)

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

173 (PR.drainWhile (<= value))

174 )

175

176{-# INLINE split_ #-}

177split_ :: MonadCatch m

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

179split_ value =

180 IP.parse

181 (PR.split_

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

183 (PR.drainWhile (<= value))

184 )

185

186{-# INLINE sliceSepByP #-}

187sliceSepByP :: MonadCatch m

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

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

190

191{-# INLINE teeAllAny #-}

192teeAllAny :: MonadCatch m

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

194teeAllAny value =

195 IP.parse

196 (PR.teeWith (,)

197 (PR.drainWhile (<= value))

198 (PR.drainWhile (<= value))

199 )

200

201{-# INLINE teeFstAllAny #-}

202teeFstAllAny :: MonadCatch m

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

204teeFstAllAny value =

205 IP.parse

206 (PR.teeWithFst (,)

207 (PR.drainWhile (<= value))

208 (PR.drainWhile (<= value))

209 )

210

211{-# INLINE shortestAllAny #-}

212shortestAllAny :: MonadCatch m

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

214shortestAllAny value =

215 IP.parse

216 (PR.shortest

217 (PR.drainWhile (<= value))

218 (PR.drainWhile (<= value))

219 )

220

221{-# INLINE longestAllAny #-}

222longestAllAny :: MonadCatch m

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

224longestAllAny value =

225 IP.parse

226 (PR.longest

227 (PR.drainWhile (<= value))

228 (PR.drainWhile (<= value))

229 )

230

231parseManyChunksOfSum :: Int -> Handle -> IO Int

232parseManyChunksOfSum n inh =

233 S.length

234 $ IP.parseMany

235 (PR.fromFold $ FL.takeLE n FL.sum)

236 (S.unfold Handle.read inh)

237

238-------------------------------------------------------------------------------

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

240-------------------------------------------------------------------------------

241

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

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

244-- not have to rely on it.

245--

246{-# INLINE lookAhead #-}

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

248lookAhead value =

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

250

251{-# INLINE sequenceA #-}

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

253sequenceA value xs = do

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

255 return $ length x

256

257{-# INLINE sequenceA_ #-}

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

259sequenceA_ value =

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

261

262{-# INLINE sequence #-}

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

264sequence value xs = do

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

266 return $ length x

267

268{-# INLINE sequence_ #-}

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

270sequence_ value =

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

272

273{-# INLINE choice #-}

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

275choice value =

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

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

278

279-------------------------------------------------------------------------------

280-- Stream transformation

281-------------------------------------------------------------------------------

282

283{-# INLINE parseMany #-}

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

285parseMany =

286 S.drain

287 . S.map getSum

288 . IP.parseMany (PR.fromFold $ FL.takeLE 2 FL.mconcat)

289 . S.map Sum

290

291{-# INLINE parseIterate #-}

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

293parseIterate =

294 S.drain

295 . S.map getSum

296 . IP.parseIterate (PR.fromFold . FL.takeLE 2 . FL.sconcat) (Sum 0)

297 . S.map Sum

298

299-------------------------------------------------------------------------------

300-- Benchmarks

301-------------------------------------------------------------------------------

302

303moduleName :: String

304moduleName = "Data.Parser"

305

306o_1_space_serial :: Int -> [Benchmark]

307o_1_space_serial value =

308 [ benchIOSink value "takeBetween" $ takeBetween value

309 , benchIOSink value "takeEQ" $ takeEQ value

310 , benchIOSink value "takeWhile" $ takeWhile value

311 , benchIOSink value "drainWhile" $ drainWhile value

312 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

313 , benchIOSink value "groupBy" $ groupBy

314 , benchIOSink value "groupByRolling" $ groupByRolling

315 , benchIOSink value "wordBy" $ wordBy value

316 , benchIOSink value "splitAp" $ splitAp value

317 , benchIOSink value "splitApBefore" $ splitApBefore value

318 , benchIOSink value "splitApAfter" $ splitApAfter value

319 , benchIOSink value "splitWith" $ splitWith value

320 , benchIOSink value "sliceSepByP" $ sliceSepByP value

321 , benchIOSink value "many" many

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

323 , benchIOSink value "some" some

324 , benchIOSink value "manyTill" $ manyTill value

325 , benchIOSink value "tee" $ teeAllAny value

326 , benchIOSink value "teeFst" $ teeFstAllAny value

327 , benchIOSink value "shortest" $ shortestAllAny value

328 , benchIOSink value "longest" $ longestAllAny value

329 , benchIOSink value "parseMany" parseMany

330 , benchIOSink value "parseIterate" parseIterate

331 ]

332

333o_1_space_filesystem :: BenchEnv -> [Benchmark]

334o_1_space_filesystem env =

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

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

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

338 $ \inh _ -> inline parseManyChunksOfSum 1 inh

339 ]

340

341o_n_heap_serial :: Int -> [Benchmark]

342o_n_heap_serial value =

343 [

344 -- lookahead benchmark holds the entire input till end

345 benchIOSink value "lookAhead" $ lookAhead value

346

347 -- accumulates the results in a list

348 , benchIOSink value "sequence" $ sequence value

349 , benchIOSink value "sequenceA" $ sequenceA value

350

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

352 , benchIOSink value "sequence_" $ sequence_ value

353 , benchIOSink value "sequenceA_" $ sequenceA_ value

354 -- non-linear time complexity (parserD)

355 , benchIOSink value "split_" $ split_ value

356 -- XXX why O(n) heap?

357 , benchIOSink value "choice" $ choice value

358

359 -- These show non-linear time complexity.

360 -- They accumulate the results in a list.

361 , benchIOSink value "manyAlt" manyAlt

362 , benchIOSink value "someAlt" someAlt

363 ]

364

365-------------------------------------------------------------------------------

366-- Driver

367-------------------------------------------------------------------------------

368

369main :: IO ()

370main = do

371 (value, cfg, benches) <- parseCLIOpts defaultStreamSize

372 env <- mkHandleBenchEnv

373 value `seq` runMode (mode cfg) cfg benches (allBenchmarks env value)

374

375 where

376

377 allBenchmarks env value =

378 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

379 , bgroup

380 (o_1_space_prefix moduleName ++ "/filesystem")

381 (o_1_space_filesystem env)

382 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

383 ]