September 2026 - ghc-commits

[Git][ghc/ghc][wip/annotation-fixes] 6 commits: base: Preserve exception context in modifyIOError
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: 5dc3fb3d by Zubin Duggal at 2026-09-30T17:38:52+05:30 base: Preserve exception context in modifyIOError Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - 6e10ba2f by Zubin Duggal at 2026-09-30T17:38:52+05:30 base: Preserve exception context in mapException Fixes #27851. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/446 - - - - - 39bedca7 by Zubin Duggal at 2026-09-30T17:38:53+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 - - - - - 96cb0b55 by Zubin Duggal at 2026-09-30T17:38:53+05:30 base: Preserve exception context when rethrowing exceptions in hClose Fixes #27875. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/447 - - - - - cb9debbd by Zubin Duggal at 2026-09-30T17:38:53+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 - - - - - e9688c44 by Zubin Duggal at 2026-09-30T17:38:53+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)) + * Preserve exception context when rethrowing exceptions in `modifyIOError` and `mapException`. ([CLC proposal #446](https://github.com/haskell/core-libraries-committee/issues/446)) + * Preserve exception context when rethrowing exceptions in `hGetLine`, `hGetContents`, `hGetContents'`, `hClose`, `executablePath`, and on Windows in `openFile`, `openFileBlocking` and `openBinaryFile`. ([CLC proposal #447](https://github.com/haskell/core-libraries-committee/issues/447)) ## 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/56e6d5db93d172964cb5faaaf1d707… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/56e6d5db93d172964cb5faaaf1d707… 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

1 0

[Git][ghc/ghc][wip/annotation-fixes] 6 commits: base: Preserve exception context in modifyIOError
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

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/2b6d5865a17628f8248282a378b2ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2ee… 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

1 0

[Git][ghc/ghc][wip/annotation-fixes] 6 commits: base: Preserve exception context in modifyIOError
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

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/2b6d5865a17628f8248282a378b2ee… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b6d5865a17628f8248282a378b2ee… 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

1 0

[Git][ghc/ghc][wip/annotation-fixes] 7 commits: ghci: Drop GHCi's exception context when rethrowing in ghc -e
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed to branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC Commits: 27b0f716 by Zubin Duggal at 2026-09-30T17:28:08+05:30 ghci: Drop GHCi's exception context when rethrowing in ghc -e Fixes #27847. - - - - - f0705262 by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context in modifyIOError Fixes #27851. - - - - - 3b92dfeb by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context in mapException See #27851. - - - - - 1725738f by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in Handle reads See #27851. - - - - - 1a22ec0b by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in hClose See #27851. - - - - - 8c1d30db by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in Windows openFile See #27851. - - - - - 2b6d5865 by Zubin Duggal at 2026-09-30T17:28:08+05:30 base: Preserve exception context when rethrowing exceptions in executablePath See #27851. - - - - - 26 changed files: - + changelog.d/T27847 - + changelog.d/T27851 - + changelog.d/T27851b - + changelog.d/T27851c - + changelog.d/T27851d - + changelog.d/T27851e - + changelog.d/T27851f - ghc/GHCi/UI/Monad.hs - 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 - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghc-e/should_run/ghc-e005.stderr Changes: ===================================== changelog.d/T27847 ===================================== @@ -0,0 +1,5 @@ +section: ghci +synopsis: Drop GHCi's own exception context when rethrowing exceptions in + ``ghc -e`` and ``runghc``. +issues: #27847 +mrs: !16747 ===================================== changelog.d/T27851 ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``modifyIOError``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851b ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``mapException``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851c ===================================== @@ -0,0 +1,5 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hGetLine``, + ``hGetContents`` and ``hGetContents'``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851d ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``hClose``. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851e ===================================== @@ -0,0 +1,5 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``openFile``, + ``openFileBlocking`` and ``openBinaryFile`` on Windows. +issues: #27851 +mrs: !16747 ===================================== changelog.d/T27851f ===================================== @@ -0,0 +1,4 @@ +section: base +synopsis: Preserve exception context when rethrowing exceptions in ``executablePath``. +issues: #27851 +mrs: !16747 ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -211,7 +211,7 @@ data CommandResult deriving Show cmdSuccess :: MonadThrow m => CommandResult -> m (Maybe Bool) -cmdSuccess CommandComplete{ cmdResult = Left e } = +cmdSuccess CommandComplete{ cmdResult = Left (SomeException e) } = {- Don't add a backtrace from ghci/ghc to the exception from the user program! -} #if MIN_VERSION_base(4,21,0) throwM (NoBacktrace e) ===================================== 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, ['']) ===================================== testsuite/tests/ghc-e/should_fail/T18441fail7.stderr ===================================== @@ -5,10 +5,6 @@ IO error: "Abcde" does not exist While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException: | | IO error: "Abcde" does not exist - | - | HasCallStack backtrace: - | throw, called at compiler/GHC/Utils/Panic.hs:180:21 in ghc-10.1-inplace:GHC.Utils.Panic - | throwGhcException, called at ghc/GHCi/UI.hs:2851:21 in ghc-bin-10.1.20260801-inplace:GHCi.UI HasCallStack backtrace: throwIO, called at compiler/GHC/Utils/Error.hs:513:19 in ghc-10.1-inplace:GHC.Utils.Error ===================================== testsuite/tests/ghc-e/should_run/ghc-e005.stderr ===================================== @@ -4,8 +4,3 @@ foo HasCallStack backtrace: error, called at ghc-e005.hs:12:10 in main:Main - - -HasCallStack backtrace: - throwIO, called at ghc\GHCi\UI.hs:1655:31 in ghc-bin-10.1.20260629-inplace:GHCi.UI - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6b8a645b484e1833839d8fa882370… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e6b8a645b484e1833839d8fa882370… 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

