git.iko.soy/streamly
on a11fe00 help sign in
streamly/benchmark/Streamly/Benchmark/Data/Stream/Exceptions.hs
371 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 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 Control.Monad.Catch (MonadCatch)
55import Test.Inspection
57import qualified Streamly.Internal.Data.Stream as D
58#endif
60#ifdef USE_PRELUDE
61type Stream = Stream.SerialT
62toStreamD = Stream.toStream
63fromStreamD = Stream.fromStream
64#else
65type Stream = Stream.Stream
66toStreamD :: a -> a
67toStreamD = id
68fromStreamD :: a -> a
69fromStreamD = id
70#endif
72afterUnsafe :: IO b -> Stream IO a -> Stream IO a
73finallyUnsafe :: IO b -> Stream IO a -> Stream IO a
74bracketUnsafe :: IO b -> (b -> IO c) -> (b -> Stream IO a) -> Stream IO a
75#ifdef USE_PRELUDE
76afterUnsafe = Stream.after_
77finallyUnsafe = Stream.finally_
78bracketUnsafe = Stream.bracket_
79#else
80afterUnsafe = Stream.afterUnsafe
81finallyUnsafe = Stream.finallyUnsafe
82bracketUnsafe = Stream.bracketUnsafe
83#endif
85-------------------------------------------------------------------------------
86-- stream exceptions
87-------------------------------------------------------------------------------
89data BenchException
90 = BenchException1
91 | BenchException2
92 deriving (Show, Eq, Ord)
94instance Exception BenchException
96retryNoneSimple :: Int -> Int -> IO ()
97retryNoneSimple length from =
98 drain
99 $ Stream.retry
100 (Map.singleton BenchException1 length)
101 (const Stream.nil)
102 source
104 where
106 source = Stream.enumerateFromTo from (from + length)
108retryNone :: Int -> Int -> IO ()
109retryNone length from = do
110 ref <- Ref.newIORef (0 :: Int)
111 drain
112 $ Stream.retry (Map.singleton BenchException1 length) (const Stream.nil)
113 $ source ref
115 where
117 source ref =
118 Stream.replicateM (from + length)
119 $ Ref.modifyIORef' ref (+ 1) >> Ref.readIORef ref
121retryAll :: Int -> Int -> IO ()
122retryAll length from = do
123 ref <- Ref.newIORef 0
124 drain
125 $ Stream.retry
126 (Map.singleton BenchException1 (length + from)) (const Stream.nil)
127 $ source ref
129 where
131 source ref =
132 Stream.fromEffect
133 $ do
134 Ref.modifyIORef' ref (+ 1)
135 val <- Ref.readIORef ref
136 if val >= length
137 then return length
138 else throwIO BenchException1
140retryUnknown :: Int -> Int -> IO ()
141retryUnknown length from = do
142 drain
143 $ Stream.retry (Map.singleton BenchException1 length) (const source)
144 $ throwIO BenchException2 `Stream.before` Stream.nil
146 where
148 source = Stream.enumerateFromTo from (from + length)
151o_1_space_serial_exceptions :: Int -> [Benchmark]
152o_1_space_serial_exceptions length =
153 [ bgroup
154 "exceptions/serial"
155 [ benchIOSrc1 "retryNoneSimple" (retryNoneSimple length)
156 , benchIOSrc1 "retryNone" (retryNone length)
157 , benchIOSrc1 "retryAll" (retryAll length)
158 , benchIOSrc1 "retryUnknown" (retryUnknown length)
159 ]
160 ]
162-- XXX Move these to FileSystem.Handle benchmarks
164-------------------------------------------------------------------------------
165-- copy stream exceptions
166-------------------------------------------------------------------------------
168-- | Send the file contents to /dev/null with exception handling
169readWriteOnExceptionStream :: Handle -> Handle -> IO ()
170readWriteOnExceptionStream inh devNull =
171 let readEx = Stream.onException (hClose inh) (Stream.unfold FH.reader inh)
172 in Stream.fold (FH.write devNull) readEx
174#ifdef INSPECTION
175inspect $ hasNoTypeClasses 'readWriteOnExceptionStream
176#endif
178-- | Send the file contents to /dev/null with exception handling
179readWriteHandleExceptionStream :: Handle -> Handle -> IO ()
180readWriteHandleExceptionStream inh devNull =
181 let handler (_e :: SomeException) =
182 return $ Stream.fromEffect (hClose inh >> return 10)
183 readEx = Stream.handle handler (Stream.unfold FH.reader inh)
184 in Stream.fold (FH.write devNull) readEx
186#ifdef INSPECTION
187inspect $ hasNoTypeClasses 'readWriteHandleExceptionStream
188#endif
190-- | Send the file contents to /dev/null with exception handling
191readWriteFinally_Stream :: Handle -> Handle -> IO ()
192readWriteFinally_Stream inh devNull =
193 let readEx =
194 finallyUnsafe (hClose inh) (Stream.unfold FH.reader inh)
195 in Stream.fold (FH.write devNull) readEx
197#ifdef INSPECTION
198inspect $ hasNoTypeClasses 'readWriteFinally_Stream
199#endif
201readWriteFinallyStream :: Handle -> Handle -> IO ()
202readWriteFinallyStream inh devNull =
203 let readEx = Stream.finally (hClose inh) (Stream.unfold FH.reader inh)
204 in Stream.fold (FH.write devNull) readEx
206-- | Send the file contents to /dev/null with exception handling
207fromToBytesBracket_Stream :: Handle -> Handle -> IO ()
208fromToBytesBracket_Stream inh devNull =
209 let readEx = bracketUnsafe (return ()) (\_ -> hClose inh)
210 (\_ -> fromStreamD $ IFH.read inh)
211 in IFH.putBytes devNull (toStreamD readEx)
213#ifdef INSPECTION
214inspect $ hasNoTypeClasses 'fromToBytesBracket_Stream
215#endif
217fromToBytesBracketStream :: Handle -> Handle -> IO ()
218fromToBytesBracketStream inh devNull =
219 let readEx = Stream.bracket (return ()) (\_ -> hClose inh)
220 (\_ -> fromStreamD $ IFH.read inh)
221 in IFH.putBytes devNull (toStreamD readEx)
223readWriteBeforeAfterStream :: Handle -> Handle -> IO ()
224readWriteBeforeAfterStream inh devNull =
225 let readEx =
226 Stream.after (hClose inh)
227 $ Stream.before (hPutChar devNull 'A') (Stream.unfold FH.reader inh)
228 in Stream.fold (FH.write devNull) readEx
230#ifdef INSPECTION
231inspect $ 'readWriteBeforeAfterStream `hasNoType` ''D.Step
232#endif
234readWriteAfterStream :: Handle -> Handle -> IO ()
235readWriteAfterStream inh devNull =
236 let readEx = Stream.after (hClose inh) (Stream.unfold FH.reader inh)
237 in Stream.fold (FH.write devNull) readEx
239#ifdef INSPECTION
240inspect $ 'readWriteAfterStream `hasNoType` ''D.Step
241#endif
243readWriteAfter_Stream :: Handle -> Handle -> IO ()
244readWriteAfter_Stream inh devNull =
245 let readEx = afterUnsafe (hClose inh) (Stream.unfold FH.reader inh)
246 in Stream.fold (FH.write devNull) readEx
248#ifdef INSPECTION
249inspect $ hasNoTypeClasses 'readWriteAfter_Stream
250inspect $ 'readWriteAfter_Stream `hasNoType` ''D.Step
251#endif
253o_1_space_copy_stream_exceptions :: BenchEnv -> [Benchmark]
254o_1_space_copy_stream_exceptions env =
255 [ bgroup "exceptions"
256 [ mkBenchSmall "Stream.onException" env $ \inh _ ->
257 readWriteOnExceptionStream inh (nullH env)
258 , mkBenchSmall "Stream.handle" env $ \inh _ ->
259 readWriteHandleExceptionStream inh (nullH env)
260 , mkBenchSmall "Stream.finally_" env $ \inh _ ->
261 readWriteFinally_Stream inh (nullH env)
262 , mkBenchSmall "Stream.finally" env $ \inh _ ->
263 readWriteFinallyStream inh (nullH env)
264 , mkBenchSmall "Stream.after . Stream.before" env $ \inh _ ->
265 readWriteBeforeAfterStream inh (nullH env)
266 , mkBenchSmall "Stream.after" env $ \inh _ ->
267 readWriteAfterStream inh (nullH env)
268 , mkBenchSmall "Stream.after_" env $ \inh _ ->
269 readWriteAfter_Stream inh (nullH env)
270 ]
271 , bgroup "exceptions/fromToBytes"
272 [ mkBenchSmall "Stream.bracket_" env $ \inh _ ->
273 fromToBytesBracket_Stream inh (nullH env)
274 , mkBenchSmall "Stream.bracket" env $ \inh _ ->
275 fromToBytesBracketStream inh (nullH env)
276 ]
277 ]
279 -------------------------------------------------------------------------------
280-- Exceptions readChunks
281-------------------------------------------------------------------------------
283-- | Send the file contents to /dev/null with exception handling
284readChunksOnException :: Handle -> Handle -> IO ()
285readChunksOnException inh devNull =
286 let readEx = IUF.onException (\_ -> hClose inh) FH.chunkReader
287 in IUF.fold (IFH.writeChunks devNull) readEx inh
289#ifdef INSPECTION
290#if __GLASGOW_HASKELL__ >= 906
291inspect $ hasNoTypeClassesExcept 'readChunksOnException [''MonadCatch]
292#else
293inspect $ hasNoTypeClasses 'readChunksOnException
294#endif
295#endif
297-- | Send the file contents to /dev/null with exception handling
298readChunksBracket_ :: Handle -> Handle -> IO ()
299readChunksBracket_ inh devNull =
300 let readEx = IUF.bracket_ return (\_ -> hClose inh) FH.chunkReader
301 in IUF.fold (IFH.writeChunks devNull) readEx inh
303#ifdef INSPECTION
304#if __GLASGOW_HASKELL__ >= 906
305inspect $ hasNoTypeClassesExcept 'readChunksBracket_ [''MonadCatch]
306#else
307inspect $ hasNoTypeClasses 'readChunksBracket_
308#endif
309#endif
311readChunksBracket :: Handle -> Handle -> IO ()
312readChunksBracket inh devNull =
313 let readEx = IUF.bracket return (\_ -> hClose inh) FH.chunkReader
314 in IUF.fold (IFH.writeChunks devNull) readEx inh
316o_1_space_copy_exceptions_readChunks :: BenchEnv -> [Benchmark]
317o_1_space_copy_exceptions_readChunks env =
318 [ bgroup "exceptions/readChunks"
319 [ mkBench "UF.onException" env $ \inH _ ->
320 readChunksOnException inH (nullH env)
321 , mkBench "UF.bracket_" env $ \inH _ ->
322 readChunksBracket_ inH (nullH env)
323 , mkBench "UF.bracket" env $ \inH _ ->
324 readChunksBracket inH (nullH env)
325 ]
326 ]
328-------------------------------------------------------------------------------
329-- Exceptions toChunks
330-------------------------------------------------------------------------------
332-- | Send the file contents to /dev/null with exception handling
333toChunksBracket_ :: Handle -> Handle -> IO ()
334toChunksBracket_ inh devNull =
335 let readEx = bracketUnsafe
336 (return ())
337 (\_ -> hClose inh)
338 (\_ -> fromStreamD $ IFH.readChunks inh)
339 in Stream.fold (IFH.writeChunks devNull) readEx
341#ifdef INSPECTION
342inspect $ hasNoTypeClasses 'toChunksBracket_
343#endif
345toChunksBracket :: Handle -> Handle -> IO ()
346toChunksBracket inh devNull =
347 let readEx = Stream.bracket
348 (return ())
349 (\_ -> hClose inh)
350 (\_ -> fromStreamD $ IFH.readChunks inh)
351 in Stream.fold (IFH.writeChunks devNull) readEx
353o_1_space_copy_exceptions_toChunks :: BenchEnv -> [Benchmark]
354o_1_space_copy_exceptions_toChunks env =
355 [ bgroup "exceptions/toChunks"
356 [ mkBench "Stream.bracket_" env $ \inH _ ->
357 toChunksBracket_ inH (nullH env)
358 , mkBench "Stream.bracket" env $ \inH _ ->
359 toChunksBracket inH (nullH env)
360 ]
361 ]
363benchmarks :: String -> BenchEnv -> Int -> [Benchmark]
364benchmarks moduleName _env size =
365 [ bgroup (o_1_space_prefix moduleName) $ concat
366 [ o_1_space_serial_exceptions size
367 , o_1_space_copy_exceptions_readChunks _env
368 , o_1_space_copy_exceptions_toChunks _env
369 , o_1_space_copy_stream_exceptions _env
370 ]
371 ]