No default finalizer exception handler

Commit cfc8e2e2 introduced a mechanism for handling of exceptions
that occur during Handle finalization, and 372cf730 set the default
handler to print out the error to stderr.

However, #21680 pointed out we might not want to set this by default,
as it might pollute users' terminals with unwanted information.
So, for the time being, the default handler discards the exception.

Fixes #21680

(cherry picked from commit 681e0e8ce470ec77a0db071f9fc7ec15995a0bb3)

10 files changed, 49 insertions, 25 deletions

diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs
index 04045dad05..a2354175e4 100644
--- a/libraries/base/GHC/TopHandler.hs
+++ b/libraries/base/GHC/TopHandler.hs
@@ -83,7 +83,11 @@ runMainIO main =
     do
       main_thread_id <- myThreadId
       weak_tid <- mkWeakThreadId main_thread_id
-      setFinalizerExceptionHandler handleFinalizerException
+
+    --setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
+      -- For the time being, we don't install any exception handler for
+      -- Handle finalization. Instead, the user should set one manually.
+
       case weak_tid of (Weak w) -> setMainThread w
       install_interrupt_handler $ do
            m <- deRefWeak weak_tid
@@ -253,13 +257,6 @@ flushStdHandles = do
       -- Swallow any exceptions thrown by the finalizer exception handler
       handleFinalizerExc se `catchException` (\(SomeException _) -> return ())
 
--- | See Note [Handling exceptions during Handle finalization] in
--- GHC.IO.Handle.Internals
-handleFinalizerException :: SomeException -> IO ()
-handleFinalizerException se =
-    hPutStr stderr msg `catchException` (\(SomeException _) -> return ())
-  where
-    msg = "Exception during Weak# finalization (ignored): " ++ displayException se ++ "\n"
 
 safeExit, fastExit :: Int -> IO a
 safeExit = exitHelper useSafeExit
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 85011586a5..d7d2ba14eb 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -6,10 +6,9 @@
   * Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91))
   * Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and
     `(,,,,,) a b c d e f`.