1 0

[Git][ghc/ghc][wip/T27731] 16 commits: Remove the call to hoistFlag from processCmdLineP
by Simon Peyton Jones (＠simonpj) 30 Sep '26

30 Sep '26

Simon Peyton Jones pushed to branch wip/T27731 at Glasgow Haskell Compiler / GHC Commits: 098bba70 by Facundo Domínguez at 2026-09-17T14:57:41-04:00 Remove the call to hoistFlag from processCmdLineP This call was undesirable because it was causing a reconstruction of the list of flag processors. Even relying on list fusion would not be sufficient because we want to replace the list with a data structure with faster lookups to address #25763. The removal is done in two moves: * We move CmdLineP to CmdLine.hs * Then we move the effect of hoisting to processArgs via a new function hoistEwM - - - - - e01799c7 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Do not create duplicate flag processors for the -W flag This makes simpler implementing the command line parser with a trie map holding flag processors. If we were to allow duplicate flag processors for any flag, the trie map would need to be a multimap. - - - - - 3875b257 by Facundo Domínguez at 2026-09-17T14:57:42-04:00 Replace the list of flag processors with a trie map in `processArgs` Previously `GHC.Driver.CmdLine.findArg` was called for each command-line argument, doing a linear search on the list of flag processors each time. This was somewhat costly as the list of flag processor has near 2000 elements. A lookup with a trie map is faster in general, but the speed up is only noticeable when calling `GHC.Driver.CmdLine.processArgs` sufficient times, so the amount of lookups piles up. This could happen in large projects with many units each having many dependencies. If only a module needs to be recompiled, the user still needs to wait for all of the flag parsing to complete. The benchmark at testsuite/tests/perf/compiler/cmdline-parser shows a 10x speed up when using the trie. The trie map is implemented in `GHC.Data.StringTrie`. The design is explained in Note [Processing command line argument fast] in GHC.Driver.Session. The commit also: * adds two property-based tests for trie map operations, * adds a benchmark of the command line parser, and * renames the predicate `arg_ok` to `valid_flag_suffix` to decide what flag processor should be used when there are multiple matching prefixes on a flag. Fixes #25763. - - - - - 5236634a by Andreas Klebinger at 2026-09-17T14:58:24-04:00 Compile Word64{Map,Set} with -O2 always. This is the hottest code and even if we build GHC with -O0 otherwise -O2 pays off for these modules. Fixes #27814. - - - - - 545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - bf17f289 by fendor at 2026-09-22T15:04:05-04:00 Don't lose instances from shadowed imported modules with the same name When we look for instances below the current module, we need to check the unit id as well when we check for whether the module is the current module, otherwise we ignore modules we import that have the same name as the import module. Adds regression test. - - - - - 53eead15 by Wolfgang Jeltsch at 2026-09-24T20:12:03-04:00 Correct the documentation of `explicitUnits` Resolves #27787. - - - - - 35bf6f4b by Simon Jakobi at 2026-09-24T20:12:49-04:00 Remove stale specHeader bullet from Note [Don't make fillers for constraint types] The Note said that Specialise.specHeader also calls mkAbsentFiller. abfc224a27c removed that call: the specialiser no longer drops dead arguments at all, see Note [Do not drop dead args from specialisations] in GHC.Core.Opt.Specialise. Assisted-by: Claude Fable 5.1 - - - - - 1abef1ef by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the `mhu-closure` makefile - - - - - a79a68ea by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Make `ghci-multi` hide all unneeded packages - - - - - d6e72450 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Improve the definition of the home unit closure property - - - - - c9a2766d by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Re-implement the home unit closure check Compared to the previous implementation, the new one has the following advantages: * It is correct. - It distinguishes between units that have the same unit ID but different ABI hashes. - When `-hide-all-packages` is not used, it considers as home unit dependencies also units that are made implicitly available because they are in the package database. * It seems to be faster in usual settings. - In particular, it does not have a preparation phase in which it merges the dependency information from all home units, so that its running time does not grow linearly with the size of the package database in normal Cabal scenarios. * It is (hopefully) clearer. * It is better documented. - - - - - fa96acf8 by Wolfgang Jeltsch at 2026-09-25T17:02:07-04:00 Remove erroneous GHC flag in `hadrian-multi` The flag was `-Werror=-Wno-error=incomplete-record-selectors`. Its purpose was to permit incomplete record selectors, but because of the illegal combination of `-Werror=` and `-Wno-error` it was ignored, without any negative consequences. - - - - - 9f48a5b9 by Alan Zimmerman at 2026-09-25T17:02:50-04:00 EPA: Add specific layout field to AnnList Up to now AnnList has effectively served to represent lists of things having layout, regardless of whether they do or not. In Haskell, layout is optional in many places, as there is also an alternative syntax using braces and semi-colons, which is free-form. This commit introduces AnnListLayout, a data structure capturing this distinction. It is deliberately set up similarly to EpLayout, so that these two can be merged in time. The transition is done mechanically, where AnnListBraces is not used yet, the original Nothing case maps to AnnListNoLayout, and the Just case to AnnListLayout. Later commits will fine tune these against the actual parser layout. - - - - - 234bab08 by Vladislav Zavialov at 2026-09-29T17:22:54-04:00 Add regression test for #7803 Commit 2effe18ab5, first shipped with GHC 8.2.1, fixed #7803 "Superclass methods are left unspecialized". This change turns the example from the ticket description into a regression test, checking that foo1 is fully specialised at Double, with no calls to the overloaded exp5Tail. Closes #7803 Assisted-by: Claude Opus 5 - - - - - b2577fd9 by Simon Peyton Jones at 2026-09-30T12:52:08+01:00 Simplify the error-suppression mechanism in GHC.Tc.Errors In `GHC.Tc.Errors.reportWanteds` we suppress some errors in favour of others. But the mechanism had grown crufty, and #27331 exposed a bug. This MR makes it simpler and more uniform, by doing everything via the `ei_suppress` field of the ErrorItem. Claude then found another closely-related bug (see the review linked on !16564). That bug is immortalised in new test T18851d. I'm still not happy with `ignoreConstraint` but we can worry about that another day; I have not touched it. Main changes * Instead of /predicting/ when an error will be reported, we set `cec_error_reported` when an error is /actually/ reported. (I renamed it from `cec_suppress` to reflect this change.) Now errors are suppressed only when a preceding error has actually been reported. Simpler and more robust. See `Note [cec_error_reported: suppressing less-serious errors]` The big changes are in `reportWanteds` which looks very different. * New `Note [ei_suppress: suppressing confusing errors]` describes the (quite separate) `ei_suppress` mechanism for suppressing confusing errors, mainly arising from non-empty rewriter sets * In `tryTypeClassDefaulting`, instead of switching off type-class defaulting if there is an insoluble /anywhere/, we just switch it off locally when we find an insoluble sub-tree. See Note [When to do type-class defaulting] and (W5) in Note [ApproximateWC] * Greatly simplify `insolubleWantedCt`. Small refactorings * Rename `askNoErrs` to `askErrsFound` and flip its polarity * The code for "check if ei_suppress is true of all items" code is moved to `mkErrorItems` rather than in the large `reportWanteds`. * Code for `has_gadt_match` moves to `mkGivenErrorReporter`, rather than polluting the large `reportWanteds`. * Many tests with `-fdefer-type-errors` get more warnings, especially about ambiguous (Num a) constraints. This is by-design: see Note [Always warn with -fdefer-type-errors]. Previously GHC was not honouring this Note but now it is, hence the extra errors. - - - - - 100 changed files: - .gitlab-ci.yml - + changelog.d/25763-cmdline-opt - + changelog.d/26610 - + changelog.d/T27731 - compiler/GHC/Builtin/WiredIn/Ids.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - + compiler/GHC/Data/StringTrie.hs - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Data/Word64Set/Internal.hs - compiler/GHC/Driver/CmdLine.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - ghc/GHC/Driver/Session/Mode.hs - hadrian/ghci-multi-cabal.in - rts/include/stg/Prim.h - rts/prim/bitrev.c - rts/prim/bswap.c - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/driver/all.T - testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout - + testsuite/tests/driver/stringtrie.hs - + testsuite/tests/driver/stringtrie.stdout - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - + testsuite/tests/ghci/prog-mhu008/Makefile - + testsuite/tests/ghci/prog-mhu008/a/M.hs - + testsuite/tests/ghci/prog-mhu008/all.T - + testsuite/tests/ghci/prog-mhu008/b/M.hs - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout - + testsuite/tests/ghci/prog-mhu008/unitA - + testsuite/tests/ghci/prog-mhu008/unitB - testsuite/tests/module/mod130.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/overloadedstrings/should_fail/T25926.stderr - testsuite/tests/overloadedstrings/should_fail/T27124.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr - + testsuite/tests/perf/compiler/T25763.stderr - testsuite/tests/perf/compiler/all.T - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - + testsuite/tests/simplCore/should_compile/T7803.hs - + testsuite/tests/simplCore/should_compile/T7803.stderr - + testsuite/tests/simplCore/should_compile/T7803a.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/typecheck/should_compile/T11254.stderr - testsuite/tests/typecheck/should_compile/T15370.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/ClassOperator.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/DoExpansion3.stderr - testsuite/tests/typecheck/should_fail/FunDepOrigin1b.hs - testsuite/tests/typecheck/should_fail/T18851.stderr - + testsuite/tests/typecheck/should_fail/T18851e.hs - + testsuite/tests/typecheck/should_fail/T18851e.stderr - testsuite/tests/typecheck/should_fail/T22940.stderr - testsuite/tests/typecheck/should_fail/T26823.stderr - + testsuite/tests/typecheck/should_fail/T27731.hs - + testsuite/tests/typecheck/should_fail/T27731.stderr - testsuite/tests/typecheck/should_fail/T5691.stderr - testsuite/tests/typecheck/should_fail/T7437.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail019.stderr - + testsuite/tests/warnings/should_fail/WExpectedNoArgError.stderr - testsuite/tests/warnings/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c3c41a45a1e11853c9055bfa1e110… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c3c41a45a1e11853c9055bfa1e110… 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

