From 16f03f1c83de3c7e70cb62a0d95abc0488dd32a1 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Thu, 9 Mar 2017 15:50:36 -0500 Subject: Try strictifying catches * Make `catchException` and `catchAny` lazy like they probably should be. * Manually strictify some things surrounding `catch` in the libraries. --- libraries/base/Control/Concurrent.hs | 4 ++-- libraries/base/GHC/Conc/Sync.hs | 8 -------- libraries/base/GHC/IO.hs | 29 +++++------------------------ libraries/base/GHC/IO/Handle/FD.hs | 6 +++--- libraries/base/GHC/IO/Handle/Internals.hs | 5 ++--- libraries/base/GHC/IO/Handle/Text.hs | 7 +++---- libraries/base/GHC/TopHandler.hs | 4 ++-- 7 files changed, 17 insertions(+), 46 deletions(-) diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index ada825d0f0..63cd96bfdd 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -109,7 +109,7 @@ import Control.Exception.Base as Exception import GHC.Conc hiding (threadWaitRead, threadWaitWrite, threadWaitReadSTM, threadWaitWriteSTM) -import GHC.IO ( unsafeUnmask, catchException ) +import GHC.IO ( unsafeUnmask, catch ) import GHC.IORef ( newIORef, readIORef, writeIORef ) import GHC.Base @@ -381,7 +381,7 @@ runInUnboundThread action = do mv <- newEmptyMVar mask $ \restore -> do tid <- forkIO $ Exception.try (restore action) >>= putMVar mv - let wait = takeMVar mv `catchException` \(e :: SomeException) -> + let wait = takeMVar mv `catch` \(e :: SomeException) -> Exception.throwTo tid e >> wait wait >>= unsafeResult else action diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index a70e103952..9b6e7928c7 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -280,8 +280,6 @@ forkIO :: IO () -> IO ThreadId forkIO action = IO $ \ s -> case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #) where - -- We must use 'catch' rather than 'catchException' because the action - -- could be bottom. #13330 action_plus = catch action childHandler -- | Like 'forkIO', but the child thread is passed a function that can @@ -330,8 +328,6 @@ forkOn :: Int -> IO () -> IO ThreadId forkOn (I# cpu) action = IO $ \ s -> case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #) where - -- We must use 'catch' rather than 'catchException' because the action - -- could be bottom. #13330 action_plus = catch action childHandler -- | Like 'forkIOWithUnmask', but the child thread is pinned to the @@ -401,10 +397,6 @@ foreign import ccall "&enabled_capabilities" enabled_capabilities :: Ptr CInt childHandler :: SomeException -> IO () childHandler err = catch (real_handler err) childHandler - -- We must use catch here rather than catchException. If the - -- raised exception throws an (imprecise) exception, then real_handler err - -- will do so as well. If we use catchException here, then we could miss - -- that exception. real_handler :: SomeException -> IO () real_handler se diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs index 8459db6b75..bcbaad6205 100644 --- a/libraries/base/GHC/IO.hs +++ b/libraries/base/GHC/IO.hs @@ -128,12 +128,8 @@ have to work around that in the definition of catch below). -} -- | Catch an exception in the 'IO' monad. --- --- Note that this function is /strict/ in the action. That is, --- @catchException undefined b == _|_@. See #exceptions_and_strictness# --- for details. catchException :: Exception e => IO a -> (e -> IO a) -> IO a -catchException !io handler = catch io handler +catchException io handler = catch io handler -- | This is the simplest of the exception-catching functions. It -- takes a single argument, runs it, and if an exception is raised @@ -180,19 +176,12 @@ catch (IO io) handler = IO $ catch# io handler' -- | Catch any 'Exception' type in the 'IO' monad. --- --- Note that this function is /strict/ in the action. That is, --- @catchAny undefined b == _|_@. See #exceptions_and_strictness# for --- details. catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a -catchAny !(IO io) handler = IO $ catch# io handler' +catchAny (IO io) handler = IO $ catch# io handler' where handler' (SomeException e) = unIO (handler e) --- Using catchException here means that if `m` throws an --- 'IOError' /as an imprecise exception/, we will not catch --- it. No one should really be doing that anyway. mplusIO :: IO a -> IO a -> IO a -mplusIO m n = m `catchException` \ (_ :: IOError) -> n +mplusIO m n = m `catch` \ (_ :: IOError) -> n -- | A variant of 'throw' that can only be used within the 'IO' monad. -- @@ -282,8 +271,8 @@ getMaskingState = IO $ \s -> _ -> MaskedInterruptible #) onException :: IO a -> IO b -> IO a -onException io what = io `catchException` \e -> do _ <- what - throwIO (e :: SomeException) +onException io what = io `catch` \e -> do _ <- what + throwIO (e :: SomeException) -- | Executes an IO computation with asynchronous -- exceptions /masked/. That is, any thread which attempts to raise @@ -437,12 +426,4 @@ examples: > test2 = GHC.IO.catchException (error "uh oh") (\(_ :: SomeException) -> putStrLn "it failed") While @test1@ will print "it failed", @test2@ will print "uh oh". - -When using 'catchException', exceptions thrown while evaluating the -action-to-be-executed will not be caught; only exceptions thrown during -execution of the action will be handled by the exception handler. - -Since this strictness is a small optimization and may lead to surprising -results, all of the @catch@ and @handle@ variants offered by "Control.Exception" -use 'catch' rather than 'catchException'. -} diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs index e988b25c9f..ee88b3d5f1 100644 --- a/libraries/base/GHC/IO/Handle/FD.hs +++ b/libraries/base/GHC/IO/Handle/FD.hs @@ -138,7 +138,7 @@ addFilePathToIOError fun fp ioe -- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = - catchException + catch (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) (\e -> ioError (addFilePathToIOError "openFile" fp e)) @@ -150,7 +150,7 @@ openFile fp im = -- @since 4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle openFileBlocking fp im = - catchException + catch (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) (\e -> ioError (addFilePathToIOError "openFile" fp e)) @@ -165,7 +165,7 @@ openFileBlocking fp im = openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = - catchException + catch (openFile' fp m True True) (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs index 48ece1dc5e..3c1e1f881d 100644 --- a/libraries/base/GHC/IO/Handle/Internals.hs +++ b/libraries/base/GHC/IO/Handle/Internals.hs @@ -157,13 +157,12 @@ withHandle__' fun h m act = h' <- do_operation fun h act m checkHandleInvariants h' putMVar m h' - return () do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a do_operation fun h act m = do h_ <- takeMVar m checkHandleInvariants h_ - act h_ `catchException` handler h_ + act h_ `catch` handler h_ where handler h_ e = do putMVar m h_ @@ -748,7 +747,7 @@ hClose_help handle_ = trymaybe :: IO () -> IO (Maybe SomeException) -trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e) +trymaybe io = (do io; return Nothing) `catch` \e -> return (Just e) hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException) hClose_handle_ h_@Handle__{..} = do diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs index 8d927384c8..0b74ab5413 100644 --- a/libraries/base/GHC/IO/Handle/Text.hs +++ b/libraries/base/GHC/IO/Handle/Text.hs @@ -45,7 +45,6 @@ import qualified GHC.IO.Device as RawIO import Foreign import Foreign.C -import qualified Control.Exception as Exception import Data.Typeable import System.IO.Error import Data.Maybe @@ -245,8 +244,8 @@ hGetLineBufferedLoop handle_@Handle__{..} hGetLineBufferedLoop handle_ new_buf (xs:xss) maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) -maybeFillReadBuffer handle_ buf - = catchException +maybeFillReadBuffer handle_ !buf + = catch (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) @@ -401,7 +400,7 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - Exception.catch + catch (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs index f1c87e5110..eed94492d6 100644 --- a/libraries/base/GHC/TopHandler.hs +++ b/libraries/base/GHC/TopHandler.hs @@ -154,14 +154,14 @@ runIOFastExit main = catch main topHandlerFastExit -- are used to export Haskell functions with non-IO types. -- runNonIO :: a -> IO a -runNonIO a = catch (a `seq` return a) topHandler +runNonIO a = catch (evaluate a) topHandler topHandler :: SomeException -> IO a topHandler err = catch (real_handler safeExit err) topHandler topHandlerFastExit :: SomeException -> IO a topHandlerFastExit err = - catchException (real_handler fastExit err) topHandlerFastExit + catch (real_handler fastExit err) topHandlerFastExit -- Make sure we handle errors while reporting the error! -- (e.g. evaluating the string passed to 'error' might generate -- cgit v1.2.1