content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE MagicHash #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE UnliftedFFITypes #-}
  
  {-# OPTIONS_HADDOCK not-home #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  GHC.Internal.TopHandler
  -- Copyright   :  (c) The University of Glasgow, 2001-2002
  -- License     :  see libraries/base/LICENSE
  --
  -- Maintainer  :  ghc-devs@haskell.org
  -- Stability   :  internal
  -- Portability :  non-portable (GHC Extensions)
  --
  -- Support for catching exceptions raised during top-level computations
  -- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)
  --
  -- /The API of this module is unstable and not meant to be consumed by the general public./
  -- If you absolutely must depend on it, make sure to use a tight upper
  -- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can
  -- change rapidly without much warning.
  --
  -----------------------------------------------------------------------------
  
  module GHC.Internal.TopHandler (
          runMainIO, runIO, runIOFastExit, runNonIO,
          topHandler, topHandlerFastExit,
          reportStackOverflow, reportError,
          flushStdHandles
      ) where
  
  #include <ghcplatform.h>
  #include "HsBaseConfig.h"
  
  import GHC.Internal.Control.Exception
  import GHC.Internal.Data.Maybe
  
  import GHC.Internal.Foreign.C.Error
  import GHC.Internal.Foreign.C.Types
  import GHC.Internal.Foreign.C.String
  import GHC.Internal.Base
  import GHC.Internal.Conc.Sync hiding (throwTo)
  import GHC.Internal.Real
  import GHC.Internal.IO
  import GHC.Internal.IO.Handle
  import GHC.Internal.IO.StdHandles
  import GHC.Internal.IO.Exception
  import GHC.Internal.Weak
  
  #if defined(mingw32_HOST_OS)
  import GHC.Internal.ConsoleHandler as GHC.ConsoleHandler
  #elif defined(javascript_HOST_ARCH)
  #else
  import GHC.Internal.Ptr
  import GHC.Internal.Conc.Signal
  import GHC.Internal.Data.Dynamic (toDyn)
  #endif
  
  -- Note [rts_setMainThread must be called unsafely]
  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- rts_setMainThread must be called as unsafe, because it
  -- dereferences the Weak# and manipulates the raw Haskell value
  -- behind it.  Therefore, it must not race with a garbage collection.
  
  
  -- Note [rts_setMainThread has an unsound type]
  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- 'rts_setMainThread' is imported with type Weak# ThreadId -> IO (),
  -- but this is an unsound type for it: it grabs the /key/ of the
  -- 'Weak#' object, which isn't tracked by the type at all.
  -- That this works at all is a consequence of the fact that
  -- 'mkWeakThreadId' produces a 'Weak#' with a 'ThreadId#' as the key
  -- This is fairly robust, in that 'mkWeakThreadId' wouldn't work
  -- otherwise, but it still is sufficiently non-trivial to justify an
  -- ASSERT in rts/TopHandler.c.
  
  -- see Note [rts_setMainThread must be called unsafely] and
  -- Note [rts_setMainThread has an unsound type]
  foreign import ccall unsafe "rts_setMainThread"
    setMainThread :: Weak# ThreadId -> IO ()
  
  -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
  -- called in the program).  It catches otherwise uncaught exceptions,
  -- and also flushes stdout\/stderr before exiting.
  runMainIO :: IO a -> IO a
  runMainIO main =
      do
        main_thread_id <- myThreadId
        weak_tid <- mkWeakThreadId main_thread_id
  
        --setFinalizerExceptionHandler (printToHandleFinalizerExceptionHandler stderr)
        -- For the time being, we don't install any exception handler for
        -- Handle finalization. Instead, the user should set one manually.
  
        case weak_tid of (Weak w) -> setMainThread w
        install_interrupt_handler $ do
             m <- deRefWeak weak_tid
             case m of
                 Nothing  -> return ()
                 Just tid -> throwTo tid (toException UserInterrupt)
        main -- hs_exit() will flush
      `catch`
        topHandler
  
  install_interrupt_handler :: IO () -> IO ()
  #if defined(javascript_HOST_ARCH)
  install_interrupt_handler _ = return ()
  #elif defined(mingw32_HOST_OS)
  install_interrupt_handler handler = do
    _ <- GHC.ConsoleHandler.installHandler $
       Catch $ \event ->
          case event of
             ControlC -> handler
             Break    -> handler
             Close    -> handler
             _ -> return ()
    return ()
  #elif !defined(HAVE_SIGNAL_H)
  install_interrupt_handler _ = pure ()
  #else
  #include "rts/Signals.h"
  -- specialised version of System.Posix.Signals.installHandler, which
  -- isn't available here.
  install_interrupt_handler handler = do
     let sig = CONST_SIGINT :: CInt
     _ <- setHandler sig (Just (const handler, toDyn handler))
     _ <- stg_sig_install sig STG_SIG_RST nullPtr
       -- STG_SIG_RST: the second ^C kills us for real, just in case the
       -- RTS or program is unresponsive.
     return ()
  
  foreign import ccall unsafe
    stg_sig_install
          :: CInt                         -- sig no.
          -> CInt                         -- action code (STG_SIG_HAN etc.)
          -> Ptr ()                       -- (in, out) blocked
          -> IO CInt                      -- (ret) old action code
  #endif
  
  -- | 'runIO' is wrapped around every @foreign export@ and @foreign
  -- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the
  -- result of running 'GHC.Internal.System.Exit.exitWith' in a foreign-exported
  -- function is the same as in the main thread: it terminates the
  -- program.
  --
  runIO :: IO a -> IO a
  runIO main = catch main topHandler
  
  -- | Like 'runIO', but in the event of an exception that causes an exit,
  -- we don't shut down the system cleanly, we just exit.  This is
  -- useful in some cases, because the safe exit version will give other
  -- threads a chance to clean up first, which might shut down the
  -- system in a different way.  For example, try
  --
  --   main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
  --
  -- This will sometimes exit with "interrupted" and code 0, because the
  -- main thread is given a chance to shut down when the child thread calls
  -- safeExit.  There is a race to shut down between the main and child threads.
  --
  runIOFastExit :: IO a -> IO a
  runIOFastExit main = catch main topHandlerFastExit
          -- NB. this is used by the testsuite driver
  
  -- | The same as 'runIO', but for non-IO computations.  Used for
  -- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
  -- are used to export Haskell functions with non-IO types.
  --
  runNonIO :: a -> IO a
  runNonIO a = catch (a `seq` return a) topHandler
  
  topHandler :: SomeException -> IO a
  topHandler err = catch (real_handler safeExit err) topHandler
  
  topHandlerFastExit :: SomeException -> IO a
  topHandlerFastExit err =
    catchException (real_handler fastExit err) topHandlerFastExit
  
  -- Make sure we handle errors while reporting the error!
  -- (e.g. evaluating the string passed to 'error' might generate
  --  another error, etc.)
  --
  real_handler :: (Int -> IO a) -> SomeException -> IO a
  real_handler exit se = do
    flushStdHandles -- before any error output
    case fromException se of
        Just StackOverflow -> do
             reportStackOverflow
             exit 2
  
        Just UserInterrupt -> exitInterrupted
  
        Just HeapOverflow -> do
             reportHeapOverflow
             exit 251
  
        _ -> case fromException se of
             -- only the main thread gets ExitException exceptions
             Just ExitSuccess     -> exit 0
             Just (ExitFailure n) -> exit n
  
             -- EPIPE errors received for stdout are ignored (#2699)
             _ -> catch (case fromException se of
                  Just IOError{ ioe_type = ResourceVanished,
                                ioe_errno = Just ioe,
                                ioe_handle = Just hdl }
                     | Errno ioe == ePIPE, hdl == stdout -> exit 0
                  _ -> do reportError se
                          exit 1
                  ) (disasterHandler exit) -- See Note [Disaster with iconv]
  
  -- don't use errorBelch() directly, because we cannot call varargs functions
  -- using the FFI.
  foreign import ccall unsafe "HsBase.h errorBelch2"
      c_errorBelch :: CString -> CString -> IO ()
  
  errorBelch :: String -> IO ()
  errorBelch msg =
      withCAString "%s" $ \fmt ->
        withCAString msg $ \msg' ->
            c_errorBelch fmt msg'
  
  disasterHandler :: (Int -> IO a) -> IOError -> IO a
  disasterHandler exit _ =
      errorBelch msgStr >> exit 1
    where
      msgStr =
          "encountered an exception while trying to report an exception.\n" ++
          "One possible reason for this is that we failed while trying to " ++
          "encode an error message. Check that your locale is configured " ++
          "properly."
  
  {-
  Note [Disaster with iconv]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
  When using iconv, it's possible for things like iconv_open to fail in
  restricted environments (like an initram or restricted container), but
  when this happens the error raised inevitably calls `peekCString`,
  which depends on the users locale, which depends on using
  `iconv_open`... which causes an infinite loop.
  
  This occurrence is also known as tickets #10298 and #7695. So to work
  around it we just set _another_ error handler and bail directly by
  calling the RTS, without iconv at all.
  -}
  
  
  -- try to flush stdout/stderr.
  flushStdHandles :: IO ()
  flushStdHandles = do
    hFlush stdout `catchException` handleExc
    -- In the event that we fail to flush stderr the default finalizer exception
    -- handler (which prints to stderr) will also likely fail. However, we call it
    -- anyways since the user may have set their own handler.
    hFlush stderr `catchException` handleExc
    where
      -- We dispatch exceptions thrown by hFlush to the same action used to
      -- handle Weak finalizers since this is where "normal" Handles (e.g. not
      -- stderr/stdout) would be flushed.
      --
      -- See Note [Handling exceptions during Handle finalization] in
      -- GHC.Internal.IO.Handle.Internals
      handleExc se = do
        handleFinalizerExc <- getFinalizerExceptionHandler
        -- Swallow any exceptions thrown by the finalizer exception handler
        handleFinalizerExc se `catchException` (\(SomeException _) -> return ())
  
  
  safeExit, fastExit :: Int -> IO a
  safeExit = exitHelper useSafeExit
  fastExit = exitHelper useFastExit
  
  unreachable :: IO a
  unreachable = failIO "If you can read this, shutdownHaskellAndExit did not exit."
  
  exitHelper :: CInt -> Int -> IO a
  #if defined(mingw32_HOST_OS) || defined(javascript_HOST_ARCH)
  exitHelper exitKind r =
    shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable
  #else
  -- On Unix we use an encoding for the ExitCode:
  --      0 -- 255  normal exit code
  --   -127 -- -1   exit by signal
  -- For any invalid encoding we just use a replacement (0xff).
  exitHelper exitKind r
    | r >= 0 && r <= 255
    = shutdownHaskellAndExit   (fromIntegral   r)  exitKind >> unreachable
    | r >= -127 && r <= -1
    = shutdownHaskellAndSignal (fromIntegral (-r)) exitKind >> unreachable
    | otherwise
    = shutdownHaskellAndExit   0xff                exitKind >> unreachable
  
  -- See Note [Lack of signals on wasm32-wasi].
  #if !defined(HAVE_SIGNAL_H)
  shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
  shutdownHaskellAndSignal = shutdownHaskellAndExit
  #else
  foreign import ccall "shutdownHaskellAndSignal"
    shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
  #endif
  #endif
  
  exitInterrupted :: IO a
  exitInterrupted =
  #if defined(mingw32_HOST_OS) || defined(javascript_HOST_ARCH)
    safeExit 252
  #elif !defined(HAVE_SIGNAL_H)
    safeExit 1
  #else
    -- we must exit via the default action for SIGINT, so that the
    -- parent of this process can take appropriate action (see #2301)
    safeExit (-CONST_SIGINT)
  #endif
  
  -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
  -- re-enter Haskell land through finalizers.
  foreign import ccall "Rts.h shutdownHaskellAndExit"
    shutdownHaskellAndExit :: CInt -> CInt -> IO ()
  
  useFastExit, useSafeExit :: CInt
  useFastExit = 1
  useSafeExit = 0
  