1 0

[Git][ghc/ghc][wip/fendor/27835] Prepend in-memory unit database for backpack
by Hannes Siebenhandl (＠fendor) 30 Sep '26

30 Sep '26

Hannes Siebenhandl pushed to branch wip/fendor/27835 at Glasgow Haskell Compiler / GHC Commits: 455b17e2 by Hannes Siebenhandl at 2026-09-30T13:41:43+02:00 Prepend in-memory unit database for backpack The packageDbFlags are stored in reverse order. Thus, prepending will ensure that the in-memory unit database is the last item on the unit database stack. Further, the in-memory unit database needs to be able to shadow units from earlier unit databases in the unit database stack. Moreover, a `-clear-package-db` would remove the in-memory database if it weren't the last item on the stack. Closes #27835 - - - - - 5 changed files: - changelog.d/unit-index - compiler/GHC/Driver/Backpack.hs - + testsuite/tests/backpack/should_compile/T27835.bkp - + testsuite/tests/backpack/should_compile/T27835.stderr - testsuite/tests/backpack/should_compile/all.T Changes: ===================================== changelog.d/unit-index ===================================== @@ -1,7 +1,7 @@ section: compiler synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units -issues: #27500 #26423 #27748 -mrs: !16115 !16598 +issues: #27500 #26423 #27748 #27835 +mrs: !16115 !16598 !16748 description: { The ``UnitState`` used to be duplicated for all ``HomeUnitEnv``, not sharing any of the ``UnitInfo``s. ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -441,9 +441,11 @@ addInMemoryDatabase dflags u = do } let uic = hscUIC hsc_env liftIO $ cacheExternalUnitDatabase uic newdb - -- added at the end because ordering matters + -- Ordering matters here! We prepend the unit database, because 'packageDBFlags' + -- are stored in reverse order. Making this unit db, the last one in the unit db stack. + -- It needs to be the last one to overwrite any other potential in-memory unit that occurs earlier. pure dflags - { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] + { packageDBFlags = PackageDB (PkgDbPath (unitDatabasePath newdb)) : packageDBFlags dflags } -- | Register a new virtual unit database containing a single unit ===================================== testsuite/tests/backpack/should_compile/T27835.bkp ===================================== @@ -0,0 +1,11 @@ +unit p where + module P where + p :: Int + p = 42 + +unit q where + dependency p + module Q where + import P + q :: Int + q = p + 1 ===================================== testsuite/tests/backpack/should_compile/T27835.stderr ===================================== @@ -0,0 +1,7 @@ +[1 of 2] Processing p + Instantiating p + [1 of 1] Compiling P ( p/P.hs, T27835.out/p/P.o ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p + [1 of 1] Compiling Q ( q/Q.hs, T27835.out/q/Q.o ) ===================================== testsuite/tests/backpack/should_compile/all.T ===================================== @@ -61,3 +61,4 @@ test('T13250', normal, backpack_compile, ['']) test('T13323', normal, backpack_compile, ['']) test('T20396', normal, backpack_compile, ['']) test('T23424', [ignore_stdout, ignore_stderr], backpack_compile, ['-ddump-rn-trace -ddump-if-trace -ddump-tc-trace']) +test('T27835', normal, backpack_compile, ['-clear-package-db -global-package-db']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/455b17e2bdc70b2f89b50a735483d97… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/455b17e2bdc70b2f89b50a735483d97… 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

