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

git.iko.soy/streamly

on 43dda21 help sign in

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

417 lines 15 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-- Make the input unsorted.

64{-# INLINE benchIOSinkRandom #-}

65benchIOSinkRandom

66 :: (IsStream t, NFData b)

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

68benchIOSinkRandom value name f =

69 bench name $ nfIO $ randomRIO (1,1)

70 >>= f

71 . S.map (\x -> if even x then x + 2 else x)

72 . sourceUnfoldrM value

74-------------------------------------------------------------------------------

75-- Parsers

76-------------------------------------------------------------------------------

78{-# INLINE drainWhile #-}

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

80drainWhile p = PR.takeWhile p FL.drain

82{-# INLINE sliceBeginWith #-}

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

84sliceBeginWith value stream = do

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

86 let stream2 = value `S.cons` stream1

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

89{-# INLINE takeWhile #-}

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

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

93{-# INLINE takeP #-}

94takeP :: MonadThrow m => Int -> SerialT m a -> m ()

95takeP value = IP.parseD (PR.takeP value (PR.fromFold FL.drain))

97{-# INLINE takeBetween #-}

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

99takeBetween value = IP.parseD (PR.takeBetween 0 value FL.drain)

100

101{-# INLINE groupBy #-}

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

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

104

105{-# INLINE groupByRolling #-}

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

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

108

109{-# INLINE wordBy #-}

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

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

112

113{-# INLINE manyWordByEven #-}

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

115manyWordByEven =

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

117

118{-# INLINE many #-}

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

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

121

122{-# INLINE manyAlt #-}

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

124manyAlt xs = do

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

126 return $ Prelude.length x

127

128{-# INLINE some #-}

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

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

131

132{-# INLINE someAlt #-}

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

134someAlt xs = do

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

136 return $ Prelude.length x

137

138{-#INLINE sliceSepByP #-}

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

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

141

142{-# INLINE manyTill #-}

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

144manyTill value =

145 let p = PR.satisfy (> 0)

146 pcond = PR.satisfy (== value)

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

148

149{-# INLINE serialWith #-}

150serialWith :: MonadThrow m

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

152serialWith value =

153 IP.parseD

154 ((,)

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

156 <*> drainWhile (<= value)

157 )

158

159{-# INLINE teeAllAny #-}

160teeAllAny :: MonadThrow m

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

162teeAllAny value =

163 IP.parseD

164 (PR.teeWith (,)

165 (drainWhile (<= value))

166 (drainWhile (<= value))

167 )

168

169{-# INLINE teeFstAllAny #-}

170teeFstAllAny :: MonadThrow m

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

172teeFstAllAny value =

173 IP.parseD

174 (PR.teeWithFst (,)

175 (drainWhile (<= value))

176 (drainWhile (<= value))

177 )

178

179{-# INLINE shortestAllAny #-}

180shortestAllAny :: MonadThrow m

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

182shortestAllAny value =

183 IP.parseD

184 (PR.shortest

185 (drainWhile (<= value))

186 (drainWhile (<= value))

187 )

188

189{-# INLINE longestAllAny #-}

190longestAllAny :: MonadCatch m

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

192longestAllAny value =

193 IP.parseD

194 (PR.longest

195 (drainWhile (<= value))

196 (drainWhile (<= value))

197 )

198

199-------------------------------------------------------------------------------

200-- Spanning

201-------------------------------------------------------------------------------

202

203{-# INLINE span #-}

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

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

206

207{-# INLINE spanBy #-}

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

209spanBy value =

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

211

212{-# INLINE spanByRolling #-}

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

214spanByRolling value =

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

216

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

218-- Nested

219-------------------------------------------------------------------------------

220

221{-# INLINE parseMany #-}

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

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

224

225{-# INLINE parseManyGroups #-}

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

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

228

229{-# INLINE parseManyGroupsRolling #-}

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

231parseManyGroupsRolling b =

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

233

234{-# INLINE parseManyGroupsRollingEither #-}

235parseManyGroupsRollingEither :: (MonadThrow m, MonadCatch m) =>

236 (Int -> Int -> Bool) -> SerialT m Int -> m ()

237parseManyGroupsRollingEither cmp =

238 IP.drain

239 . IP.parseManyD (PR.groupByRollingEither cmp FL.drain FL.drain)

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.parseManyD 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 :: MonadThrow m => Int -> SerialT m Int -> m ()

267lookAhead value =

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

269

270{-# INLINE sequenceA_ #-}

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

272sequenceA_ value =

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

274

275-- quadratic complexity

276{-# INLINE sequenceA #-}

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

278sequenceA value xs = do

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

280 return $ length x

281

282-- quadratic complexity

283{-# INLINE sequence #-}

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

285sequence value xs = do

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

287 return $ length x

288

289{-# INLINE sequence_ #-}

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

291sequence_ value xs =

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

293

294 where

295

296 {-# INLINE f #-}

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

298

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

300-- quadratic performance complexity.

301--

302{-# INLINE choiceAsum #-}

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

304choiceAsum value =

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

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

307

308{-# INLINE choice #-}

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

310choice value =

311 IP.parseD

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

313

314-------------------------------------------------------------------------------

315-- Benchmarks

316-------------------------------------------------------------------------------

317

318moduleName :: String

319moduleName = "Data.Parser.ParserD"

320

321o_1_space_serial :: Int -> [Benchmark]

322o_1_space_serial value =

323 [ benchIOSink value "takeWhile" $ takeWhile value

324 , benchIOSink value "takeP" $ takeP value

325 , benchIOSink value "takeBetween" $ takeBetween value

326 , benchIOSink value "sliceBeginWith" $ sliceBeginWith value

327 , benchIOSink value "groupBy" $ groupBy

328 , benchIOSink value "groupByRolling" $ groupByRolling

329 , benchIOSink value "wordBy" $ wordBy value

330 , benchIOSink value "serialWith" $ serialWith value

331 , benchIOSink value "many" many

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

333 , benchIOSink value "some" some

334 , benchIOSink value "sliceSepByP" $ sliceSepByP value

335 , benchIOSink value "manyTill" $ manyTill value

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

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

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

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

340 ]

341

342o_1_space_serial_spanning :: Int -> [Benchmark]

343o_1_space_serial_spanning value =

344 [ benchIOSink value "span" $ span value

345 , benchIOSink value "spanBy" $ spanBy value

346 , benchIOSink value "spanByRolling" $ spanByRolling value

347 ]

348

349o_1_space_serial_nested :: Int -> [Benchmark]

350o_1_space_serial_nested value =

351 [ benchIOSink value "parseMany" $ parseMany value

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

353 $ parseManyGroups False

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

355 $ parseManyGroupsRolling False

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

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

358 $ parseManyGroupsRolling True

359 , benchIOSink value "parseMany groupRollingByEither (Left)"

360 $ parseManyGroupsRollingEither (<)

361 , benchIOSink value "parseMany groupRollingByEither (Right)"

362 $ parseManyGroupsRollingEither (>)

363 , benchIOSinkRandom value "parseMany groupRollingByEither (Alternating)"

364 $ parseManyGroupsRollingEither (>)

365 ]

366

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

368o_1_space_serial_unfold bound arrays =

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

370 $ nfIO $ parseManyUnfoldArrays bound arrays

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

372 $ nfIO $ parseManyUnfoldArrays 1 arrays

373 ]

374

375o_n_heap_serial :: Int -> [Benchmark]

376o_n_heap_serial value =

377 [

378 -- lookahead benchmark holds the entire input till end

379 benchIOSink value "lookAhead" $ lookAhead value

380

381 -- These show non-linear time complexity

382 -- They accumulate the results in a list.

383 , benchIOSink value "manyAlt" manyAlt

384 , benchIOSink value "someAlt" someAlt

385 ]

386

387-- accumulate results in a list in IO

388o_n_space_serial :: Int -> [Benchmark]

389o_n_space_serial value =

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

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

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

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

394 , benchIOSink value "choice (asum)/100" $ choiceAsum (value `div` 100)

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

396 ]

397

398-------------------------------------------------------------------------------

399-- Driver

400-------------------------------------------------------------------------------

401

402main :: IO ()

403main = runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks

404

405 where

406

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

408

409 allBenchmarks arraysSmall value =

410 [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value)

411 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_spanning value)

412 , bgroup (o_1_space_prefix moduleName) (o_1_space_serial_nested value)

413 , bgroup (o_1_space_prefix moduleName)

414 (o_1_space_serial_unfold value arraysSmall)

415 , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value)

416 , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value)

417 ]