{-# 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 {-# SOURCE #-} GHC.Conc.Sync (labelThreadByteArray#, myThreadId)
import GHC.IO (catchException, unsafePerformIO)
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
label = ByteArray# -> ByteArray
ByteArray (String -> ByteArray#
utf8EncodeByteArray# String
"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 :: Int -> Array# (State# RealWorld -> State# RealWorld) -> IO ()
runFinalizerBatch (I# Int#
n) Array# (State# RealWorld -> State# RealWorld)
arr = do
    ThreadId
tid <- IO ThreadId
myThreadId
    case ByteArray
label of ByteArray ByteArray#
ba# -> ThreadId -> ByteArray# -> IO ()
labelThreadByteArray# ThreadId
tid ByteArray#
ba#
    Int# -> IO ()
go Int#
n
  where
    getFinalizer :: Int# -> IO ()
    getFinalizer :: Int# -> IO ()
getFinalizer Int#
i =
        case Array# (State# RealWorld -> State# RealWorld)
-> Int# -> (# State# RealWorld -> State# RealWorld #)
forall a. Array# a -> Int# -> (# a #)
indexArray# Array# (State# RealWorld -> State# RealWorld)
arr Int#
i of
          (# State# RealWorld -> State# RealWorld
io #) -> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
              case State# RealWorld -> State# RealWorld
io State# RealWorld
s of
                State# RealWorld
s' -> (# State# RealWorld
s', () #)

    go :: Int# -> IO ()
    go :: Int# -> IO ()
go Int#
0# = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go Int#
i = do
        let i' :: Int#
i' = Int#
i Int# -> Int# -> Int#
-# Int#
1#
        let finalizer :: IO ()
finalizer = Int# -> IO ()
getFinalizer Int#
i'
        IO ()
finalizer IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` SomeException -> IO ()
handleExc
        Int# -> IO ()
go Int#
i'

    handleExc :: SomeException -> IO ()
    handleExc :: SomeException -> IO ()
handleExc SomeException
se = do
        SomeException -> IO ()
handleFinalizerExc <- IO (SomeException -> IO ())
getFinalizerExceptionHandler
        SomeException -> IO ()
handleFinalizerExc SomeException
se IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` (\(SomeException e
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- See Note [Handling exceptions during Handle finalization] for the
-- motivation for this mechanism.
finalizerExceptionHandler :: IORef (SomeException -> IO ())
finalizerExceptionHandler :: IORef (SomeException -> IO ())
finalizerExceptionHandler = IO (IORef (SomeException -> IO ()))
-> IORef (SomeException -> IO ())
forall a. IO a -> a
unsafePerformIO (IO (IORef (SomeException -> IO ()))
 -> IORef (SomeException -> IO ()))
-> IO (IORef (SomeException -> IO ()))
-> IORef (SomeException -> IO ())
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO ()) -> IO (IORef (SomeException -> IO ()))
forall a. a -> IO (IORef a)
newIORef (IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const (IO () -> SomeException -> IO ())
-> IO () -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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 :: IO (SomeException -> IO ())
getFinalizerExceptionHandler = IORef (SomeException -> IO ()) -> IO (SomeException -> IO ())
forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
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 :: (SomeException -> IO ()) -> IO ()
setFinalizerExceptionHandler = IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
finalizerExceptionHandler