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

git.iko.soy/streamly

on cf63b4e help sign in

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

378 lines 13 kB history raw

1-- |

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

4--

5-- License : BSD-3-Clause

6-- Maintainer : streamly@composewell.com

8{-# LANGUAGE FlexibleContexts #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# OPTIONS_GHC -fspec-constr-recursive=4 #-}

12module Main

13 (

14 main

15 ) where

17import Control.DeepSeq (NFData(..))

18import Control.Monad.Catch (MonadCatch, MonadThrow)

19import Data.Foldable (asum)

20import Data.Functor (($>))

21import Data.Maybe (fromMaybe)

22import System.Random (randomRIO)

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

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.Array.Foreign as Array

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

31import qualified Streamly.Internal.Data.Parser.ParserD as PR

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

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

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

36import Gauge

37import Streamly.Prelude (SerialT, MonadAsync, IsStream)

38import Streamly.Benchmark.Common

40-------------------------------------------------------------------------------

41-- Utilities

42-------------------------------------------------------------------------------

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

46{-# INLINE sourceUnfoldrM #-}

47sourceUnfoldrM :: (IsStream t, MonadAsync m) => Int -> Int -> t m Int

48sourceUnfoldrM value n = S.unfoldrM step n

49 where

50 step cnt =

51 if cnt > n + value

52 then return Nothing

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

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

56{-# INLINE benchIOSink #-}

57benchIOSink

58 :: (IsStream t, NFData b)

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

60benchIOSink value name f =

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

63-------------------------------------------------------------------------------

64-- Parsers

65-------------------------------------------------------------------------------

67{-# INLINE drainWhile #-}

68drainWhile :: MonadThrow m => (a -> Bool) -> PR.Parser m a ()

69drainWhile p = PR.takeWhile p FL.drain

71{-# INLINE sliceBeginWith #-}

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

73sliceBeginWith value stream = do

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

75 let stream2 = value `S.cons` stream1

76 IP.parseD (PR.sliceBeginWith (== value) FL.drain) stream2

78{-# INLINE takeWhile #-}

79takeWhile :: MonadThrow m => Int -> SerialT m Int -> m ()

80takeWhile value = IP.parseD (drainWhile (<= value))

82{-# INLINE groupBy #-}

83groupBy :: MonadThrow m => SerialT m Int -> m ()

84groupBy = IP.parseD (PR.groupBy (<=) FL.drain)

86{-# INLINE groupByRolling #-}

87groupByRolling :: MonadThrow m => SerialT m Int -> m ()

88groupByRolling = IP.parseD (PR.groupByRolling (<=) FL.drain)

90{-# INLINE wordBy #-}

91wordBy :: MonadThrow m => Int -> SerialT m Int -> m ()

92wordBy value = IP.parseD (PR.wordBy (>= value) FL.drain)

94{-# INLINE manyWordByEven #-}

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

96manyWordByEven =

97 IP.parseD (PR.many (PR.wordBy (Prelude.even) FL.drain) FL.drain)

99{-# INLINE many #-}

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

101many = IP.parseD (PR.many (PR.satisfy (> 0)) FL.length)

102

103{-# INLINE manyAlt #-}

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

105manyAlt xs = do

106 x <- IP.parseD (AP.many (PR.satisfy (> 0))) xs

107 return $ Prelude.length x

108

109{-# INLINE some #-}

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

111some = IP.parseD (PR.some (PR.satisfy (> 0)) FL.length)

112

113{-# INLINE someAlt #-}

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

115someAlt xs = do

116 x <- IP.parseD (AP.some (PR.satisfy (> 0))) xs

117 return $ Prelude.length x

118

119{-#INLINE sliceSepByP #-}

120sliceSepByP :: MonadCatch m => Int -> SerialT m Int -> m ()

121sliceSepByP value = IP.parseD (PR.sliceSepByP (>= value) (PR.fromFold FL.drain))

122

123{-# INLINE manyTill #-}

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

125manyTill value =

126 let p = PR.satisfy (> 0)

127 pcond = PR.satisfy (== value)

128 in IP.parseD (PR.manyTill FL.length p pcond)

129

130{-# INLINE serialWith #-}

131serialWith :: MonadThrow m

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

133serialWith value =

134 IP.parseD

135 ((,)

136 <$> drainWhile (<= (value `div` 2))

137 <*> drainWhile (<= value)

138 )

139

140{-# INLINE teeAllAny #-}

141teeAllAny :: MonadThrow m

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

143teeAllAny value =

144 IP.parseD

145 (PR.teeWith (,)

146 (drainWhile (<= value))

147 (drainWhile (<= value))

148 )

149

150{-# INLINE teeFstAllAny #-}

151teeFstAllAny :: MonadThrow m

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

153teeFstAllAny value =

154 IP.parseD

155 (PR.teeWithFst (,)

156 (drainWhile (<= value))

157 (drainWhile (<= value))

158 )

159

160{-# INLINE shortestAllAny #-}

161shortestAllAny :: MonadThrow m

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

163shortestAllAny value =

164 IP.parseD

165 (PR.shortest

166 (drainWhile (<= value))

167 (drainWhile (<= value))

168 )

169

170{-# INLINE longestAllAny #-}

171longestAllAny :: MonadCatch m

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

173longestAllAny value =

174 IP.parseD

175 (PR.longest

176 (drainWhile (<= value))

177 (drainWhile (<= value))

178 )

179

180-------------------------------------------------------------------------------

181-- Spanning

182-------------------------------------------------------------------------------

183

184{-# INLINE span #-}

185span :: MonadThrow m => Int -> SerialT m Int -> m ((), ())

186span value = IP.parseD (PR.span (<= (value `div` 2)) FL.drain FL.drain)

187

188{-# INLINE spanBy #-}

189spanBy :: MonadThrow m => Int -> SerialT m Int -> m ((), ())

190spanBy value =

191 IP.parseD (PR.spanBy (\_ i -> i <= (value `div` 2)) FL.drain FL.drain)

192

193{-# INLINE spanByRolling #-}

194spanByRolling :: MonadThrow m => Int -> SerialT m Int -> m ((), ())

195spanByRolling value =

196 IP.parseD (PR.spanByRolling (\_ i -> i <= value `div` 2) FL.drain FL.drain)

197

198-------------------------------------------------------------------------------

199-- Nested

200-------------------------------------------------------------------------------

201

202{-# INLINE parseMany #-}

203parseMany :: MonadThrow m => Int -> SerialT m Int -> m ()

204parseMany value = IP.drain . IP.parseManyD (drainWhile (<= value + 1))

205

206{-# INLINE parseManyGroups #-}

207parseManyGroups :: MonadThrow m => Bool -> SerialT m Int -> m ()

208parseManyGroups b = IP.drain . IP.parseManyD (PR.groupBy (\_ _ -> b) FL.drain)

209

210{-# INLINE parseManyGroupsRolling #-}

211parseManyGroupsRolling :: MonadThrow m => Bool -> SerialT m Int -> m ()

212parseManyGroupsRolling b =

213 IP.drain . IP.parseManyD (PR.groupByRolling (\_ _ -> b) FL.drain)

214

215-------------------------------------------------------------------------------

216-- Parsing with unfolds

217-------------------------------------------------------------------------------

218

219{-# INLINE parseManyUnfoldArrays #-}

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

221parseManyUnfoldArrays count arrays = do

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

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

224 let readSrc =

225 Source.producer

226 $ Producer.concat Producer.fromList Array.producer

227 let streamParser =

228 Producer.simplify (Source.parseManyD parser readSrc)

229 S.drain $ S.unfold streamParser src

230

231-------------------------------------------------------------------------------

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

233-------------------------------------------------------------------------------

234

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

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

237-- not have to rely on it.

238--

239{-# INLINE lookAhead #-}

240lookAhead :: MonadThrow m => Int -> SerialT m Int -> m ()

241lookAhead value =

242 IP.parseD (PR.lookAhead (PR.takeWhile (<= value) FL.drain) $> ())

243

244{-# INLINE sequenceA_ #-}

245sequenceA_ :: MonadThrow m => Int -> SerialT m Int -> m ()

246sequenceA_ value =

247 IP.parseD (F.sequenceA_ $ replicate value (PR.satisfy (> 0)))

248

249-- quadratic complexity

250{-# INLINE sequenceA #-}

251sequenceA :: MonadThrow m => Int -> SerialT m Int -> m Int

252sequenceA value xs = do

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

254 return $ length x

255

256-- quadratic complexity

257{-# INLINE sequence #-}

258sequence :: MonadThrow m => Int -> SerialT m Int -> m Int

259sequence value xs = do

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

261 return $ length x

262

263{-# INLINE sequence_ #-}

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

265sequence_ value xs =

266 IP.parseD (foldr f (return ()) (replicate value (PR.takeBetween 0 1 FL.drain))) xs

267

268 where

269

270 {-# INLINE f #-}

271 f m k = m >>= (\_ -> k)

272

273-- choice using the "Alternative" instance with direct style parser type has

274-- quadratic performance complexity.

275--

276{-# INLINE choice #-}

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

278choice value =

279 IP.parseD (asum (replicate value (PR.satisfy (< 0)))

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

281

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

283-- Benchmarks

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

285

286moduleName :: String

287moduleName = "Data.Parser.ParserD"

288

289o_1_space_serial :: Int -> [Benchmark]

290o_1_space_serial value =

291 [ benchIOSink value "takeWhile" $ takeWhile value

292 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

293 , benchIOSink value "groupBy" $ groupBy

294 , benchIOSink value "groupByRolling" $ groupByRolling

295 , benchIOSink value "wordBy" $ wordBy value

296 , benchIOSink value "serialWith" $ serialWith value

297 , benchIOSink value "many" many

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

299 , benchIOSink value "some" some

300 , benchIOSink value "sliceSepByP" $ sliceSepByP value

301 , benchIOSink value "manyTill" $ manyTill value

302 , benchIOSink value "tee (all,any)" $ teeAllAny value

303 , benchIOSink value "teeFst (all,any)" $ teeFstAllAny value

304 , benchIOSink value "shortest (all,any)" $ shortestAllAny value

305 , benchIOSink value "longest (all,any)" $ longestAllAny value

306 ]

307

308o_1_space_serial_spanning :: Int -> [Benchmark]

309o_1_space_serial_spanning value =

310 [ benchIOSink value "span" $ span value

311 , benchIOSink value "spanBy" $ spanBy value

312 , benchIOSink value "spanByRolling" $ spanByRolling value

313 ]

314

315o_1_space_serial_nested :: Int -> [Benchmark]

316o_1_space_serial_nested value =

317 [ benchIOSink value "parseMany" $ parseMany value

318 , benchIOSink value "parseMany groupBy (bound groups)"

319 $ (parseManyGroups False)

320 , benchIOSink value "parseMany groupRollingBy (bound groups)"

321 $ (parseManyGroupsRolling False)

322 , benchIOSink value "parseMany groupBy (1 group)" $ (parseManyGroups True)

323 , benchIOSink value "parseMany groupRollingBy (1 group)"

324 $ (parseManyGroupsRolling True)

325 ]

326

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

328o_1_space_serial_unfold bound arrays =

329 [ bench "parseMany/Unfold/1000 arrays/1 parse"

330 $ nfIO $ parseManyUnfoldArrays bound arrays

331 , bench "parseMany/Unfold/1000 arrays/100000 parses"

332 $ nfIO $ parseManyUnfoldArrays 1 arrays

333 ]

334

335o_n_heap_serial :: Int -> [Benchmark]

336o_n_heap_serial value =

337 [

338 -- lookahead benchmark holds the entire input till end

339 benchIOSink value "lookAhead" $ lookAhead value

340

341 -- These show non-linear time complexity

342 -- They accumulate the results in a list.

343 , benchIOSink value "manyAlt" manyAlt

344 , benchIOSink value "someAlt" someAlt

345 ]

346

347-- accumulate results in a list in IO

348o_n_space_serial :: Int -> [Benchmark]

349o_n_space_serial value =

350 [ benchIOSink value "sequenceA/100" $ sequenceA (value `div` 100)

351 , benchIOSink value "sequenceA_/100" $ sequenceA_ (value `div` 100)

352 , benchIOSink value "sequence/100" $ sequence (value `div` 100)

353 , benchIOSink value "sequence_/100" $ sequence_ (value `div` 100)

354 , benchIOSink value "choice/100" $ choice (value `div` 100)

355 ]

356

357-------------------------------------------------------------------------------

358-- Driver

359-------------------------------------------------------------------------------

360

361main :: IO ()

362main = do

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

364 arraysSmall <- IP.toList $ IP.arraysOf 100 $ sourceUnfoldrM value 0

365 value `seq` runMode (mode cfg) cfg benches

366 (allBenchmarks value arraysSmall)

367

368 where

369

370 allBenchmarks value arraysSmall =

371 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

372 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_spanning value)

373 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_nested value)

374 , bgroup (o_1_space_prefix moduleName)

375 (o_1_space_serial_unfold value arraysSmall)

376 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

377 , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)

378 ]