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

git.iko.soy/streamly

on beabbcc help sign in

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

291 lines 9.6 kB history raw

1-- |

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

4--

5-- License : BSD-3-Clause

6-- Maintainer : streamly@composewell.com

8{-# LANGUAGE FlexibleContexts #-}

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

11module Main

12 (

13 main

14 ) where

16import Control.DeepSeq (NFData(..))

17import Control.Monad.Catch (MonadCatch)

18import Data.Foldable (asum)

19import Data.Monoid (Sum(..))

20import System.Random (randomRIO)

21import Prelude

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

24import qualified Data.Traversable as TR

25import qualified Data.Foldable as F

26import qualified Control.Applicative as AP

27import qualified Streamly.Prelude as S

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

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

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

32import Gauge

33import Streamly.Prelude (SerialT)

34import Streamly.Benchmark.Common

36-------------------------------------------------------------------------------

37-- Utilities

38-------------------------------------------------------------------------------

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

42{-# INLINE sourceUnfoldrM #-}

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

44sourceUnfoldrM value n = S.unfoldrM step n

45 where

46 step cnt =

47 if cnt > n + value

48 then return Nothing

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

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

52{-# INLINE benchIOSink #-}

53benchIOSink

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

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

56benchIOSink value name f =

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

59-------------------------------------------------------------------------------

60-- Parsers

61-------------------------------------------------------------------------------

63{-# INLINE any #-}

64any :: (MonadCatch m, Ord a) => a -> SerialT m a -> m Bool

65any value = IP.parse (PR.any (> value))

67{-# INLINE all #-}

68all :: (MonadCatch m, Ord a) => a -> SerialT m a -> m Bool

69all value = IP.parse (PR.all (<= value))

71{-# INLINE take #-}

72take :: MonadCatch m => Int -> SerialT m a -> m ()

73take value = IP.parse (PR.take value FL.drain)

75{-# INLINE takeWhile #-}

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

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

79{-# INLINE many #-}

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

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

83{-# INLINE manyAlt #-}

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

85manyAlt xs = do

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

87 return $ Prelude.length x

89{-# INLINE some #-}

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

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

93{-# INLINE someAlt #-}

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

95someAlt xs = do

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

97 return $ Prelude.length x

99{-# INLINE manyTill #-}

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

101manyTill value =

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

103

104{-# INLINE splitAp #-}

105splitAp :: MonadCatch m

106 => Int -> SerialT m Int -> m (Bool, Bool)

107splitAp value =

108 IP.parse ((,) <$> PR.all (<= (value `div` 2)) <*> PR.any (> value))

109

110{-# INLINE splitApBefore #-}

111splitApBefore :: MonadCatch m

112 => Int -> SerialT m Int -> m Bool

113splitApBefore value =

114 IP.parse (PR.all (<= (value `div` 2)) *> PR.any (> value))

115

116{-# INLINE splitApAfter #-}

117splitApAfter :: MonadCatch m

118 => Int -> SerialT m Int -> m Bool

119splitApAfter value =

120 IP.parse (PR.all (<= (value `div` 2)) <* PR.any (> value))

121

122{-# INLINE splitWith #-}

123splitWith :: MonadCatch m

124 => Int -> SerialT m Int -> m (Bool, Bool)

125splitWith value =

126 IP.parse (PR.splitWith (,) (PR.all (<= (value `div` 2))) (PR.any (> value)))

127

128{-# INLINE split_ #-}

129split_ :: MonadCatch m

130 => Int -> SerialT m Int -> m Bool

131split_ value =

132 IP.parse (PR.split_ (PR.all (<= (value `div` 2))) (PR.any (> value)))

133

134{-# INLINE teeAllAny #-}

135teeAllAny :: (MonadCatch m, Ord a)

136 => a -> SerialT m a -> m (Bool, Bool)

137teeAllAny value =

138 IP.parse (PR.teeWith (,) (PR.all (<= value)) (PR.any (> value)))

139

140{-# INLINE teeFstAllAny #-}

141teeFstAllAny :: (MonadCatch m, Ord a)

142 => a -> SerialT m a -> m (Bool, Bool)

143teeFstAllAny value =

144 IP.parse (PR.teeWithFst (,) (PR.all (<= value)) (PR.any (> value)))

145

146{-# INLINE shortestAllAny #-}

147shortestAllAny :: (MonadCatch m, Ord a)

148 => a -> SerialT m a -> m Bool

149shortestAllAny value =

150 IP.parse (PR.shortest (PR.all (<= value)) (PR.any (> value)))

151

152{-# INLINE longestAllAny #-}

153longestAllAny :: (MonadCatch m, Ord a)

154 => a -> SerialT m a -> m Bool

155longestAllAny value =

156 IP.parse (PR.longest (PR.all (<= value)) (PR.any (> value)))

157

158-------------------------------------------------------------------------------

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

160-------------------------------------------------------------------------------

161

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

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

164-- not have to rely on it.

165--

166{-# INLINE lookAhead #-}

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

168lookAhead value =

169 IP.parse (PR.lookAhead (PR.takeWhile (<= value) FL.drain) *> pure ())

170

171{-# INLINE sequenceA #-}

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

173sequenceA value xs = do

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

175 return $ length x

176

177{-# INLINE sequenceA_ #-}

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

179sequenceA_ value =

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

181

182{-# INLINE sequence #-}

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

184sequence value xs = do

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

186 return $ length x

187

188{-# INLINE sequence_ #-}

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

190sequence_ value =

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

192

193{-# INLINE choice #-}

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

195choice value =

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

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

198

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

200-- Stream transformation

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

202

203{-# INLINE parseMany #-}

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

205parseMany =

206 S.drain

207 . S.map getSum

208 . IP.parseMany (PR.take 2 FL.mconcat)

209 . S.map Sum

210

211{-# INLINE parseIterate #-}

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

213parseIterate =

214 S.drain

215 . S.map getSum

216 . IP.parseIterate (\b -> (PR.take 2 (FL.sconcat b))) (Sum 0)

217 . S.map Sum

218

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

220-- Benchmarks

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

222

223moduleName :: String

224moduleName = "Data.Parser"

225

226o_1_space_serial :: Int -> [Benchmark]

227o_1_space_serial value =

228 [ benchIOSink value "any" $ any value

229 , benchIOSink value "all" $ all value

230 , benchIOSink value "take" $ take value

231 , benchIOSink value "takeWhile" $ takeWhile value

232 , benchIOSink value "splitAp" $ splitAp value

233 , benchIOSink value "splitApBefore" $ splitApBefore value

234 , benchIOSink value "splitApAfter" $ splitApAfter value

235 , benchIOSink value "splitWith" $ splitWith value

236 , benchIOSink value "many" many

237 , benchIOSink value "some" some

238 , benchIOSink value "manyTill" $ manyTill value

239 , benchIOSink value "tee" $ teeAllAny value

240 , benchIOSink value "teeFst" $ teeFstAllAny value

241 , benchIOSink value "shortest" $ shortestAllAny value

242 , benchIOSink value "longest" $ longestAllAny value

243 , benchIOSink value "parseMany" parseMany

244 , benchIOSink value "parseIterate" parseIterate

245 ]

246

247o_n_heap_serial :: Int -> [Benchmark]

248o_n_heap_serial value =

249 [

250 -- lookahead benchmark holds the entire input till end

251 benchIOSink value "lookAhead" $ lookAhead value

252

253 -- accumulates the results in a list

254 , benchIOSink value "sequence" $ sequence value

255 , benchIOSink value "sequenceA" $ sequenceA value

256

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

258 , benchIOSink value "sequence_" $ sequence_ value

259 , benchIOSink value "sequenceA_" $ sequenceA_ value

260 -- non-linear time complexity (parserD)

261 , benchIOSink value "split_" $ split_ value

262 -- XXX why O(n) heap?

263 , benchIOSink value "choice" $ choice value

264

265 -- These show non-linear time complexity.

266 -- They accumulate the results in a list.

267 , benchIOSink value "manyAlt" manyAlt

268 , benchIOSink value "someAlt" someAlt

269 ]

270

271-------------------------------------------------------------------------------

272-- Driver

273-------------------------------------------------------------------------------

274

275main :: IO ()

276main = do

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

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

279

280 where

281

282 allBenchmarks value =

283 [ bgroup (o_1_space_prefix moduleName) $ concat

284 [

285 o_1_space_serial value

286 ]

287 , bgroup (o_n_heap_prefix moduleName) $ concat

288 [

289 o_n_heap_serial value

290 ]

291 ]