base: Throw exceptions raised while closing finalized Handles

Fixes #21336.

4 files changed, 70 insertions, 15 deletions

diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs
index cbd43c1666..cd1f6a35ef 100644
--- a/libraries/base/GHC/IO/Handle/Internals.hs
+++ b/libraries/base/GHC/IO/Handle/Internals.hs
@@ -440,9 +440,39 @@ recoveringEncode codec from to = go from to
 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
 handleFinalizer fp m = do
   handle_ <- takeMVar m
-  (handle_', _) <- hClose_help handle_
+  (handle_', mb_exc) <- hClose_help handle_
   putMVar m handle_'
-  return ()
+  case mb_exc of
+    Just exc -> throwIO exc
+    Nothing -> return ()
+
+{-
+   Note [Handling exceptions during Handle finalization]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   Handles which become unreachable are flushed closed automatically by the
+   garbage collector, which calls 'GHC.IO.Handle.Internals.handleFinalizer'.
+   However, numerous things can go wrong during this process. For instance,
+   while we are flushing we may find that the handle's device is full. What to
+   do in this case?
+
+   For a long time we would simply ignore the failure. However, silently
+   ignoring failures is rarely a good option. For this reason the
+   'GHC.Weak.Finalizer.runFinalizerBatch' now catches exceptions and
+   dispatches them to a notification action (which can be set via
+   'GHC.Weak.Finalize.setFinalizerExceptionHandler').
+
+   This then poses the question of what happens if the exception notification
+   action itself throws an exception. We currently ignore such second-order
+   exceptions.
+
+   Note that stdout/stderr are handled a bit differently, since they are never
+   finalized by the GC. Instead, 'GHC.TopHandler.flushStdHandles' explicitly
+   catches exceptions from hFlush and dispatches them to the usual Weak
+   finalization exception notifier.
+
+   See #21336.
+
+ -}
 
 -- ---------------------------------------------------------------------------
 -- Allocating buffers
diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs
index 6a4e0325a6..704e521e18 100644
--- a/libraries/base/GHC/TopHandler.hs
+++ b/libraries/base/GHC/TopHandler.hs
@@ -81,6 +81,7 @@ runMainIO main =
     do
       main_thread_id <- myThreadId
       weak_tid <- mkWeakThreadId main_thread_id
+      setFinalizerExceptionHandler handleFinalizerException
       case weak_tid of (Weak w) -> setMainThread w
       install_interrupt_handler $ do
            m <- deRefWeak weak_tid
@@ -226,13 +227,33 @@ calling the RTS, without iconv at all.
 -}
 
 
--- try to flush stdout/stderr, but don't worry if we fail
--- (these handles might have errors, and we don't want to go into
--- an infinite loop).
+-- try to flush stdout/stderr.
 flushStdHandles :: IO ()
 flushStdHandles = do
-  hFlush stdout `catchAny` \_ -> return ()
-  hFlush stderr `catchAny` \_ -> return ()
+  hFlush stdout `catchException` handleExc
+  -- In the event that we fail to flush stderr the default finalizer exception
+  -- handler (which prints to stderr) will also likely fail. However, we call it
+  -- anyways since the user may have set their own handler.
+  hFlush stderr `catchException` handleExc
+  where
+    -- We dispatch exceptions thrown by hFlush to the same action used to
+    -- handle Weak finalizers since this is where "normal" Handles (e.g. not
+    -- stderr/stdout) would be flushed.
+    --
+    -- See Note [Handling exceptions during Handle finalization] in
+    -- GHC.IO.Handle.Internals
+    handleExc se = do
+      handleFinalizerExc <- getFinalizerExceptionHandler
+      -- 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/GHC/Weak/Finalize.hs b/libraries/base/GHC/Weak/Finalize.hs
index 09308fb3d3..d16277248b 100644
--- a/libraries/base/GHC/Weak/Finalize.hs
+++ b/libraries/base/GHC/Weak/Finalize.hs
@@ -49,6 +49,8 @@ runFinalizerBatch (I# n) arr =
         handleFinalizerExc <- getFinalizerExceptionHandler
         handleFinalizerExc se `catchException` (\(SomeException _) -> return ())
 
+-- See Note [Handling exceptions during Handle finalization] for the
+-- motivation for this mechanism.
 finalizerExceptionHandler :: IORef (SomeException -> IO ())
 finalizerExceptionHandler = unsafePerformIO $ newIORef (const $ return ())
 {-# NOINLINE finalizerExceptionHandler #-}
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index e9596fb6f4..fb9eba2c8d 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -779,14 +779,16 @@ test('TyAppPat_Wildcard', normal, compile, [''])
 
 test('T18998', normal, compile, [''])
 test('T18998b', normal, compile, [''])
-test('InlinePatSyn_InlinableBuilder', [], makefile_test, [])
-test('InlinePatSyn_InlinableMatcher', [], makefile_test, [])
-test('InlinePatSyn_InlineBuilder', [], makefile_test, [])
-test('InlinePatSyn_InlineMatcher', [], makefile_test, [])
-test('InlinePatSyn_NoInlineBuilder', [], makefile_test, [])
-test('InlinePatSyn_NoInlineMatcher', [], makefile_test, [])
-test('InlinePatSyn_ExplicitBidiBuilder', [], makefile_test, [])
-test('InlinePatSyn_ExplicitBidiMatcher', [], makefile_test, [])
+# Ignore stderr as otherwise we see a warning due to grep closing GHC's stdout before
+# GHC has finished writing to it.
+test('InlinePatSyn_InlinableBuilder', [ignore_stderr], makefile_test, [])
+test('InlinePatSyn_InlinableMatcher', [ignore_stderr], makefile_test, [])
+test('InlinePatSyn_InlineBuilder', [ignore_stderr], makefile_test, [])
+test('InlinePatSyn_InlineMatcher', [ignore_stderr], makefile_test, [])
+test('InlinePatSyn_NoInlineBuilder', [ignore_stderr], makefile_test, [])
+test('InlinePatSyn_NoInlineMatcher', [ignore_stderr], makefile_test, [])
+test('InlinePatSyn_ExplicitBidiBuilder', [ignore_stderr], makefile_test, [])
+test('InlinePatSyn_ExplicitBidiMatcher', [ignore_stderr], makefile_test, [])
 test('T18467', normal, compile, [''])
 
 test('T19315', normal, compile, [''])