blob: 87bc7b9f7e5c20186078c72a79cd0dd0cfcf22cf (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
{-# 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"
|
