base: Introduce [sg]etFinalizerExceptionHandler

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

8 files changed, 77 insertions, 29 deletions

diff --git a/libraries/base/GHC/Weak.hs b/libraries/base/GHC/Weak.hs
index 5044d8f8aa..df57ad0165 100644
--- a/libraries/base/GHC/Weak.hs
+++ b/libraries/base/GHC/Weak.hs
@@ -25,10 +25,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 +139,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..1e6aceae75
--- /dev/null
+++ b/libraries/base/GHC/Weak/Finalize.hs
@@ -0,0 +1,60 @@
+{-# 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 #-}
+
+getFinalizerExceptionHandler :: IO (SomeException -> IO ())
+getFinalizerExceptionHandler = readIORef finalizerExceptionHandler
+
+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/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 ff60f1b456..5e9ccdd787 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
diff --git a/utils/haddock b/utils/haddock
-Subproject 7921211350a572d5365e7feb5fa4cc04666318e
+Subproject 24208496649a02d5f87373052c430ea4a97842c