summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libraries/base/GHC/IO/Handle/Internals.hs34
-rw-r--r--libraries/base/GHC/TopHandler.hs31
-rw-r--r--libraries/base/GHC/Weak/Finalize.hs2
-rw-r--r--testsuite/tests/typecheck/should_compile/all.T18
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, [''])