git.iko.soy/streamly
on 30c98dc help sign in
streamly/benchmark/Streamly/Benchmark/Data/Stream/Exceptions.hs
346 lines 11 kB history raw
1-- |
2-- Module : Stream.Exceptions
3-- Copyright : (c) 2019 Composewell Technologies
4-- License : BSD-3-Clause
5-- Maintainer : streamly@composewell.com
6-- Stability : experimental
7-- Portability : GHC
9{-# LANGUAGE CPP #-}
10{-# LANGUAGE FlexibleContexts #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13#ifdef __HADDOCK_VERSION__
14#undef INSPECTION
15#endif
17#ifdef INSPECTION
18{-# LANGUAGE TemplateHaskell #-}
19{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
20#endif
22module Stream.Exceptions (benchmarks) where
24import Control.Exception (Exception, throwIO)
25import Stream.Common (drain)
26import Streamly.Internal.Data.Stream (Stream)
28import qualified Data.IORef as Ref
29import qualified Data.Map.Strict as Map
30import qualified Stream.Common as Common
32#ifndef USE_STREAMLY_CORE
33import Control.Exception (SomeException)
34import System.IO (Handle, hClose, hPutChar)
35import qualified Streamly.FileSystem.Handle as FH
36import qualified Streamly.Internal.FileSystem.Handle as IFH
37import qualified Streamly.Internal.Data.Unfold as IUF
38#endif
40#ifdef USE_PRELUDE
41import qualified Streamly.Internal.Data.Stream.IsStream as Stream
42#else
43import qualified Streamly.Internal.Data.Stream as Stream
44#endif
46import Gauge hiding (env)
47import Prelude hiding (last, length)
48import Streamly.Benchmark.Common
49import Streamly.Benchmark.Common.Handle
51#ifdef INSPECTION
52import Test.Inspection
54import qualified Streamly.Internal.Data.Stream.StreamD as D
55#endif
57-------------------------------------------------------------------------------
58-- stream exceptions
59-------------------------------------------------------------------------------
61{-# INLINE replicateM #-}
62replicateM :: Common.MonadAsync m => Int -> m a -> Stream m a
63#ifdef USE_PRELUDE
64replicateM = Stream.replicateM
65#else
66replicateM n = Stream.sequence . Stream.replicate n
67#endif
69data BenchException
70 = BenchException1
71 | BenchException2
72 deriving (Show, Eq, Ord)
74instance Exception BenchException
76retryNoneSimple :: Int -> Int -> IO ()
77retryNoneSimple length from =
78 drain
79 $ Stream.retry
80 (Map.singleton BenchException1 length)
81 (const Stream.nil)
82 source
84 where
86 source = Stream.enumerateFromTo from (from + length)
88retryNone :: Int -> Int -> IO ()
89retryNone length from = do
90 ref <- Ref.newIORef (0 :: Int)
91 drain
92 $ Stream.retry (Map.singleton BenchException1 length) (const Stream.nil)
93 $ source ref
95 where
97 source ref =
98 replicateM (from + length)
99 $ Ref.modifyIORef' ref (+ 1) >> Ref.readIORef ref
101retryAll :: Int -> Int -> IO ()
102retryAll length from = do
103 ref <- Ref.newIORef 0
104 drain
105 $ Stream.retry
106 (Map.singleton BenchException1 (length + from)) (const Stream.nil)
107 $ source ref
109 where
111 source ref =
112 Stream.fromEffect
113 $ do
114 Ref.modifyIORef' ref (+ 1)
115 val <- Ref.readIORef ref
116 if val >= length
117 then return length
118 else throwIO BenchException1
120retryUnknown :: Int -> Int -> IO ()
121retryUnknown length from = do
122 drain
123 $ Stream.retry (Map.singleton BenchException1 length) (const source)
124 $ throwIO BenchException2 `Stream.before` Stream.nil
126 where
128 source = Stream.enumerateFromTo from (from + length)
131o_1_space_serial_exceptions :: Int -> [Benchmark]
132o_1_space_serial_exceptions length =
133 [ bgroup
134 "exceptions/serial"
135 [ benchIOSrc1 "retryNoneSimple" (retryNoneSimple length)
136 , benchIOSrc1 "retryNone" (retryNone length)
137 , benchIOSrc1 "retryAll" (retryAll length)
138 , benchIOSrc1 "retryUnknown" (retryUnknown length)
139 ]
140 ]
142-- XXX Move these to FileSystem.Handle benchmarks
143#ifndef USE_STREAMLY_CORE
145-------------------------------------------------------------------------------
146-- copy stream exceptions
147-------------------------------------------------------------------------------
149-- | Send the file contents to /dev/null with exception handling
150readWriteOnExceptionStream :: Handle -> Handle -> IO ()
151readWriteOnExceptionStream inh devNull =
152 let readEx = Stream.onException (hClose inh) (Stream.unfold FH.read inh)
153 in Stream.fold (FH.write devNull) readEx
155#ifdef INSPECTION
156inspect $ hasNoTypeClasses 'readWriteOnExceptionStream
157#endif
159-- | Send the file contents to /dev/null with exception handling
160readWriteHandleExceptionStream :: Handle -> Handle -> IO ()
161readWriteHandleExceptionStream inh devNull =
162 let handler (_e :: SomeException) = Stream.fromEffect (hClose inh >> return 10)
163 readEx = Stream.handle handler (Stream.unfold FH.read inh)
164 in Stream.fold (FH.write devNull) readEx
166#ifdef INSPECTION
167inspect $ hasNoTypeClasses 'readWriteHandleExceptionStream
168#endif
170-- | Send the file contents to /dev/null with exception handling
171readWriteFinally_Stream :: Handle -> Handle -> IO ()
172readWriteFinally_Stream inh devNull =
173 let readEx = Stream.finally_ (hClose inh) (Stream.unfold FH.read inh)
174 in Stream.fold (FH.write devNull) readEx
176#ifdef INSPECTION
177inspect $ hasNoTypeClasses 'readWriteFinally_Stream
178#endif
180readWriteFinallyStream :: Handle -> Handle -> IO ()
181readWriteFinallyStream inh devNull =
182 let readEx = Stream.finally (hClose inh) (Stream.unfold FH.read inh)
183 in Stream.fold (FH.write devNull) readEx
185-- | Send the file contents to /dev/null with exception handling
186fromToBytesBracket_Stream :: Handle -> Handle -> IO ()
187fromToBytesBracket_Stream inh devNull =
188 let readEx = Stream.bracket_ (return ()) (\_ -> hClose inh)
189 (\_ -> IFH.getBytes inh)
190 in IFH.putBytes devNull readEx
192#ifdef INSPECTION
193inspect $ hasNoTypeClasses 'fromToBytesBracket_Stream
194#endif
196fromToBytesBracketStream :: Handle -> Handle -> IO ()
197fromToBytesBracketStream inh devNull =
198 let readEx = Stream.bracket (return ()) (\_ -> hClose inh)
199 (\_ -> IFH.getBytes inh)
200 in IFH.putBytes devNull readEx
202readWriteBeforeAfterStream :: Handle -> Handle -> IO ()
203readWriteBeforeAfterStream inh devNull =
204 let readEx =
205 Stream.after (hClose inh)
206 $ Stream.before (hPutChar devNull 'A') (Stream.unfold FH.read inh)
207 in Stream.fold (FH.write devNull) readEx
209#ifdef INSPECTION
210inspect $ 'readWriteBeforeAfterStream `hasNoType` ''D.Step
211#endif
213readWriteAfterStream :: Handle -> Handle -> IO ()
214readWriteAfterStream inh devNull =
215 let readEx = Stream.after (hClose inh) (Stream.unfold FH.read inh)
216 in Stream.fold (FH.write devNull) readEx
218#ifdef INSPECTION
219inspect $ 'readWriteAfterStream `hasNoType` ''D.Step
220#endif
222readWriteAfter_Stream :: Handle -> Handle -> IO ()
223readWriteAfter_Stream inh devNull =
224 let readEx = Stream.after_ (hClose inh) (Stream.unfold FH.read inh)
225 in Stream.fold (FH.write devNull) readEx
227#ifdef INSPECTION
228inspect $ hasNoTypeClasses 'readWriteAfter_Stream
229inspect $ 'readWriteAfter_Stream `hasNoType` ''D.Step
230#endif
232o_1_space_copy_stream_exceptions :: BenchEnv -> [Benchmark]
233o_1_space_copy_stream_exceptions env =
234 [ bgroup "exceptions"
235 [ mkBenchSmall "Stream.onException" env $ \inh _ ->
236 readWriteOnExceptionStream inh (nullH env)
237 , mkBenchSmall "Stream.handle" env $ \inh _ ->
238 readWriteHandleExceptionStream inh (nullH env)
239 , mkBenchSmall "Stream.finally_" env $ \inh _ ->
240 readWriteFinally_Stream inh (nullH env)
241 , mkBenchSmall "Stream.finally" env $ \inh _ ->
242 readWriteFinallyStream inh (nullH env)
243 , mkBenchSmall "Stream.after . Stream.before" env $ \inh _ ->
244 readWriteBeforeAfterStream inh (nullH env)
245 , mkBenchSmall "Stream.after" env $ \inh _ ->
246 readWriteAfterStream inh (nullH env)
247 , mkBenchSmall "Stream.after_" env $ \inh _ ->
248 readWriteAfter_Stream inh (nullH env)
249 ]
250 , bgroup "exceptions/fromToBytes"
251 [ mkBenchSmall "Stream.bracket_" env $ \inh _ ->
252 fromToBytesBracket_Stream inh (nullH env)
253 , mkBenchSmall "Stream.bracket" env $ \inh _ ->
254 fromToBytesBracketStream inh (nullH env)
255 ]
256 ]
258 -------------------------------------------------------------------------------
259-- Exceptions readChunks
260-------------------------------------------------------------------------------
262-- | Send the file contents to /dev/null with exception handling
263readChunksOnException :: Handle -> Handle -> IO ()
264readChunksOnException inh devNull =
265 let readEx = IUF.onException (\_ -> hClose inh) FH.readChunks
266 in IUF.fold (IFH.writeChunks devNull) readEx inh
268#ifdef INSPECTION
269inspect $ hasNoTypeClasses 'readChunksOnException
270#endif
272-- | Send the file contents to /dev/null with exception handling
273readChunksBracket_ :: Handle -> Handle -> IO ()
274readChunksBracket_ inh devNull =
275 let readEx = IUF.bracket_ return (\_ -> hClose inh) FH.readChunks
276 in IUF.fold (IFH.writeChunks devNull) readEx inh
278#ifdef INSPECTION
279inspect $ hasNoTypeClasses 'readChunksBracket_
280#endif
282readChunksBracket :: Handle -> Handle -> IO ()
283readChunksBracket inh devNull =
284 let readEx = IUF.bracket return (\_ -> hClose inh) FH.readChunks
285 in IUF.fold (IFH.writeChunks devNull) readEx inh
287o_1_space_copy_exceptions_readChunks :: BenchEnv -> [Benchmark]
288o_1_space_copy_exceptions_readChunks env =
289 [ bgroup "exceptions/readChunks"
290 [ mkBench "UF.onException" env $ \inH _ ->
291 readChunksOnException inH (nullH env)
292 , mkBench "UF.bracket_" env $ \inH _ ->
293 readChunksBracket_ inH (nullH env)
294 , mkBench "UF.bracket" env $ \inH _ ->
295 readChunksBracket inH (nullH env)
296 ]
297 ]
299-------------------------------------------------------------------------------
300-- Exceptions toChunks
301-------------------------------------------------------------------------------
303-- | Send the file contents to /dev/null with exception handling
304toChunksBracket_ :: Handle -> Handle -> IO ()
305toChunksBracket_ inh devNull =
306 let readEx = Stream.bracket_
307 (return ())
308 (\_ -> hClose inh)
309 (\_ -> IFH.getChunks inh)
310 in Stream.fold (IFH.writeChunks devNull) readEx
312#ifdef INSPECTION
313inspect $ hasNoTypeClasses 'toChunksBracket_
314#endif
316toChunksBracket :: Handle -> Handle -> IO ()
317toChunksBracket inh devNull =
318 let readEx = Stream.bracket
319 (return ())
320 (\_ -> hClose inh)
321 (\_ -> IFH.getChunks inh)
322 in Stream.fold (IFH.writeChunks devNull) readEx
324o_1_space_copy_exceptions_toChunks :: BenchEnv -> [Benchmark]
325o_1_space_copy_exceptions_toChunks env =
326 [ bgroup "exceptions/toChunks"
327 [ mkBench "Stream.bracket_" env $ \inH _ ->
328 toChunksBracket_ inH (nullH env)
329 , mkBench "Stream.bracket" env $ \inH _ ->
330 toChunksBracket inH (nullH env)
331 ]
332 ]
334#endif
336benchmarks :: String -> BenchEnv -> Int -> [Benchmark]
337benchmarks moduleName _env size =
338 [ bgroup (o_1_space_prefix moduleName) $ concat
339 [ o_1_space_serial_exceptions size
340#ifndef USE_STREAMLY_CORE
341 , o_1_space_copy_exceptions_readChunks _env
342 , o_1_space_copy_exceptions_toChunks _env
343 , o_1_space_copy_stream_exceptions _env
344#endif
345 ]
346 ]