-  * Exceptions thrown by weak pointer finalizers are now reported via a global
-    exception handler.
-  * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which allows the
-    user to override the above-mentioned handler.
+  * Exceptions thrown by weak pointer finalizers can now be reported by setting
+    a global exception handler, using `System.Mem.Weak.setFinalizerExceptionHandler`.
+    The default behaviour is unchanged (exceptions are ignored and not reported).
   * `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe`
     ([CLC proposal #45](https://github.com/haskell/core-libraries-committee/issues/45))
   * Add `Data.Foldable1` and `Data.Bifoldable1`
diff --git a/libraries/base/tests/IO/T21336/FinalizerExceptionHandler.hs b/libraries/base/tests/IO/T21336/FinalizerExceptionHandler.hs
new file mode 100644
index 0000000000..92ff2d8c86
--- /dev/null
+++ b/libraries/base/tests/IO/T21336/FinalizerExceptionHandler.hs
@@ -0,0 +1,21 @@
+module FinalizerExceptionHandler
+  ( setFinalizerExceptionHandler
+  , getFinalizerExceptionHandler
+  , printToStderrFinalizerExceptionHandler )
+  where
+
+import GHC.Exception     ( SomeException(..), displayException )
+import GHC.IO            ( catchException )
+import GHC.IO.Handle     ( hPutStr )
+import GHC.IO.StdHandles ( stderr )
+import GHC.Weak.Finalize ( setFinalizerExceptionHandler, getFinalizerExceptionHandler )
+
+-- | An exception handler for Handle finalization that prints the error to
+-- stderr, but doesn't rethrow it.
+printToStderrFinalizerExceptionHandler :: SomeException -> IO ()
+-- See Note [Handling exceptions during Handle finalization] in
+-- GHC.IO.Handle.Internals
+printToStderrFinalizerExceptionHandler se =
+    hPutStr stderr msg `catchException` (\(SomeException _) -> return ())
+  where
+    msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n"
diff --git a/libraries/base/tests/IO/T21336/T21336a.hs b/libraries/base/tests/IO/T21336/T21336a.hs
index 91c852ce92..80c260e655 100644
--- a/libraries/base/tests/IO/T21336/T21336a.hs
+++ b/libraries/base/tests/IO/T21336/T21336a.hs
@@ -1,9 +1,10 @@
-import GHC.Weak
 import System.IO
 import System.Mem
+import FinalizerExceptionHandler
 
 main :: IO ()
 main = do
+    setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
     f <- openFile "/dev/full" WriteMode
     hPutStr f "hello"
     -- Ensure that the Handle's finalizer is run
diff --git a/libraries/base/tests/IO/T21336/T21336a.stderr b/libraries/base/tests/IO/T21336/T21336a.stderr
index 059b0e2473..039d26a4af 100644
--- a/libraries/base/tests/IO/T21336/T21336a.stderr
+++ b/libraries/base/tests/IO/T21336/T21336a.stderr
@@ -1 +1 @@
-Exception during Weak# finalization (ignored): GHC.IO.FD.fdWrite: resource exhausted (No space left on device)
+Exception during weak pointer finalization (ignored): GHC.IO.FD.fdWrite: resource exhausted (No space left on device)
diff --git a/libraries/base/tests/IO/T21336/T21336b.hs b/libraries/base/tests/IO/T21336/T21336b.hs
index a8f0329dd0..6d397950e9 100644
--- a/libraries/base/tests/IO/T21336/T21336b.hs
+++ b/libraries/base/tests/IO/T21336/T21336b.hs
@@ -1,6 +1,9 @@
-import GHC.Weak
 import System.IO
+import System.Mem
+import FinalizerExceptionHandler
 
 main :: IO ()
-main = hPutStr stdout "hello"
+main = do
+  setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
+  hPutStr stdout "hello"
 
diff --git a/libraries/base/tests/IO/T21336/T21336b.stderr b/libraries/base/tests/IO/T21336/T21336b.stderr
index 66a347472a..2e702f81e7 100644
--- a/libraries/base/tests/IO/T21336/T21336b.stderr
+++ b/libraries/base/tests/IO/T21336/T21336b.stderr
@@ -1 +1 @@
-Exception during Weak# finalization (ignored): <stdout>: hFlush: resource exhausted (No space left on device)
+Exception during weak pointer finalization (ignored): <stdout>: hFlush: resource exhausted (No space left on device)
diff --git a/libraries/base/tests/IO/T21336/T21336c.hs b/libraries/base/tests/IO/T21336/T21336c.hs
index a8f0329dd0..6d397950e9 100644
--- a/libraries/base/tests/IO/T21336/T21336c.hs
+++ b/libraries/base/tests/IO/T21336/T21336c.hs
@@ -1,6 +1,9 @@
-import GHC.Weak
 import System.IO
+import System.Mem
+import FinalizerExceptionHandler
 
 main :: IO ()
-main = hPutStr stdout "hello"
+main = do
+  setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
+  hPutStr stdout "hello"
 
diff --git a/libraries/base/tests/IO/T21336/all.T b/libraries/base/tests/IO/T21336/all.T
index b14e0c771b..e187a54bcd 100644
--- a/libraries/base/tests/IO/T21336/all.T
+++ b/libraries/base/tests/IO/T21336/all.T
@@ -3,14 +3,18 @@ test('T21336a',
      [ unless(opsys('linux') or opsys('freebsd'), skip)
      , js_broken(22261)
      , fragile(22022)
+     , extra_files(['FinalizerExceptionHandler.hs'])
      ],
      compile_and_run, [''])
 test('T21336b',
-     [unless(opsys('linux') or opsys('freebsd'), skip), js_broken(22352)],
+     [ unless(opsys('linux') or opsys('freebsd'), skip)
+     , js_broken(22352)
+     , extra_files(['FinalizerExceptionHandler.hs'])
+     ],
      makefile_test, [])
 test('T21336c',
      [ unless(opsys('linux') or opsys('freebsd'), skip)
      , js_broken(22370)
+     , extra_files(['FinalizerExceptionHandler.hs'])
      ],
      makefile_test, [])
-
diff --git a/libraries/base/tests/T13167.stderr b/libraries/base/tests/T13167.stderr
deleted file mode 100644
index ecb0102c0b..0000000000
--- a/libraries/base/tests/T13167.stderr
+++ /dev/null
@@ -1,4 +0,0 @@
-Exception during Weak# finalization (ignored): failed
-Exception during Weak# finalization (ignored): failed
-Exception during Weak# finalization (ignored): failed
-Exception during Weak# finalization (ignored): failed