{-# 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"