git.iko.soy/streamly
on 1946eb8 help sign in
streamly/benchmark/Streamly/Benchmark/Data/Stream/Exceptions.hs
361 lines 12 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 USE_PRELUDE
14{-# OPTIONS_GHC -Wno-deprecations #-}
15#endif
17#ifdef __HADDOCK_VERSION__
18#undef INSPECTION
19#endif
21#ifdef INSPECTION
22{-# LANGUAGE TemplateHaskell #-}
23{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
24#endif
26module Stream.Exceptions (benchmarks) where
28import Control.Exception (Exception, throwIO)
29import Stream.Common (drain)
31import qualified Data.IORef as Ref
32import qualified Data.Map.Strict as Map
34import Control.Exception (SomeException)
35import System.IO (Handle, hClose, hPutChar)
36import qualified Streamly.FileSystem.Handle as FH
37import qualified Streamly.Internal.FileSystem.Handle as IFH
38import qualified Streamly.Internal.Data.Unfold as IUF
39import qualified Streamly.Internal.Data.Unfold.Exception as IUF
41#ifdef USE_PRELUDE
42import qualified Streamly.Internal.Data.Stream.IsStream as Stream
43#else
44import qualified Streamly.Internal.Data.Stream.StreamD as Stream
45import qualified Streamly.Internal.Data.Stream.Exception.Lifted as Stream
46#endif
48import Gauge hiding (env)
49import Prelude hiding (last, length)
50import Streamly.Benchmark.Common
51import Streamly.Benchmark.Common.Handle
53#ifdef INSPECTION
54import Test.Inspection
56import qualified Streamly.Internal.Data.Stream.StreamD as D
57#endif
59#ifdef USE_PRELUDE
60type Stream = Stream.SerialT
61toStreamD = Stream.toStream
62fromStreamD = Stream.fromStream
63#else
64type Stream = Stream.Stream
65toStreamD :: a -> a
66toStreamD = id
67fromStreamD :: a -> a
68fromStreamD = id
69#endif
71afterUnsafe :: IO b -> Stream IO a -> Stream IO a
72finallyUnsafe :: IO b -> Stream IO a -> Stream IO a
73bracketUnsafe :: IO b -> (b -> IO c) -> (b -> Stream IO a) -> Stream IO a
74#ifdef USE_PRELUDE
75afterUnsafe = Stream.after_
76finallyUnsafe = Stream.finally_
77bracketUnsafe = Stream.bracket_
78#else
79afterUnsafe = Stream.afterUnsafe
80finallyUnsafe = Stream.finallyUnsafe
81bracketUnsafe = Stream.bracketUnsafe
82#endif
84-------------------------------------------------------------------------------
85-- stream exceptions
86-------------------------------------------------------------------------------
88data BenchException
89 = BenchException1
90 | BenchException2
91 deriving (Show, Eq, Ord)
93instance Exception BenchException
95retryNoneSimple :: Int -> Int -> IO ()
96retryNoneSimple length from =
97 drain
98 $ Stream.retry
99 (Map.singleton BenchException1 length)
100 (const Stream.nil)
101 source
103 where
105 source = Stream.enumerateFromTo from (from + length)
107retryNone :: Int -> Int -> IO ()
108retryNone length from = do
109 ref <- Ref.newIORef (0 :: Int)
110 drain
111 $ Stream.retry (Map.singleton BenchException1 length) (const Stream.nil)
112 $ source ref
114 where
116 source ref =
117 Stream.replicateM (from + length)
118 $ Ref.modifyIORef' ref (+ 1) >> Ref.readIORef ref
120retryAll :: Int -> Int -> IO ()
121retryAll length from = do
122 ref <- Ref.newIORef 0
123 drain
124 $ Stream.retry
125 (Map.singleton BenchException1 (length + from)) (const Stream.nil)
126 $ source ref
128 where
130 source ref =
131 Stream.fromEffect
132 $ do
133 Ref.modifyIORef' ref (+ 1)
134 val <- Ref.readIORef ref
135 if val >= length
136 then return length
137 else throwIO BenchException1
139retryUnknown :: Int -> Int -> IO ()
140retryUnknown length from = do
141 drain
142 $ Stream.retry (Map.singleton BenchException1 length) (const source)
143 $ throwIO BenchException2 `Stream.before` Stream.nil
145 where
147 source = Stream.enumerateFromTo from (from + length)
150o_1_space_serial_exceptions :: Int -> [Benchmark]
151o_1_space_serial_exceptions length =
152 [ bgroup
153 "exceptions/serial"
154 [ benchIOSrc1 "retryNoneSimple" (retryNoneSimple length)
155 , benchIOSrc1 "retryNone" (retryNone length)
156 , benchIOSrc1 "retryAll" (retryAll length)
157 , benchIOSrc1 "retryUnknown" (retryUnknown length)
158 ]
159 ]
161-- XXX Move these to FileSystem.Handle benchmarks
163-------------------------------------------------------------------------------
164-- copy stream exceptions
165-------------------------------------------------------------------------------
167-- | Send the file contents to /dev/null with exception handling
168readWriteOnExceptionStream :: Handle -> Handle -> IO ()
169readWriteOnExceptionStream inh devNull =
170 let readEx = Stream.onException (hClose inh) (Stream.unfold FH.reader inh)
171 in Stream.fold (FH.write devNull) readEx
173#ifdef INSPECTION
174inspect $ hasNoTypeClasses 'readWriteOnExceptionStream
175#endif
177-- | Send the file contents to /dev/null with exception handling
178readWriteHandleExceptionStream :: Handle -> Handle -> IO ()
179readWriteHandleExceptionStream inh devNull =
180 let handler (_e :: SomeException) = Stream.fromEffect (hClose inh >> return 10)
181 readEx = Stream.handle handler (Stream.unfold FH.reader inh)
182 in Stream.fold (FH.write devNull) readEx
184#ifdef INSPECTION
185inspect $ hasNoTypeClasses 'readWriteHandleExceptionStream
186#endif
188-- | Send the file contents to /dev/null with exception handling
189readWriteFinally_Stream :: Handle -> Handle -> IO ()
190readWriteFinally_Stream inh devNull =
191 let readEx =
192 finallyUnsafe (hClose inh) (Stream.unfold FH.reader inh)
193 in Stream.fold (FH.write devNull) readEx
195#ifdef INSPECTION
196inspect $ hasNoTypeClasses 'readWriteFinally_Stream
197#endif
199readWriteFinallyStream :: Handle -> Handle -> IO ()
200readWriteFinallyStream inh devNull =
201 let readEx = Stream.finally (hClose inh) (Stream.unfold FH.reader inh)
202 in Stream.fold (FH.write devNull) readEx
204-- | Send the file contents to /dev/null with exception handling
205fromToBytesBracket_Stream :: Handle -> Handle -> IO ()
206fromToBytesBracket_Stream inh devNull =
207 let readEx = bracketUnsafe (return ()) (\_ -> hClose inh)
208 (\_ -> fromStreamD $ IFH.read inh)
209 in IFH.putBytes devNull (toStreamD readEx)
211#ifdef INSPECTION
212inspect $ hasNoTypeClasses 'fromToBytesBracket_Stream
213#endif
215fromToBytesBracketStream :: Handle -> Handle -> IO ()
216fromToBytesBracketStream inh devNull =
217 let readEx = Stream.bracket (return ()) (\_ -> hClose inh)
218 (\_ -> fromStreamD $ IFH.read inh)
219 in IFH.putBytes devNull (toStreamD readEx)
221readWriteBeforeAfterStream :: Handle -> Handle -> IO ()
222readWriteBeforeAfterStream inh devNull =
223 let readEx =
224 Stream.after (hClose inh)
225 $ Stream.before (hPutChar devNull 'A') (Stream.unfold FH.reader inh)
226 in Stream.fold (FH.write devNull) readEx
228#ifdef INSPECTION
229inspect $ 'readWriteBeforeAfterStream `hasNoType` ''D.Step
230#endif
232readWriteAfterStream :: Handle -> Handle -> IO ()
233readWriteAfterStream inh devNull =
234 let readEx = Stream.after (hClose inh) (Stream.unfold FH.reader inh)
235 in Stream.fold (FH.write devNull) readEx
237#ifdef INSPECTION
238inspect $ 'readWriteAfterStream `hasNoType` ''D.Step
239#endif
241readWriteAfter_Stream :: Handle -> Handle -> IO ()
242readWriteAfter_Stream inh devNull =
243 let readEx = afterUnsafe (hClose inh) (Stream.unfold FH.reader inh)
244 in Stream.fold (FH.write devNull) readEx
246#ifdef INSPECTION
247inspect $ hasNoTypeClasses 'readWriteAfter_Stream
248inspect $ 'readWriteAfter_Stream `hasNoType` ''D.Step
249#endif
251o_1_space_copy_stream_exceptions :: BenchEnv -> [Benchmark]
252o_1_space_copy_stream_exceptions env =
253 [ bgroup "exceptions"
254 [ mkBenchSmall "Stream.onException" env $ \inh _ ->
255 readWriteOnExceptionStream inh (nullH env)
256 , mkBenchSmall "Stream.handle" env $ \inh _ ->
257 readWriteHandleExceptionStream inh (nullH env)
258 , mkBenchSmall "Stream.finally_" env $ \inh _ ->
259 readWriteFinally_Stream inh (nullH env)
260 , mkBenchSmall "Stream.finally" env $ \inh _ ->
261 readWriteFinallyStream inh (nullH env)
262 , mkBenchSmall "Stream.after . Stream.before" env $ \inh _ ->
263 readWriteBeforeAfterStream inh (nullH env)
264 , mkBenchSmall "Stream.after" env $ \inh _ ->
265 readWriteAfterStream inh (nullH env)
266 , mkBenchSmall "Stream.after_" env $ \inh _ ->
267 readWriteAfter_Stream inh (nullH env)
268 ]
269 , bgroup "exceptions/fromToBytes"
270 [ mkBenchSmall "Stream.bracket_" env $ \inh _ ->
271 fromToBytesBracket_Stream inh (nullH env)
272 , mkBenchSmall "Stream.bracket" env $ \inh _ ->
273 fromToBytesBracketStream inh (nullH env)
274 ]
275 ]
277 -------------------------------------------------------------------------------
278-- Exceptions readChunks
279-------------------------------------------------------------------------------
281-- | Send the file contents to /dev/null with exception handling
282readChunksOnException :: Handle -> Handle -> IO ()
283readChunksOnException inh devNull =
284 let readEx = IUF.onException (\_ -> hClose inh) FH.chunkReader
285 in IUF.fold (IFH.writeChunks devNull) readEx inh
287#ifdef INSPECTION
288inspect $ hasNoTypeClasses 'readChunksOnException
289#endif
291-- | Send the file contents to /dev/null with exception handling
292readChunksBracket_ :: Handle -> Handle -> IO ()
293readChunksBracket_ inh devNull =
294 let readEx = IUF.bracket_ return (\_ -> hClose inh) FH.chunkReader
295 in IUF.fold (IFH.writeChunks devNull) readEx inh
297#ifdef INSPECTION
298inspect $ hasNoTypeClasses 'readChunksBracket_
299#endif
301readChunksBracket :: Handle -> Handle -> IO ()
302readChunksBracket inh devNull =
303 let readEx = IUF.bracket return (\_ -> hClose inh) FH.chunkReader
304 in IUF.fold (IFH.writeChunks devNull) readEx inh
306o_1_space_copy_exceptions_readChunks :: BenchEnv -> [Benchmark]
307o_1_space_copy_exceptions_readChunks env =
308 [ bgroup "exceptions/readChunks"
309 [ mkBench "UF.onException" env $ \inH _ ->
310 readChunksOnException inH (nullH env)
311 , mkBench "UF.bracket_" env $ \inH _ ->
312 readChunksBracket_ inH (nullH env)
313 , mkBench "UF.bracket" env $ \inH _ ->
314 readChunksBracket inH (nullH env)
315 ]
316 ]
318-------------------------------------------------------------------------------
319-- Exceptions toChunks
320-------------------------------------------------------------------------------
322-- | Send the file contents to /dev/null with exception handling
323toChunksBracket_ :: Handle -> Handle -> IO ()
324toChunksBracket_ inh devNull =
325 let readEx = bracketUnsafe
326 (return ())
327 (\_ -> hClose inh)
328 (\_ -> fromStreamD $ IFH.readChunks inh)
329 in Stream.fold (IFH.writeChunks devNull) readEx
331#ifdef INSPECTION
332inspect $ hasNoTypeClasses 'toChunksBracket_
333#endif
335toChunksBracket :: Handle -> Handle -> IO ()
336toChunksBracket inh devNull =
337 let readEx = Stream.bracket
338 (return ())
339 (\_ -> hClose inh)
340 (\_ -> fromStreamD $ IFH.readChunks inh)
341 in Stream.fold (IFH.writeChunks devNull) readEx
343o_1_space_copy_exceptions_toChunks :: BenchEnv -> [Benchmark]
344o_1_space_copy_exceptions_toChunks env =
345 [ bgroup "exceptions/toChunks"
346 [ mkBench "Stream.bracket_" env $ \inH _ ->
347 toChunksBracket_ inH (nullH env)
348 , mkBench "Stream.bracket" env $ \inH _ ->
349 toChunksBracket inH (nullH env)
350 ]
351 ]
353benchmarks :: String -> BenchEnv -> Int -> [Benchmark]
354benchmarks moduleName _env size =
355 [ bgroup (o_1_space_prefix moduleName) $ concat
356 [ o_1_space_serial_exceptions size
357 , o_1_space_copy_exceptions_readChunks _env
358 , o_1_space_copy_exceptions_toChunks _env
359 , o_1_space_copy_stream_exceptions _env
360 ]
361 ]