From 294c93a580e85e242d90349ae92fa6a7818002bb Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 24 Oct 2022 10:05:09 -0400
Subject: [PATCH] base: Use displayException in top-level exception handler
Happily this also allows us to eliminate a special case for Deadlock
exceptions.
Implements [CLC #198](https://github.com/haskell/core-libraries-committee/issues/198).
---
libraries/base/changelog.md | 1 +
libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs | 9 ++-------
libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs | 3 ++-
3 files changed, 5 insertions(+), 8 deletions(-)
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 7e0607ca7131..1040de7b1c1c 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -2,6 +2,7 @@
## 4.20.0.0 *TBA*
* Export `foldl'` from `Prelude` ([CLC proposal #167](https://github.com/haskell/core-libraries-committee/issues/167))
+ * The top-level handler for uncaught exceptions now displays the output of `displayException` rather than `show` ([CLC proposal #198](https://github.com/haskell/core-libraries-committee/issues/198))
* Add `permutations` and `permutations1` to `Data.List.NonEmpty` ([CLC proposal #68](https://github.com/haskell/core-libraries-committee/issues/68))
* Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #175](https://github.com/haskell/core-libraries-committee/issues/175))
* Implement `stimes` for `instance Semigroup (Endo a)` explicitly ([CLC proposal #4](https://github.com/haskell/core-libraries-committee/issues/4))
diff --git a/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs b/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
index e12d20bb674c..a25d9de9be71 100644
--- a/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs
@@ -109,9 +109,6 @@ import GHC.Internal.Foreign.C.String
import GHC.Internal.Foreign.Storable
import GHC.Internal.Foreign.StablePtr
-import GHC.Internal.Data.Typeable
-import GHC.Internal.Data.Maybe
-
import GHC.Internal.Base
import {-# SOURCE #-} GHC.Internal.IO.Handle ( hFlush )
import {-# SOURCE #-} GHC.Internal.IO.StdHandles ( stdout )
@@ -952,11 +949,9 @@ uncaughtExceptionHandler :: IORef (SomeException -> IO ())
uncaughtExceptionHandler = unsafePerformIO (newIORef defaultHandler)
where
defaultHandler :: SomeException -> IO ()
- defaultHandler se@(SomeException ex) = do
+ defaultHandler se = do
(hFlush stdout) `catchAny` (\ _ -> return ())
- let msg = case cast ex of
- Just Deadlock -> "no threads to run: infinite loop or deadlock?"
- _ -> showsPrec 0 se ""
+ let msg = displayException se
withCString "%s" $ \cfmt ->
withCString msg $ \cmsg ->
errorBelch cfmt cmsg
diff --git a/libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs b/libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
index 6d2171cd3d10..0a2eaed53870 100644
--- a/libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
+++ b/libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
@@ -105,7 +105,8 @@ blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM
data Deadlock = Deadlock
-- | @since base-4.1.0.0
-instance Exception Deadlock
+instance Exception Deadlock where
+ displayException _ = "no threads to run: infinite loop or deadlock?"
-- | @since base-4.1.0.0
instance Show Deadlock where
--
GitLab