base: Introduce [sg]etFinalizerExceptionHandler

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

6 files changed, 93 insertions, 25 deletions

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, [''])