[Git][ghc/ghc][wip/romes/exceptions-propagate] Fix exception backtraces from GHCi

[Rodrigo Mesquita (@alt-romes)]

Rodrigo Mesquita pushed to branch wip/romes/exceptions-propagate at Glasgow Haskell Compiler / GHC


Commits:
fe6c5f62 by Rodrigo Mesquita at 2024-10-02T15:29:38+01:00
Fix exception backtraces from GHCi

When running the program with `runhaskell`/`runghc` the backtrace should
match the backtrace one would get by compiling and running the program.
But currently, an exception thrown in a program interpreted with
`runhaskell` will:

    * Not include the original exception backtrace at all
    * Include the backtrace from the internal GHCi/ghc rethrowing of the
      original exception

This commit fixes this divergence by not annotating the ghc(i) backtrace
(with NoBacktrace) and making sure that the backtrace of the original
exception is serialized across the boundary and rethrown with the
appropriate context.

Fixes #25116

- - - - -


3 changed files:

- ghc/GHCi/UI/Monad.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs


Changes:

=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -212,7 +212,9 @@ data CommandResult
    deriving Show
 
 cmdSuccess :: MonadThrow m => CommandResult -> m (Maybe Bool)
-cmdSuccess CommandComplete{ cmdResult = Left e } = throwM e
+cmdSuccess CommandComplete{ cmdResult = Left e } =
+  {- Don't add a backtrace from ghci/ghc to the exception from the user program! -}
+  throwM (NoBacktrace e)
 cmdSuccess CommandComplete{ cmdResult = Right r } = return r
 cmdSuccess CommandIncomplete = return $ Just True
 


=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -40,6 +40,9 @@ import GHC.Fingerprint
 import GHC.Conc (pseq, par)
 import Control.Concurrent
 import Control.Exception
+#if MIN_VERSION_base(4,20,0)
+import Control.Exception.Context
+#endif
 import Data.Binary
 import Data.Binary.Get
 import Data.Binary.Put
@@ -442,7 +445,15 @@ toSerializableException :: SomeException -> SerializableException
 toSerializableException ex
   | Just UserInterrupt <- fromException ex  = EUserInterrupt
   | Just (ec::ExitCode) <- fromException ex = (EExitCode ec)
-  | otherwise = EOtherException (show (ex :: SomeException))
+  | otherwise = EOtherException $
+#if MIN_VERSION_base(4,20,0)
+      -- Exception plus backtrace as seen in `displayExceptionWithInfo`
+      case displayExceptionContext (someExceptionContext ex) of
+        "" -> displayException (ex :: SomeException)
+        cx -> displayException (ex :: SomeException) ++ "\n\n" ++ cx
+#else
+      show (ex :: SomeException)
+#endif
 
 fromSerializableException :: SerializableException -> SomeException
 fromSerializableException EUserInterrupt = toException UserInterrupt


=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -252,7 +252,7 @@ sandboxIO opts io = do
 --
 rethrow :: EvalOpts -> IO a -> IO a
 rethrow EvalOpts{..} io =
-  catch io $ \se -> do
+  catchNoPropagate io $ \(ExceptionWithContext cx se) -> do
     -- If -fbreak-on-error, we break unconditionally,
     --  but with care of not breaking twice
     if breakOnError && not breakOnException
@@ -263,7 +263,7 @@ rethrow EvalOpts{..} io =
                Just UserInterrupt -> return ()
                -- In any other case, we don't want to break
                _ -> poke exceptionFlag 0
-    throwIO se
+    rethrowIO (ExceptionWithContext cx se)
 
 --
 -- While we're waiting for the sandbox thread to return a result, if



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe6c5f626f06b6f72a61f8b0086fecb6cbdf02c0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe6c5f626f06b6f72a61f8b0086fecb6cbdf02c0
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241002/b831a50c/attachment-0001.html>