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

git.iko.soy/streamly

on a12febb help sign in

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

354 lines 11 kB history raw

1-- |

2-- Module : Streamly.Benchmark.Data.Parser

4--

5-- License : BSD-3-Clause

6-- Maintainer : streamly@composewell.com

8{-# LANGUAGE FlexibleContexts #-}

10module Main

11 (

12 main

13 ) where

15import Control.DeepSeq (NFData(..))

16import Control.Monad.Catch (MonadCatch)

17import Data.Foldable (asum)

18import Data.Functor (($>))

19import Data.Maybe (fromMaybe)

20import Data.Monoid (Sum(..))

21import System.Random (randomRIO)

22import Prelude

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

25import qualified Data.Traversable as TR

26import qualified Data.Foldable as F

27import qualified Control.Applicative as AP

28import qualified Streamly.Prelude as S

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

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

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

33import Gauge

34import Streamly.Prelude (SerialT)

35import Streamly.Benchmark.Common

37-------------------------------------------------------------------------------

38-- Utilities

39-------------------------------------------------------------------------------

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

43{-# INLINE sourceUnfoldrM #-}

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

45sourceUnfoldrM value n = S.unfoldrM step n

46 where

47 step cnt =

48 if cnt > n + value

49 then return Nothing

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

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

53{-# INLINE benchIOSink #-}

54benchIOSink

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

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

57benchIOSink value name f =

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

60-------------------------------------------------------------------------------

61-- Parsers

62-------------------------------------------------------------------------------

64{-# INLINE takeBetween #-}

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

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

68{-# INLINE takeEQ #-}

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

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

72{-# INLINE drainWhile #-}

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

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

76{-# INLINE sliceBeginWith #-}

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

78sliceBeginWith value stream = do

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

80 let stream2 = value `S.cons` stream1

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

83{-# INLINE takeWhile #-}

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

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

87{-# INLINE groupBy #-}

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

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

91{-# INLINE groupByRolling #-}

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

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

95{-# INLINE wordBy #-}

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

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

99{-# INLINE manyWordByEven #-}

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

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

102

103{-# INLINE many #-}

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

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

106

107{-# INLINE manyAlt #-}

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

109manyAlt xs = do

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

111 return $ Prelude.length x

112

113{-# INLINE some #-}

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

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

116

117{-# INLINE someAlt #-}

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

119someAlt xs = do

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

121 return $ Prelude.length x

122

123{-# INLINE manyTill #-}

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

125manyTill value =

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

127

128{-# INLINE splitAp #-}

129splitAp :: MonadCatch m

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

131splitAp value =

132 IP.parse

133 ((,)

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

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

136 )

137

138{-# INLINE splitApBefore #-}

139splitApBefore :: MonadCatch m

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

141splitApBefore value =

142 IP.parse

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

144 *> PR.drainWhile (<= value)

145 )

146

147{-# INLINE splitApAfter #-}

148splitApAfter :: MonadCatch m

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

150splitApAfter value =

151 IP.parse

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

153 <* PR.drainWhile (<= value)

154 )

155

156{-# INLINE splitWith #-}

157splitWith :: MonadCatch m

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

159splitWith value =

160 IP.parse

161 (PR.splitWith (,)

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

163 (PR.drainWhile (<= value))

164 )

165

166{-# INLINE split_ #-}

167split_ :: MonadCatch m

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

169split_ value =

170 IP.parse

171 (PR.split_

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

173 (PR.drainWhile (<= value))

174 )

175

176{-# INLINE sliceSepByP #-}

177sliceSepByP :: MonadCatch m

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

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

180

181{-# INLINE teeAllAny #-}

182teeAllAny :: MonadCatch m

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

184teeAllAny value =

185 IP.parse

186 (PR.teeWith (,)

187 (PR.drainWhile (<= value))

188 (PR.drainWhile (<= value))

189 )

190

191{-# INLINE teeFstAllAny #-}

192teeFstAllAny :: MonadCatch m

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

194teeFstAllAny value =

195 IP.parse

196 (PR.teeWithFst (,)

197 (PR.drainWhile (<= value))

198 (PR.drainWhile (<= value))

199 )

200

201{-# INLINE shortestAllAny #-}

202shortestAllAny :: MonadCatch m

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

204shortestAllAny value =

205 IP.parse

206 (PR.shortest

207 (PR.drainWhile (<= value))

208 (PR.drainWhile (<= value))

209 )

210

211{-# INLINE longestAllAny #-}

212longestAllAny :: MonadCatch m

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

214longestAllAny value =

215 IP.parse

216 (PR.longest

217 (PR.drainWhile (<= value))

218 (PR.drainWhile (<= value))

219 )

220

221-------------------------------------------------------------------------------

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

223-------------------------------------------------------------------------------

224

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

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

227-- not have to rely on it.

228--

229{-# INLINE lookAhead #-}

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

231lookAhead value =

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

233

234{-# INLINE sequenceA #-}

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

236sequenceA value xs = do

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

238 return $ length x

239

240{-# INLINE sequenceA_ #-}

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

242sequenceA_ value =

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

244

245{-# INLINE sequence #-}

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

247sequence value xs = do

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

249 return $ length x

250

251{-# INLINE sequence_ #-}

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

253sequence_ value =

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

255

256{-# INLINE choice #-}

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

258choice value =

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

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

261

262-------------------------------------------------------------------------------

263-- Stream transformation

264-------------------------------------------------------------------------------

265

266{-# INLINE parseMany #-}

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

268parseMany =

269 S.drain

270 . S.map getSum

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

272 . S.map Sum

273

274{-# INLINE parseIterate #-}

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

276parseIterate =

277 S.drain

278 . S.map getSum

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

280 . S.map Sum

281

282-------------------------------------------------------------------------------

283-- Benchmarks

284-------------------------------------------------------------------------------

285

286moduleName :: String

287moduleName = "Data.Parser"

288

289o_1_space_serial :: Int -> [Benchmark]

290o_1_space_serial value =

291 [ benchIOSink value "takeBetween" $ takeBetween value

292 , benchIOSink value "takeEQ" $ takeEQ value

293 , benchIOSink value "takeWhile" $ takeWhile value

294 , benchIOSink value "drainWhile" $ drainWhile value

295 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

296 , benchIOSink value "groupBy" $ groupBy

297 , benchIOSink value "groupByRolling" $ groupByRolling

298 , benchIOSink value "wordBy" $ wordBy value

299 , benchIOSink value "splitAp" $ splitAp value

300 , benchIOSink value "splitApBefore" $ splitApBefore value

301 , benchIOSink value "splitApAfter" $ splitApAfter value

302 , benchIOSink value "splitWith" $ splitWith value

303 , benchIOSink value "sliceSepByP" $ sliceSepByP value

304 , benchIOSink value "many" many

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

306 , benchIOSink value "some" some

307 , benchIOSink value "manyTill" $ manyTill value

308 , benchIOSink value "tee" $ teeAllAny value

309 , benchIOSink value "teeFst" $ teeFstAllAny value

310 , benchIOSink value "shortest" $ shortestAllAny value

311 , benchIOSink value "longest" $ longestAllAny value

312 , benchIOSink value "parseMany" parseMany

313 , benchIOSink value "parseIterate" parseIterate

314 ]

315

316o_n_heap_serial :: Int -> [Benchmark]

317o_n_heap_serial value =

318 [

319 -- lookahead benchmark holds the entire input till end

320 benchIOSink value "lookAhead" $ lookAhead value

321

322 -- accumulates the results in a list

323 , benchIOSink value "sequence" $ sequence value

324 , benchIOSink value "sequenceA" $ sequenceA value

325

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

327 , benchIOSink value "sequence_" $ sequence_ value

328 , benchIOSink value "sequenceA_" $ sequenceA_ value

329 -- non-linear time complexity (parserD)

330 , benchIOSink value "split_" $ split_ value

331 -- XXX why O(n) heap?

332 , benchIOSink value "choice" $ choice value

333

334 -- These show non-linear time complexity.

335 -- They accumulate the results in a list.

336 , benchIOSink value "manyAlt" manyAlt

337 , benchIOSink value "someAlt" someAlt

338 ]

339

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

341-- Driver

342-------------------------------------------------------------------------------

343

344main :: IO ()

345main = do

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

347 value `seq` runMode (mode cfg) cfg benches (allBenchmarks value)

348

349 where

350

351 allBenchmarks value =

352 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

353 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

354 ]