base: Introduce [sg]etFinalizerExceptionHandler

This introduces a global hook which is called when an exception is
thrown during finalization.

11 files changed, 104 insertions, 31 deletions

diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst
index c5580b5abe..14bf7e2994 100644
--- a/docs/users_guide/9.6.1-notes.rst
+++ b/docs/users_guide/9.6.1-notes.rst
@@ -15,6 +15,10 @@ Compiler
 ``base`` library
 ~~~~~~~~~~~~~~~~
 
+- Exceptions thrown by weak pointer finalizers are now caught and reported
+  via a global exception handler. By default this handler reports the error
+  to ``stderr`` although this can be changed using
+  ``GHC.Weak.Finalize.setFinalizerExceptionHandler``.
 
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/base/GHC/Weak.hs b/libraries/base/GHC/Weak.hs
index 5044d8f8aa..9eff415c99 100644
--- a/libraries/base/GHC/Weak.hs
+++ b/libraries/base/GHC/Weak.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE UnboxedTuples #-}
@@ -25,10 +24,18 @@ module GHC.Weak (
         mkWeak,
         deRefWeak,
         finalize,
-        runFinalizerBatch
+
+        -- * Handling exceptions
+        -- | When an exception is thrown by a finalizer called by the
+        -- garbage collector, GHC calls a global handler which can be set with
+        -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by
+        -- this handler will be ignored.
+        setFinalizerExceptionHandler,
+        getFinalizerExceptionHandler
     ) where
 
 import GHC.Base
+import GHC.Weak.Finalize
 
 {-|
 A weak pointer object with a key and a value.  The value has type @v@.
@@ -131,25 +138,3 @@ Instance Eq (Weak v) where
   (Weak w1) == (Weak w2) = w1 `sameWeak#` w2
 -}
 
