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

git.iko.soy/streamly

on 294aa21 help sign in

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

292 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 as S hiding (runStream)

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.Prelude as IP

33import Gauge

34import Streamly hiding (runStream)

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 :: (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 any #-}

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

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

68{-# INLINE all #-}

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

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

72{-# INLINE take #-}

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

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

76{-# INLINE takeWhile #-}

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

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

80{-# INLINE many #-}

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

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

84{-# INLINE manyAlt #-}

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

86manyAlt xs = do

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

88 return $ Prelude.length x

90{-# INLINE some #-}

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

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

94{-# INLINE someAlt #-}

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

96someAlt xs = do

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

98 return $ Prelude.length x

100{-# INLINE manyTill #-}

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

102manyTill value =

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

104

105{-# INLINE splitAp #-}

106splitAp :: MonadCatch m

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

108splitAp value =

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

110

111{-# INLINE splitApBefore #-}

112splitApBefore :: MonadCatch m

113 => Int -> SerialT m Int -> m Bool

114splitApBefore value =

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

116

117{-# INLINE splitApAfter #-}

118splitApAfter :: MonadCatch m

119 => Int -> SerialT m Int -> m Bool

120splitApAfter value =

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

122

123{-# INLINE splitWith #-}

124splitWith :: MonadCatch m

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

126splitWith value =

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

128

129{-# INLINE split_ #-}

130split_ :: MonadCatch m

131 => Int -> SerialT m Int -> m Bool

132split_ value =

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

134

135{-# INLINE teeAllAny #-}

136teeAllAny :: (MonadCatch m, Ord a)

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

138teeAllAny value =

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

140

141{-# INLINE teeFstAllAny #-}

142teeFstAllAny :: (MonadCatch m, Ord a)

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

144teeFstAllAny value =

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

146

147{-# INLINE shortestAllAny #-}

148shortestAllAny :: (MonadCatch m, Ord a)

149 => a -> SerialT m a -> m Bool

150shortestAllAny value =

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

152

153{-# INLINE longestAllAny #-}

154longestAllAny :: (MonadCatch m, Ord a)

155 => a -> SerialT m a -> m Bool

156longestAllAny value =

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

158

159-------------------------------------------------------------------------------

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

161-------------------------------------------------------------------------------

162

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

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

165-- not have to rely on it.

166--

167{-# INLINE lookAhead #-}

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

169lookAhead value =

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

171

172{-# INLINE sequenceA #-}

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

174sequenceA value xs = do

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

176 return $ length x

177

178{-# INLINE sequenceA_ #-}

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

180sequenceA_ value =

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

182

183{-# INLINE sequence #-}

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

185sequence value xs = do

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

187 return $ length x

188

189{-# INLINE sequence_ #-}

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

191sequence_ value =

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

193

194{-# INLINE choice #-}

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

196choice value =

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

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

199

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

201-- Stream transformation

202-------------------------------------------------------------------------------

203

204{-# INLINE parseMany #-}

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

206parseMany =

207 S.drain

208 . S.map getSum

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

210 . S.map Sum

211

212{-# INLINE parseIterate #-}

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

214parseIterate =

215 S.drain

216 . S.map getSum

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

218 . S.map Sum

219

220-------------------------------------------------------------------------------

221-- Benchmarks

222-------------------------------------------------------------------------------

223

224moduleName :: String

225moduleName = "Data.Parser"

226

227o_1_space_serial :: Int -> [Benchmark]

228o_1_space_serial value =

229 [ benchIOSink value "any" $ any value

230 , benchIOSink value "all" $ all value

231 , benchIOSink value "take" $ take value

232 , benchIOSink value "takeWhile" $ takeWhile value

233 , benchIOSink value "splitAp" $ splitAp value

234 , benchIOSink value "splitApBefore" $ splitApBefore value

235 , benchIOSink value "splitApAfter" $ splitApAfter value

236 , benchIOSink value "splitWith" $ splitWith value

237 , benchIOSink value "many" many

238 , benchIOSink value "some" some

239 , benchIOSink value "manyTill" $ manyTill value

240 , benchIOSink value "tee" $ teeAllAny value

241 , benchIOSink value "teeFst" $ teeFstAllAny value

242 , benchIOSink value "shortest" $ shortestAllAny value

243 , benchIOSink value "longest" $ longestAllAny value

244 , benchIOSink value "parseMany" parseMany

245 , benchIOSink value "parseIterate" parseIterate

246 ]

247

248o_n_heap_serial :: Int -> [Benchmark]

249o_n_heap_serial value =

250 [

251 -- lookahead benchmark holds the entire input till end

252 benchIOSink value "lookAhead" $ lookAhead value

253

254 -- accumulates the results in a list

255 , benchIOSink value "sequence" $ sequence value

256 , benchIOSink value "sequenceA" $ sequenceA value

257

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

259 , benchIOSink value "sequence_" $ sequence_ value

260 , benchIOSink value "sequenceA_" $ sequenceA_ value

261 -- non-linear time complexity (parserD)

262 , benchIOSink value "split_" $ split_ value

263 -- XXX why O(n) heap?

264 , benchIOSink value "choice" $ choice value

265

266 -- These show non-linear time complexity.

267 -- They accumulate the results in a list.

268 , benchIOSink value "manyAlt" manyAlt

269 , benchIOSink value "someAlt" someAlt

270 ]

271

272-------------------------------------------------------------------------------

273-- Driver

274-------------------------------------------------------------------------------

275

276main :: IO ()

277main = do

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

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

280

281 where

282

283 allBenchmarks value =

284 [ bgroup (o_1_space_prefix moduleName) $ concat

285 [

286 o_1_space_serial value

287 ]

288 , bgroup (o_n_heap_prefix moduleName) $ concat

289 [

290 o_n_heap_serial value

291 ]

292 ]