1 0

[Git][ghc/ghc][wip/fendor/27835] Prepend in-memory unit database for backpack
by Hannes Siebenhandl (＠fendor) 30 Sep '26

30 Sep '26

Hannes Siebenhandl pushed to branch wip/fendor/27835 at Glasgow Haskell Compiler / GHC Commits: 36b91be0 by Hannes Siebenhandl at 2026-09-30T13:40:25+02:00 Prepend in-memory unit database for backpack The packageDbFlags are stored in reverse order. Thus, prepending will ensure that the in-memory unit database is the last item on the unit database stack. Further, the in-memory unit database needs to be able to shadow units from earlier unit databases in the unit database stack. Moreover, a `-clear-package-db` would remove the in-memory database if it weren't the last item on the stack. Closes #27835 - - - - - 5 changed files: - changelog.d/unit-index - compiler/GHC/Driver/Backpack.hs - + testsuite/tests/backpack/should_compile/T27835.bkp - + testsuite/tests/backpack/should_compile/T27835.stderr - testsuite/tests/backpack/should_compile/all.T Changes: ===================================== changelog.d/unit-index ===================================== @@ -1,6 +1,6 @@ section: compiler synopsis: Use global ``UnitIndex`` to deduplicate ``UnitInfo``s over multiple home units -issues: #27500 #26423 #27748 +issues: #27500 #26423 #27748 #27835 mrs: !16115 !16598 description: { ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -441,9 +441,11 @@ addInMemoryDatabase dflags u = do } let uic = hscUIC hsc_env liftIO $ cacheExternalUnitDatabase uic newdb - -- added at the end because ordering matters + -- Ordering matters here! We prepend the unit database, because 'packageDBFlags' + -- are stored in reverse order. Making this unit db, the last one in the unit db stack. + -- It needs to be the last one to overwrite any other potential in-memory unit that occurs earlier. pure dflags - { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] + { packageDBFlags = PackageDB (PkgDbPath (unitDatabasePath newdb)) : packageDBFlags dflags } -- | Register a new virtual unit database containing a single unit ===================================== testsuite/tests/backpack/should_compile/T27835.bkp ===================================== @@ -0,0 +1,11 @@ +unit p where + module P where + p :: Int + p = 42 + +unit q where + dependency p + module Q where + import P + q :: Int + q = p + 1 ===================================== testsuite/tests/backpack/should_compile/T27835.stderr ===================================== @@ -0,0 +1,7 @@ +[1 of 2] Processing p + Instantiating p + [1 of 1] Compiling P ( p/P.hs, T27835.out/p/P.o ) +[2 of 2] Processing q + Instantiating q + [1 of 1] Including p + [1 of 1] Compiling Q ( q/Q.hs, T27835.out/q/Q.o ) ===================================== testsuite/tests/backpack/should_compile/all.T ===================================== @@ -61,3 +61,4 @@ test('T13250', normal, backpack_compile, ['']) test('T13323', normal, backpack_compile, ['']) test('T20396', normal, backpack_compile, ['']) test('T23424', [ignore_stdout, ignore_stderr], backpack_compile, ['-ddump-rn-trace -ddump-if-trace -ddump-tc-trace']) +test('T27835', normal, backpack_compile, ['-clear-package-db -global-package-db']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36b91be0caff0ed85fdf7afb27ff9f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36b91be0caff0ed85fdf7afb27ff9f5… 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

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/27835
by Hannes Siebenhandl (＠fendor) 30 Sep '26

