{-# 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 , printToHandleFinalizerExceptionHandler -- * Internal , runFinalizerBatch ) where import GHC.Base import GHC.Exception import GHC.IORef import {-# SOURCE #-} GHC.Conc.Sync (labelThreadByteArray#, myThreadId) import GHC.IO (catchException, unsafePerformIO) import {-# SOURCE #-} GHC.IO.Handle.Types (Handle) import {-# SOURCE #-} GHC.IO.Handle.Text (hPutStrLn) import GHC.Encoding.UTF8 (utf8EncodeByteArray#) data ByteArray = ByteArray ByteArray# -- | The label we use for finalization threads. We manually float this to the -- top-level to ensure that the ByteArray# can be shared. label :: ByteArray label = ByteArray (utf8EncodeByteArray# "weak finalizer thread") -- | 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 = do tid <- myThreadId case label of ByteArray ba# -> labelThreadByteArray# tid ba# 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 ()) -- See Note [Handling exceptions during Handle finalization] for the -- motivation for this mechanism. 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 -- | An exception handler for 'Handle' finalization that prints the error to -- the given 'Handle', but doesn't rethrow it. -- -- @since 4.18.0.0 printToHandleFinalizerExceptionHandler :: Handle -> SomeException -> IO () printToHandleFinalizerExceptionHandler hdl se = hPutStrLn hdl msg `catchException` (\(SomeException _) -> return ()) where msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n"