Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: e77fa849 by Zubin Duggal at 2026-09-30T17:35:30+05:30 base: Preserve exception context in modifyIOError Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - a1ccd107 by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context in mapException Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - 3f5763ba by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in Handle reads Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - e73d713e by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in hClose Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - a8fe1e4c by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in Windows openFile Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 56e6d5db by Zubin Duggal at 2026-09-30T17:36:58+05:30 base: Preserve exception context when rethrowing exceptions in executablePath Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - 18 changed files: - + changelog.d/clc-446 - + changelog.d/clc-447 - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs - + testsuite/tests/exceptions/T27851.hs - + testsuite/tests/exceptions/T27851.stderr - + testsuite/tests/exceptions/T27851b.hs - + testsuite/tests/exceptions/T27851b.stderr - + testsuite/tests/exceptions/T27851c.hs - + testsuite/tests/exceptions/T27851c.stdout - + testsuite/tests/exceptions/T27851d.hs - + testsuite/tests/exceptions/T27851d.stdout - testsuite/tests/exceptions/all.T Changes: ===================================== changelog.d/clc-446 ===================================== @@ -0,0 +1,7 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in + ``modifyIOError`` and ``mapException``. +issues: #27851 +mrs: !16747 +description: + See `CLC proposal 446 <https://github.com/haskell/core-libraries-committee/issues/446>`_. ===================================== changelog.d/clc-447 ===================================== @@ -0,0 +1,8 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``, + ``hGetContents``, ``hGetContents'``, ``hClose``, ``executablePath``, and on + Windows in ``openFile``, ``openFileBlocking`` and ``openBinaryFile``. +issues: #27875 +mrs: !16747 +description: + See `CLC proposal 447 <https://github.com/haskell/core-libraries-committee/issues/447>`_. ===================================== libraries/base/changelog.md ===================================== @@ -11,6 +11,8 @@ * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * `modifyIOError` now preserves the original `ExceptionContext` instead of annotating the rethrown exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) + * `mapException` now preserves the original `ExceptionContext` instead of annotating the mapped exception with `WhileHandling`. ([GHC #27851](https://gitlab.haskell.org/ghc/ghc/-/issues/27851)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs ===================================== @@ -175,8 +175,8 @@ handleJust p = flip (catchJust p) -- Notice that the usage of 'unsafePerformIO' is safe here. mapException :: (Exception e1, Exception e2) => (e1 -> e2) -> a -> a -mapException f v = unsafePerformIO (catch (evaluate v) - (\x -> throwIO (f x))) +mapException f v = unsafePerformIO $ catchNoPropagate (evaluate v) $ + \(ExceptionWithContext ctx x) -> rethrowIO (ExceptionWithContext ctx (f x)) ----------------------------------------------------------------------------- -- 'try' and variations. ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Internals.hs ===================================== @@ -193,7 +193,7 @@ do_operation fun h act m = do throwTo t e do_operation fun h act m _otherwise -> - throwIO e + rethrowIO (ExceptionWithContext c e) -- Note [async] -- ~~~~~~~~~~~~ @@ -451,7 +451,7 @@ handleFinalizer fp m = do (handle_', mb_exc) <- hClose_help handle_ putMVar m handle_' case mb_exc of - Just exc -> throwIO exc + Just exc -> throwIO (NoBacktrace exc) Nothing -> return () {- @@ -885,8 +885,9 @@ hClose_maybethrow (Just e) h = hClose_rethrow e h hClose_rethrow :: SomeException -> Handle -> IO () hClose_rethrow e h = case fromException e of - Just ioe -> ioError (augmentIOError ioe "hClose" h) - Nothing -> throwIO e + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hClose" h + Nothing -> throwIO (NoBacktrace e) hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) hClose' h m = withHandle' "hClose" h m $ hClose_help ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs ===================================== @@ -52,7 +52,6 @@ import qualified GHC.Internal.IO.Device as RawIO import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.Storable -import qualified GHC.Internal.Control.Exception as Exception import GHC.Internal.System.IO.Error import GHC.Internal.Data.Either (Either(..)) import GHC.Internal.Data.Maybe @@ -267,13 +266,14 @@ hGetLineBufferedLoop handle_@Handle__{..} maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catchException + = catchNoPropagate (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else ioError e) + else rethrowIO ec) -- See GHC.Internal.IO.Buffer #define CHARBUF_UTF32 @@ -421,7 +421,7 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - Exception.catch + catchNoPropagate (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h @@ -432,7 +432,8 @@ lazyReadBuffered h handle_@Handle__{..} = do writeIORef haCharBuffer (bufferAdjustL r buf') return (handle_, s) ) - (\e -> do (handle_', _) <- hClose_help handle_ + (\(ExceptionWithContext ctx e) -> do + (handle_', _) <- hClose_help handle_ debugIO ("hGetContents caught: " ++ show e) -- We might have a \r cached in CRLF mode. So we -- need to check for that and return it: @@ -441,7 +442,8 @@ lazyReadBuffered h handle_@Handle__{..} = do then "\r" else "" else - throw (augmentIOError e "hGetContents" h) + throw $ NoBacktrace $ ExceptionWithContext ctx $ + augmentIOError e "hGetContents" h return (handle_', r) ) @@ -496,7 +498,8 @@ hGetContents' handle = do Right s -> return s Left e -> case fromException e of - Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle) + Just ioe -> rethrowIO $ ExceptionWithContext (someExceptionContext e) $ + augmentIOError ioe "hGetContents'" handle Nothing -> throwIO (NoBacktrace e) strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String) @@ -512,12 +515,13 @@ strictRead h handle_@Handle__{..} = do strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer] strictReadLoop handle_ cbufs cbuf0 = do - mcbuf <- Exception.catch + mcbuf <- catchNoPropagate (do r <- readTextDevice handle_ cbuf0 return (Just r)) - (\e -> if isEOFError e + (\ec@(ExceptionWithContext _ e) -> + if isEOFError e then return Nothing - else throw e) + else rethrowIO ec) case mcbuf of Nothing -> return (cbuf0 : cbufs) Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1 ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle/Windows.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Internal.Base (String, fmap, otherwise, return, ($)) import qualified GHC.Internal.Base as Rebindable import qualified GHC.Internal.Data.Typeable.Internal as Rebindable import GHC.Internal.MVar +import GHC.Internal.Exception.Type (ExceptionWithContext(..)) import GHC.Internal.IO import GHC.Internal.IO.BufferedIO hiding (flushWriteBuffer) import GHC.Internal.IO.Encoding @@ -114,6 +115,11 @@ addFilePathToIOError :: String -> FilePath -> IOException -> IOException addFilePathToIOError fun fp ioe = ioe{ ioe_location = fun, ioe_filename = Just fp } +catchAndAnnotate :: FilePath -> String -> IO a -> IO a +catchAndAnnotate fp s a = + catchExceptionNoPropagate a $ \(ExceptionWithContext c e) -> + rethrowIO (ExceptionWithContext c (addFilePathToIOError s fp e)) + -- | Computation 'openFile' @file mode@ allocates and returns a new, open -- handle to manage the file @file@. It manages input if @mode@ -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', @@ -142,9 +148,8 @@ addFilePathToIOError fun fp ioe -- be using 'openBinaryFile'. openFile :: FilePath -> IOMode -> IO Handle openFile fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) + catchAndAnnotate fp "openFile" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True -- | Like 'openFile', but opens the file in ordinary blocking mode. -- This can be useful for opening a FIFO for writing: if we open in @@ -154,9 +159,8 @@ openFile fp im = -- @since base-4.4.0.0 openFileBlocking :: FilePath -> IOMode -> IO Handle openFileBlocking fp im = - catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) - (\e -> ioError (addFilePathToIOError "openFileBlocking" fp e)) + catchAndAnnotate fp "openFileBlocking" $ + openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False -- | Like 'openFile', but open the file in binary mode. -- On Windows, reading a file in text mode (which is the default) @@ -169,9 +173,8 @@ openFileBlocking fp im = openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = - catchException - (openFile' fp m True True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + catchAndAnnotate fp "openBinaryFile" $ + openFile' fp m True True openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle openFile' filepath iomode binary non_blocking = do ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -44,7 +44,7 @@ executablePath = Nothing import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.IO (FilePath) #if defined(darwin_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Err (errorWithoutStackTrace) import GHC.Internal.Real import GHC.Internal.Word @@ -66,7 +66,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.Real import GHC.Internal.System.Posix.Internals #elif defined(solaris2_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -75,7 +75,7 @@ import GHC.Internal.Foreign.Marshal.Array import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS) -import GHC.Internal.Control.Exception (catch, throw) +import GHC.Internal.Control.Exception (catchJust) import GHC.Internal.Data.Functor import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error @@ -203,10 +203,10 @@ realpath path = getExecutablePath = _NSGetExecutablePath >>= realpath -- realpath(3) fails with ENOENT file does not exist (e.g. was deleted) -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing -------------------------------------------------------------------------------- -- Linux / Solaris / Hurd @@ -242,12 +242,12 @@ executablePath = Just (check <$> getExecutablePath) where # elif defined(solaris2_HOST_OS) getExecutablePath = readSymbolicLink "/proc/self/path/a.out" -executablePath = Just ((Just <$> getExecutablePath) `catch` f) +executablePath = Just (catchJust f (Just <$> getExecutablePath) (\_ -> pure Nothing)) where -- readlink(2) fails with ENOENT when the executable has been deleted, -- even though the symlink itself still exists according to readdir(3). - f e | isDoesNotExistError e = pure Nothing - | otherwise = throw e + f e | isDoesNotExistError e = Just () + | otherwise = Nothing #endif @@ -297,15 +297,15 @@ getExecutablePath = do ] # endif -executablePath = Just (fmap Just getExecutablePath `catch` f) +executablePath = Just (catchJust f (fmap Just getExecutablePath) (\_ -> pure Nothing)) where -- The sysctl fails with errno ENOENT when executable has been deleted; -- see https://gitlab.haskell.org/ghc/ghc/-/issues/12377#note_321346. - f e | isDoesNotExistError e = pure Nothing + f e | isDoesNotExistError e = Just () -- As far as I know, ENOENT is the only kind of failure that should be -- expected and handled. Re-throw other errors. - | otherwise = throw e + | otherwise = Nothing -------------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO/Error.hs ===================================== @@ -319,9 +319,10 @@ ioeSetHandle ioe hdl = ioe{ ioe_handle = Just hdl } ioeSetFileName ioe filename = ioe{ ioe_filename = Just filename } -- | Catch any 'IOError' that occurs in the computation and throw a --- modified version. +-- modified version, preserving the original 'ExceptionContext'. modifyIOError :: (IOError -> IOError) -> IO a -> IO a -modifyIOError f io = catch io (\e -> throwIO (NoBacktrace $ f e)) +modifyIOError f io = catchNoPropagate io $ \(ExceptionWithContext ctx e) -> + rethrowIO (ExceptionWithContext ctx (f e)) -- ----------------------------------------------------------------------------- -- annotating an IOError ===================================== testsuite/tests/exceptions/T27851.hs ===================================== @@ -0,0 +1,7 @@ +import System.IO.Error + +main :: IO () +main = + modifyIOError (`ioeSetLocation` "outer") $ + modifyIOError (`ioeSetLocation` "inner") $ + ioError (mkIOError doesNotExistErrorType "origin" Nothing (Just "file")) ===================================== testsuite/tests/exceptions/T27851.stderr ===================================== @@ -0,0 +1,7 @@ +T27851: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.IOException: + +file: outer: does not exist + +HasCallStack backtrace: + ioError, called at T27851.hs:7:3 in main:Main + ===================================== testsuite/tests/exceptions/T27851b.hs ===================================== @@ -0,0 +1,7 @@ +import Control.Exception + +newtype Wrapped = Wrapped String deriving Show +instance Exception Wrapped + +main :: IO () +main = print (mapException (\(ErrorCall s) -> Wrapped s) (error "boom" :: Int)) ===================================== testsuite/tests/exceptions/T27851b.stderr ===================================== @@ -0,0 +1,7 @@ +T27851b: Uncaught exception main:Main.Wrapped: + +Wrapped "boom" + +HasCallStack backtrace: + error, called at T27851b.hs:7:59 in main:Main + ===================================== testsuite/tests/exceptions/T27851c.hs ===================================== @@ -0,0 +1,22 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + withBinaryFile "T27851c.txt" WriteMode $ \h -> hPutStr h "\xff\n" + run "hGetLine" hGetLine + run "hGetContents'" hGetContents' + run "hGetContents" $ \h -> do + s <- hGetContents h + length s `seq` pure s + +run :: String -> (Handle -> IO String) -> IO () +run name act = do + r <- try $ withFile "T27851c.txt" ReadMode $ \h -> do + hSetEncoding h utf8 + act h + case r of + Left e -> do + putStrLn ("-- " ++ name) + putStrLn (displayExceptionWithInfo e) + Right s -> print s ===================================== testsuite/tests/exceptions/T27851c.stdout ===================================== @@ -0,0 +1,24 @@ +-- hGetLine +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetLine: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents' +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents': invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + +-- hGetContents +ghc-internal:GHC.Internal.IO.Exception.IOException: + +T27851c.txt: hGetContents: invalid argument (cannot decode byte sequence starting from 255) + +HasCallStack backtrace: + ioException, called at libraries/ghc-internal/src/GHC/Internal/IO/Encoding/Failure.hs:214:23 in ghc-internal:GHC.Internal.IO.Encoding.Failure + ===================================== testsuite/tests/exceptions/T27851d.hs ===================================== @@ -0,0 +1,11 @@ +import Control.Exception +import System.IO + +main :: IO () +main = do + h <- openFile "/dev/full" WriteMode + hPutStr h "x" + r <- try (hClose h) + case r of + Left e -> putStrLn (displayExceptionWithInfo e) + Right () -> putStrLn "no exception" ===================================== testsuite/tests/exceptions/T27851d.stdout ===================================== @@ -0,0 +1,7 @@ +ghc-internal:GHC.Internal.IO.Exception.IOException: + +/dev/full: hClose: resource exhausted (No space left on device) + +HasCallStack backtrace: + ioError, called at libraries/ghc-internal/src/GHC/Internal/Foreign/C/Error.hs:293:5 in ghc-internal:GHC.Internal.Foreign.C.Error + ===================================== testsuite/tests/exceptions/all.T ===================================== @@ -1,3 +1,7 @@ test('T25052', normal, compile_and_run, ['']) test('T26759', exit_code(1), compile_and_run, ['']) test('T26759a', exit_code(1), compile_and_run, ['']) +test('T27851', exit_code(1), compile_and_run, ['']) +test('T27851b', exit_code(1), compile_and_run, ['']) +test('T27851c', normal, compile_and_run, ['']) +test('T27851d', unless(opsys('linux'), skip), compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2eeb... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2eeb... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help