30 Sep '26

Hannes Siebenhandl pushed new branch wip/fendor/27835 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/27835 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

1 0

[Git][ghc/ghc] Pushed new branch wip/annotation-fixes
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed new branch wip/annotation-fixes at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/annotation-fixes 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

1 0

[Git][ghc/ghc][wip/27845] DmdAnal: Make AbsDmd neutral in maxDmd
by Zubin (＠wz1000) 30 Sep '26

30 Sep '26

Zubin pushed to branch wip/27845 at Glasgow Haskell Compiler / GHC Commits: 0689685b by Zubin Duggal at 2026-09-30T17:00:36+05:30 DmdAnal: Make AbsDmd neutral in maxDmd fixes #27845 - - - - - 9 changed files: - + changelog.d/27845 - compiler/GHC/Types/Demand.hs - + testsuite/tests/dmdanal/should_run/T27845.hs - + testsuite/tests/dmdanal/should_run/T27845.stdout - + testsuite/tests/dmdanal/should_run/T27845_Lib.hs - + testsuite/tests/dmdanal/should_run/T27845b.hs - + testsuite/tests/dmdanal/should_run/T27845b.stdout - + testsuite/tests/dmdanal/should_run/T27845b_Lib.hs - testsuite/tests/dmdanal/should_run/all.T Changes: ===================================== changelog.d/27845 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Fix a bug where an argument used lazily only by a function's stable + unfolding could be treated as strict in its fields. +mrs: !16746 +issues: #27845 ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -924,6 +924,8 @@ maxCard (Card a) (Card b) = Card ((a .&. b .&. 0b001) .|. ((a .|. b) .&. 0b110)) maxDmd :: Demand -> Demand -> Demand maxDmd BotDmd dmd2 = dmd2 maxDmd dmd1 BotDmd = dmd1 +maxDmd AbsDmd dmd2 = dmd2 +maxDmd dmd1 AbsDmd = dmd1 maxDmd (n1 :* sd1) (n2 :* sd2) = maxCard n1 n2 :* maxSubDmd sd1 sd2 ===================================== testsuite/tests/dmdanal/should_run/T27845.hs ===================================== @@ -0,0 +1,14 @@ +module Main where +import T27845_Lib (f) +import System.Environment (getArgs) + +{-# NOINLINE mkArg #-} +mkArg :: Int -> Int +mkArg n | n < 0 = n + | otherwise = error ("boom " ++ show n) + +main :: IO () +main = do + n <- length <$> getArgs + let x = mkArg n + print (length (f (x, x) n)) ===================================== testsuite/tests/dmdanal/should_run/T27845.stdout ===================================== @@ -0,0 +1 @@ +0 ===================================== testsuite/tests/dmdanal/should_run/T27845_Lib.hs ===================================== @@ -0,0 +1,11 @@ +module T27845_Lib where + +{-# INLINABLE [2] f #-} +f :: a -> Int -> [a] +f p x = lazyUse p x ++ lazyUse p (x + 1) ++ lazyUse p (x + 2) + +{-# NOINLINE lazyUse #-} +lazyUse :: a -> Int -> [a] +lazyUse p x = p `seq` replicate x p + +{-# RULES "lazyUse" [1] forall p x. lazyUse p x = [] #-} ===================================== testsuite/tests/dmdanal/should_run/T27845b.hs ===================================== @@ -0,0 +1,14 @@ +module Main where +import T27845b_Lib (outer) +import System.Environment (getArgs) + +{-# NOINLINE mkArg #-} +mkArg :: Int -> Int +mkArg n | n < 0 = n + | otherwise = error ("boom " ++ show n) + +main :: IO () +main = do + n <- length <$> getArgs + let x = mkArg n + print (length (outer (x, x) n)) ===================================== testsuite/tests/dmdanal/should_run/T27845b.stdout ===================================== @@ -0,0 +1 @@ +0 ===================================== testsuite/tests/dmdanal/should_run/T27845b_Lib.hs ===================================== @@ -0,0 +1,14 @@ +module T27845b_Lib where + +outer :: a -> Int -> [a] +outer a n = + let {-# INLINABLE [2] g #-} + g x = lazyUse a (x + 0) ++ lazyUse a (x + 1) ++ lazyUse a (x + 2) + in g n ++ g (n + 1) ++ g (n + 2) +{-# NOINLINE outer #-} + +{-# NOINLINE lazyUse #-} +lazyUse :: a -> Int -> [a] +lazyUse p x = p `seq` replicate x p + +{-# RULES "lazyUse" [1] forall p x. lazyUse p x = [] #-} ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -37,3 +37,5 @@ test('T25439', normal, compile_and_run, ['']) test('T26748', normal, compile_and_run, ['']) test('T26416', [extra_files(['M1.hs'])], multimod_compile_and_run, ['T26416','M1.hs']) test('T27626', [extra_files(['M2.hs'])], multimod_compile_and_run, ['T27626','M2.hs']) +test('T27845', [extra_files(['T27845_Lib.hs'])], multimod_compile_and_run, ['T27845','T27845_Lib.hs']) +test('T27845b', [extra_files(['T27845b_Lib.hs'])], multimod_compile_and_run, ['T27845b','T27845b_Lib.hs']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0689685b1903dc6bd4fbf10efae94ab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0689685b1903dc6bd4fbf10efae94ab… 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

1 0