-
--- run a batch of finalizers from the garbage collector.  We're given
--- an array of finalizers and the length of the array, and we just
--- call each one in turn.
---
--- the IO primitives are inlined by hand here to get the optimal
--- code (sigh) --SDM.
-
-runFinalizerBatch :: Int -> Array# (State# RealWorld -> State# RealWorld)
-                  -> IO ()
-runFinalizerBatch (I# n) arr =
-   let  go m  = IO $ \s ->
-                  case m of
-                  0# -> (# s, () #)
-                  _  -> let !m' = m -# 1# in
-                        case indexArray# arr m' of { (# io #) ->
-                        case catch# (\p -> (# io p, () #))
-                                    (\_ s'' -> (# s'', () #)) s of          {
-                         (# s', _ #) -> unIO (go m') s'
-                        }}
-   in
-        go n
diff --git a/libraries/base/GHC/Weak/Finalize.hs b/libraries/base/GHC/Weak/Finalize.hs
new file mode 100644
index 0000000000..09308fb3d3
--- /dev/null
+++ b/libraries/base/GHC/Weak/Finalize.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE Unsafe #-}
+
+module GHC.Weak.Finalize
+    ( -- * Handling exceptions
+      -- | When an exception is thrown by a finalizer called by the
+      -- garbage collector, GHC calls a global handler which can be set with
+      -- 'setFinalizerExceptionHandler'. Note that any exceptions thrown by
+      -- this handler will be ignored.
+      setFinalizerExceptionHandler
+    , getFinalizerExceptionHandler
+      -- * Internal
+    , runFinalizerBatch
+    ) where
+
+import GHC.Base
+import GHC.Exception
+import GHC.IORef
+import GHC.IO (catchException, unsafePerformIO)
+
+-- | Run a batch of finalizers from the garbage collector.  We're given
+-- an array of finalizers and the length of the array, and we just
+-- call each one in turn.
+runFinalizerBatch :: Int
+                  -> Array# (State# RealWorld -> State# RealWorld)
+                  -> IO ()
+runFinalizerBatch (I# n) arr =
+    go n
+  where
+    getFinalizer :: Int# -> IO ()
+    getFinalizer i =
+        case indexArray# arr i of
+          (# io #) -> IO $ \s ->
+              case io s of
+                s' -> (# s', () #)
+
+    go :: Int# -> IO ()
+    go 0# = return ()
+    go i = do
+        let i' = i -# 1#
+        let finalizer = getFinalizer i'
+        finalizer `catchException` handleExc
+        go i'
+
+    handleExc :: SomeException -> IO ()
+    handleExc se = do
+        handleFinalizerExc <- getFinalizerExceptionHandler
+        handleFinalizerExc se `catchException` (\(SomeException _) -> return ())
+
+finalizerExceptionHandler :: IORef (SomeException -> IO ())
+finalizerExceptionHandler = unsafePerformIO $ newIORef (const $ return ())
+{-# NOINLINE finalizerExceptionHandler #-}
+
+-- | Get the global action called to report exceptions thrown by weak pointer
+-- finalizers to the user.
+--
+-- @since 4.18.0.0
+getFinalizerExceptionHandler :: IO (SomeException -> IO ())
+getFinalizerExceptionHandler = readIORef finalizerExceptionHandler
+
+-- | Set the global action called to report exceptions thrown by weak pointer
+-- finalizers to the user.
+--
+-- @since 4.18.0.0
+setFinalizerExceptionHandler :: (SomeException -> IO ()) -> IO ()
+setFinalizerExceptionHandler = writeIORef finalizerExceptionHandler
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index e0cd8f4197..7ecc17b3fa 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -285,6 +285,7 @@ Library
         GHC.TypeNats.Internal
         GHC.Unicode
         GHC.Weak
+        GHC.Weak.Finalize
         GHC.Word
         Numeric
         Numeric.Natural
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 76c4731b01..3762ebf4df 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -2,6 +2,11 @@
 
 ## 4.18.0.0 *TBA*
 
+  * Exceptions thrown by weak pointer finalizers are now reported via a global
+    exception handler.
+  * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which the user to
+    override the above-mentioned handler.
+
 ## 4.17.0.0 *TBA*
 
   * Add explicitly bidirectional `pattern TypeRep` to `Type.Reflection`.
diff --git a/libraries/base/tests/T13167.stderr b/libraries/base/tests/T13167.stderr
new file mode 100644
index 0000000000..ecb0102c0b
--- /dev/null
+++ b/libraries/base/tests/T13167.stderr
@@ -0,0 +1,4 @@
+Exception during Weak# finalization (ignored): failed
+Exception during Weak# finalization (ignored): failed
+Exception during Weak# finalization (ignored): failed
+Exception during Weak# finalization (ignored): failed
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index d39b41b92a..fbc3b69dcf 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -250,7 +250,12 @@ test('T3474',
 test('T14425', normal, compile_and_run, [''])
 test('T10412', normal, compile_and_run, [''])
 test('T13896', normal, compile_and_run, [''])
-test('T13167', fragile_for(16536, concurrent_ways), compile_and_run, [''])
+# On Windows this test is fragile using the old MIO IO manager due to an
+# apparent flushing bug.
+test('T13167',
+     [when(opsys('mingw32'), only_ways(['winio', 'winio_threaded'])),
+      fragile_for(16536, concurrent_ways)],
+     compile_and_run, [''])
 test('T15349', [exit_code(1), expect_broken_for(15349, ['ghci'])], compile_and_run, [''])
 test('T16111', exit_code(1), compile_and_run, [''])
 test('T16943a', normal, compile_and_run, [''])
diff --git a/rts/Prelude.h b/rts/Prelude.h
index 5f1e070e33..2a935f9f90 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -34,6 +34,7 @@ PRELUDE_CLOSURE(ghczmprim_GHCziTypes_True_closure);
 PRELUDE_CLOSURE(ghczmprim_GHCziTypes_False_closure);
 PRELUDE_CLOSURE(base_GHCziPack_unpackCString_closure);
 PRELUDE_CLOSURE(base_GHCziWeak_runFinalizzerBatch_closure);
+PRELUDE_CLOSURE(base_GHCziWeakziFinalizze_runFinalizzerBatch_closure);
 
 #if defined(IN_STG_CODE)
 extern W_ ZCMain_main_closure[];
@@ -91,7 +92,7 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
 #define True_closure              DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_True_closure)
 #define False_closure             DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_False_closure)
 #define unpackCString_closure     DLL_IMPORT_DATA_REF(base_GHCziPack_unpackCString_closure)
-#define runFinalizerBatch_closure DLL_IMPORT_DATA_REF(base_GHCziWeak_runFinalizzerBatch_closure)
+#define runFinalizerBatch_closure DLL_IMPORT_DATA_REF(base_GHCziWeakziFinalizze_runFinalizzerBatch_closure)
 #define mainIO_closure            (&ZCMain_main_closure)
 
 #define runSparks_closure         DLL_IMPORT_DATA_REF(base_GHCziConcziSync_runSparks_closure)
diff --git a/rts/package.conf.in b/rts/package.conf.in
index cb5a436f5c..248b6b9c57 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -89,7 +89,7 @@ ld-options:
          , "-Wl,-u,_ghczmprim_GHCziTypes_True_closure"
          , "-Wl,-u,_ghczmprim_GHCziTypes_False_closure"
          , "-Wl,-u,_base_GHCziPack_unpackCString_closure"
-         , "-Wl,-u,_base_GHCziWeak_runFinalizzerBatch_closure"
+         , "-Wl,-u,_base_GHCziWeakziFinalizze_runFinalizzerBatch_closure"
          , "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure"
          , "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure"
          , "-Wl,-u,_base_GHCziIOziException_allocationLimitExceeded_closure"
@@ -202,7 +202,7 @@ ld-options:
          , "-Wl,-u,ghczmprim_GHCziTypes_True_closure"
          , "-Wl,-u,ghczmprim_GHCziTypes_False_closure"
          , "-Wl,-u,base_GHCziPack_unpackCString_closure"
-         , "-Wl,-u,base_GHCziWeak_runFinalizzerBatch_closure"
+         , "-Wl,-u,base_GHCziWeakziFinalizze_runFinalizzerBatch_closure"
          , "-Wl,-u,base_GHCziIOziException_stackOverflow_closure"
          , "-Wl,-u,base_GHCziIOziException_heapOverflow_closure"
          , "-Wl,-u,base_GHCziIOziException_allocationLimitExceeded_closure"
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index cc449ee522..96989ee750 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -257,7 +257,7 @@ library
          "-Wl,-u,_ghczmprim_GHCziTypes_True_closure"
          "-Wl,-u,_ghczmprim_GHCziTypes_False_closure"
          "-Wl,-u,_base_GHCziPack_unpackCString_closure"
-         "-Wl,-u,_base_GHCziWeak_runFinalizzerBatch_closure"
+         "-Wl,-u,_base_GHCziWeakziFinalizze_runFinalizzerBatch_closure"
          "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure"
          "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure"
          "-Wl,-u,_base_GHCziIOziException_allocationLimitExceeded_closure"
@@ -340,7 +340,7 @@ library
          "-Wl,-u,ghczmprim_GHCziTypes_True_closure"
          "-Wl,-u,ghczmprim_GHCziTypes_False_closure"
          "-Wl,-u,base_GHCziPack_unpackCString_closure"
-         "-Wl,-u,base_GHCziWeak_runFinalizzerBatch_closure"
+         "-Wl,-u,base_GHCziWeakziFinalizze_runFinalizzerBatch_closure"
          "-Wl,-u,base_GHCziIOziException_stackOverflow_closure"
          "-Wl,-u,base_GHCziIOziException_heapOverflow_closure"
          "-Wl,-u,base_GHCziIOziException_allocationLimitExceeded_closure"
diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def
index cb9c32729e..e91d11a688 100644
--- a/rts/win32/libHSbase.def
+++ b/rts/win32/libHSbase.def
@@ -34,7 +34,7 @@ EXPORTS
 
 	base_GHCziTopHandler_flushStdHandles_closure
 
-        base_GHCziWeak_runFinalizzerBatch_closure
+    base_GHCziWeakziFinalizze_runFinalizzerBatch_closure
 	base_GHCziPack_unpackCString_closure
 	base_GHCziIOziException_blockedIndefinitelyOnMVar_closure
 	base_GHCziIOziException_blockedIndefinitelyOnSTM_closure