Make finalizers more reliable.

Ignore any errors thrown by finalizers when running them.

This prevents a faulty finalizer from stopping the rest being called.

Test Plan: ./validate, new test T13167

Reviewers: hvr, bgamari, simonmar

Reviewed By: bgamari, simonmar

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #13167

Differential Revision: https://phabricator.haskell.org/D4693

4 files changed, 34 insertions, 2 deletions

diff --git a/libraries/base/GHC/Weak.hs b/libraries/base/GHC/Weak.hs
index 8f886a6d23..6a53096828 100644
--- a/libraries/base/GHC/Weak.hs
+++ b/libraries/base/GHC/Weak.hs
@@ -149,8 +149,9 @@ runFinalizerBatch (I# n) arr =
                   0# -> (# s, () #)
                   _  -> let !m' = m -# 1# in
                         case indexArray# arr m' of { (# io #) ->
-                        case io s of          { s' ->
-                        unIO (go m') s'
+                        case catch# (\p -> (# io p, () #))
+                                    (\_ s'' -> (# s'', () #)) s of          {
+                         (# s', _ #) -> unIO (go m') s'
                         }}
    in
         go n
diff --git a/libraries/base/tests/T13167.hs b/libraries/base/tests/T13167.hs
new file mode 100644
index 0000000000..e41104cde9
--- /dev/null
+++ b/libraries/base/tests/T13167.hs
@@ -0,0 +1,29 @@
+import Data.IORef
+import Control.Monad
+import Control.Exception
+import Control.Concurrent.MVar
+import System.Mem
+
+main :: IO ()
+main = do
+  run
+  run
+  run
+  run
+  m <- newEmptyMVar
+  quit m
+  performMajorGC
+  takeMVar m
+
+run :: IO ()
+run = do
+  ref <- newIORef ()
+  void $ mkWeakIORef ref $ do
+    putStr "."
+    throwIO $ ErrorCall "failed"
+
+quit :: MVar () -> IO ()
+quit m = do
+  ref <- newIORef ()
+  void $ mkWeakIORef ref $ do
+    putMVar m ()
diff --git a/libraries/base/tests/T13167.stdout b/libraries/base/tests/T13167.stdout
new file mode 100644
index 0000000000..4918d25340
--- /dev/null
+++ b/libraries/base/tests/T13167.stdout
@@ -0,0 +1 @@
+....

diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 491df2fd7e..d530e10266 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -224,3 +224,4 @@ test('T3474',
 test('T14425', normal, compile_and_run, [''])
 test('T10412', normal, compile_and_run, [''])
 test('T13896', normal, compile_and_run, [''])
+test('T13167', normal, compile_and_run, [''])