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

git.iko.soy/streamly

on beabbcc help sign in

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

243 lines 8.1 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{-# OPTIONS_GHC -fspec-constr-recursive=4 #-}

11module Main

12 (

13 main

14 ) where

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

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

18import Data.Foldable (asum)

19import System.Random (randomRIO)

20import Prelude hiding (any, all, take, sequence, sequenceA, takeWhile)

22import qualified Data.Traversable as TR

23import qualified Data.Foldable as F

24import qualified Control.Applicative as AP

25import qualified Streamly.Prelude as S

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

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

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

30import Gauge

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

32import Streamly.Benchmark.Common

34-------------------------------------------------------------------------------

35-- Utilities

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

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

40{-# INLINE sourceUnfoldrM #-}

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

42sourceUnfoldrM value n = S.unfoldrM step n

43 where

44 step cnt =

45 if cnt > n + value

46 then return Nothing

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

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

50{-# INLINE benchIOSink #-}

51benchIOSink

52 :: (IsStream t, NFData b)

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

54benchIOSink value name f =

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

57-------------------------------------------------------------------------------

58-- Parsers

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

61{-# INLINE any #-}

62any :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool

63any value = IP.parseD (PR.any (> value))

65{-# INLINE all #-}

66all :: (MonadThrow m, Ord a) => a -> SerialT m a -> m Bool

67all value = IP.parseD (PR.all (<= value))

69{-# INLINE take #-}

70take :: MonadThrow m => Int -> SerialT m a -> m ()

71take value = IP.parseD (PR.take value FL.drain)

73{-# INLINE takeWhile #-}

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

75takeWhile value = IP.parseD (PR.takeWhile (<= value) FL.drain)

77{-# INLINE many #-}

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

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

81{-# INLINE manyAlt #-}

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

83manyAlt xs = do

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

85 return $ Prelude.length x

87{-# INLINE some #-}

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

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

91{-# INLINE someAlt #-}

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

93someAlt xs = do

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

95 return $ Prelude.length x

97{-# INLINE manyTill #-}

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

99manyTill value =

100 let p = PR.satisfy (> 0)

101 pcond = PR.satisfy (== value)

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

103

104{-# INLINE splitAllAny #-}

105splitAllAny :: MonadThrow m

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

107splitAllAny value =

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

109

110{-# INLINE teeAllAny #-}

111teeAllAny :: (MonadThrow m, Ord a)

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

113teeAllAny value =

114 IP.parseD (PR.teeWith (,) (PR.all (<= value)) (PR.any (> value)))

115

116{-# INLINE teeFstAllAny #-}

117teeFstAllAny :: (MonadThrow m, Ord a)

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

119teeFstAllAny value =

120 IP.parseD (PR.teeWithFst (,) (PR.all (<= value)) (PR.any (> value)))

121

122{-# INLINE shortestAllAny #-}

123shortestAllAny :: (MonadThrow m, Ord a)

124 => a -> SerialT m a -> m Bool

125shortestAllAny value =

126 IP.parseD (PR.shortest (PR.all (<= value)) (PR.any (> value)))

127

128{-# INLINE longestAllAny #-}

129longestAllAny :: (MonadCatch m, Ord a)

130 => a -> SerialT m a -> m Bool

131longestAllAny value =

132 IP.parseD (PR.longest (PR.all (<= value)) (PR.any (> value)))

133

134-------------------------------------------------------------------------------

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

136-------------------------------------------------------------------------------

137

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

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

140-- not have to rely on it.

141--

142{-# INLINE lookAhead #-}

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

144lookAhead value =

145 IP.parseD (PR.lookAhead (PR.takeWhile (<= value) FL.drain) *> pure ())

146

147{-# INLINE sequenceA_ #-}

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

149sequenceA_ value =

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

151

152-- quadratic complexity

153{-# INLINE sequenceA #-}

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

155sequenceA value xs = do

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

157 return $ length x

158

159-- quadratic complexity

160{-# INLINE sequence #-}

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

162sequence value xs = do

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

164 return $ length x

165

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

167-- quadratic performance complexity.

168--

169{-# INLINE choice #-}

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

171choice value =

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

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

174

175-------------------------------------------------------------------------------

176-- Benchmarks

177-------------------------------------------------------------------------------

178

179moduleName :: String

180moduleName = "Data.Parser.ParserD"

181

182o_1_space_serial :: Int -> [Benchmark]

183o_1_space_serial value =

184 [ benchIOSink value "any" $ any value

185 , benchIOSink value "all" $ all value

186 , benchIOSink value "take" $ take value

187 , benchIOSink value "takeWhile" $ takeWhile value

188 , benchIOSink value "split (all,any)" $ splitAllAny value

189 , benchIOSink value "many" many

190 , benchIOSink value "some" some

191 , benchIOSink value "manyTill" $ manyTill value

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

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

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

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

196 ]

197

198o_n_heap_serial :: Int -> [Benchmark]

199o_n_heap_serial value =

200 [

201 -- lookahead benchmark holds the entire input till end

202 benchIOSink value "lookAhead" $ lookAhead value

203

204 -- These show non-linear time complexity

205 -- They accumulate the results in a list.

206 , benchIOSink value "manyAlt" manyAlt

207 , benchIOSink value "someAlt" someAlt

208 ]

209

210-- accumulate results in a list in IO

211o_n_space_serial :: Int -> [Benchmark]

212o_n_space_serial value =

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

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

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

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

217 ]

218

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

220-- Driver

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

222

223main :: IO ()

224main = do

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

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

227

228 where

229

230 allBenchmarks value =

231 [ bgroup (o_1_space_prefix moduleName) $ concat

232 [

233 o_1_space_serial value

234 ]

235 , bgroup (o_n_heap_prefix moduleName) $ concat

236 [

237 o_n_heap_serial value

238 ]

239 , bgroup (o_n_space_prefix moduleName) $ concat

240 [

241 o_n_space_serial value

242 ]

243 ]