    {-# LANGUAGE CPP #-}
    {-# LANGUAGE MagicHash #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE UnliftedFFITypes #-}

    {-# OPTIONS_HADDOCK not-home #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  GHC.TopHandler
    -- Copyright   :  (c) The University of Glasgow, 2001-2002
    -- License     :  see libraries/base/LICENSE
    --
    -- Maintainer  :  cvs-ghc@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)
    --
    -----------------------------------------------------------------------------

    module GHC.TopHandler (
            runMainIO, runIO, runIOFastExit, runNonIO,
            topHandler, topHandlerFastExit,
            reportStackOverflow, reportError,
            flushStdHandles
        ) where

    #include "HsBaseConfig.h"

    import Control.Exception
    import Data.Maybe

    import Foreign
    import Foreign.C
    import GHC.Base
    import GHC.Conc hiding (throwTo)
    import GHC.Real
    import GHC.IO
    import GHC.IO.Handle
    import GHC.IO.StdHandles
    import GHC.IO.Exception
    import GHC.Weak

    #if defined(mingw32_HOST_OS)
    import GHC.ConsoleHandler
    #else
    import 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 :: forall a. IO a -> IO a
    runMainIO IO a
    main =
        do
          ThreadId
    main_thread_id <- IO ThreadId
    myThreadId
          Weak ThreadId
    weak_tid <- ThreadId -> IO (Weak ThreadId)
    mkWeakThreadId ThreadId
    main_thread_id
          case Weak ThreadId
    weak_tid of (Weak Weak# ThreadId
    w) -> Weak# ThreadId -> IO ()
    setMainThread Weak# ThreadId
    w
          IO () -> IO ()
    install_interrupt_handler (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
               Maybe ThreadId
    m <- Weak ThreadId -> IO (Maybe ThreadId)
    forall v. Weak v -> IO (Maybe v)
    deRefWeak Weak ThreadId
    weak_tid
               case Maybe ThreadId
    m of
                   Maybe ThreadId
    Nothing  -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                   Just ThreadId
    tid -> ThreadId -> SomeException -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    tid (AsyncException -> SomeException
    forall e. Exception e => e -> SomeException
    toException AsyncException
    UserInterrupt)
          IO a
    main -- hs_exit() will flush
        IO a -> (SomeException -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    `catch`
          SomeException -> IO a
    forall a. SomeException -> IO a
    topHandler

    install_interrupt_handler :: IO () -> IO ()
    #if 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 ()
    #else
    #include "rts/Signals.h"
    -- specialised version of System.Posix.Signals.installHandler, which
    -- isn't available here.
    install_interrupt_handler :: IO () -> IO ()
    install_interrupt_handler IO ()
    handler = do
       let sig :: CInt
    sig = CONST_SIGINT :: CInt
       Maybe (HandlerFun, Dynamic)
    _ <- CInt
    -> Maybe (HandlerFun, Dynamic) -> IO (Maybe (HandlerFun, Dynamic))
    setHandler CInt
    sig ((HandlerFun, Dynamic) -> Maybe (HandlerFun, Dynamic)
    forall a. a -> Maybe a
    Just (IO () -> HandlerFun
    forall a b. a -> b -> a
    const IO ()
    handler, IO () -> Dynamic
    forall a. Typeable a => a -> Dynamic
    toDyn IO ()
    handler))
       CInt
    _ <- CInt -> CInt -> Ptr () -> IO CInt
    stg_sig_install CInt
    sig STG_SIG_RST nullPtr
         -- STG_SIG_RST: the second ^C kills us for real, just in case the
         -- RTS or program is unresponsive.
       () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    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 '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 :: forall a. IO a -> IO a
    runIO IO a
    main = IO a -> (SomeException -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch IO a
    main SomeException -> IO a
    forall a. SomeException -> IO a
    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 :: forall a. IO a -> IO a
    runIOFastExit IO a
    main = IO a -> (SomeException -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch IO a
    main SomeException -> IO a
    forall a. SomeException -> IO a
    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 :: forall a. a -> IO a
    runNonIO a
    a = IO a -> (SomeException -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch (a
    a a -> IO a -> IO a
    `seq` a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    a) SomeException -> IO a
    forall a. SomeException -> IO a
    topHandler

    topHandler :: SomeException -> IO a
    topHandler :: forall a. SomeException -> IO a
    topHandler SomeException
    err = IO a -> (SomeException -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch ((Int -> IO a) -> SomeException -> IO a
    forall a. (Int -> IO a) -> SomeException -> IO a
    real_handler Int -> IO a
    forall a. Int -> IO a
    safeExit SomeException
    err) SomeException -> IO a
    forall a. SomeException -> IO a
    topHandler

    topHandlerFastExit :: SomeException -> IO a
    topHandlerFastExit :: forall a. SomeException -> IO a
    topHandlerFastExit SomeException
    err =
      IO a -> (SomeException -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catchException ((Int -> IO a) -> SomeException -> IO a
    forall a. (Int -> IO a) -> SomeException -> IO a
    real_handler Int -> IO a
    forall a. Int -> IO a
    fastExit SomeException
    err) SomeException -> IO a
    forall a. SomeException -> IO a
    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 :: forall a. (Int -> IO a) -> SomeException -> IO a
    real_handler Int -> IO a
    exit SomeException
    se = do
      IO ()
    flushStdHandles -- before any error output
      case SomeException -> Maybe AsyncException
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    se of
          Just AsyncException
    StackOverflow -> do
               IO ()
    reportStackOverflow
               Int -> IO a
    exit Int
    2

          Just AsyncException
    UserInterrupt -> IO a
    forall a. IO a
    exitInterrupted

          Just AsyncException
    HeapOverflow -> do
               IO ()
    reportHeapOverflow
               Int -> IO a
    exit Int
    251

          Maybe AsyncException
    _ -> case SomeException -> Maybe ExitCode
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    se of
               -- only the main thread gets ExitException exceptions
               Just ExitCode
    ExitSuccess     -> Int -> IO a
    exit Int
    0
               Just (ExitFailure Int
    n) -> Int -> IO a
    exit Int
    n

               -- EPIPE errors received for stdout are ignored (#2699)
               Maybe ExitCode
    _ -> IO a -> (IOError -> IO a) -> IO a
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch (case SomeException -> Maybe IOError
    forall e. Exception e => SomeException -> Maybe e
    fromException SomeException
    se of
                    Just IOError{ ioe_type :: IOError -> IOErrorType
    ioe_type = IOErrorType
    ResourceVanished,
                                  ioe_errno :: IOError -> Maybe CInt
    ioe_errno = Just CInt
    ioe,
                                  ioe_handle :: IOError -> Maybe Handle
    ioe_handle = Just Handle
    hdl }
                       | CInt -> Errno
    Errno CInt
    ioe Errno -> Errno -> Bool
    forall a. Eq a => a -> a -> Bool
    == Errno
    ePIPE, Handle
    hdl Handle -> Handle -> Bool
    forall a. Eq a => a -> a -> Bool
    == Handle
    stdout -> Int -> IO a
    exit Int
    0
                    Maybe IOError
    _ -> do SomeException -> IO ()
    reportError SomeException
    se
                            Int -> IO a
    exit Int
    1
                    ) ((Int -> IO a) -> IOError -> IO a
    forall a. (Int -> IO a) -> IOError -> IO a
    disasterHandler Int -> IO a
    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"
       errorBelch :: CString -> CString -> IO ()

    disasterHandler :: (Int -> IO a) -> IOError -> IO a
    disasterHandler :: forall a. (Int -> IO a) -> IOError -> IO a
    disasterHandler Int -> IO a
    exit IOError
    _ =
      String -> (CString -> IO a) -> IO a
    forall a. String -> (CString -> IO a) -> IO a
    withCAString String
    "%s" ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \CString
    fmt ->
        String -> (CString -> IO a) -> IO a
    forall a. String -> (CString -> IO a) -> IO a
    withCAString String
    msgStr ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a
    forall a b. (a -> b) -> a -> b
    $ \CString
    msg ->
          CString -> CString -> IO ()
    errorBelch CString
    fmt CString
    msg IO () -> IO a -> IO a
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Int -> IO a
    exit Int
    1
      where
        msgStr :: String
    msgStr =
            String
    "encountered an exception while trying to report an exception.\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
            String
    "One possible reason for this is that we failed while trying to " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
            String
    "encode an error message. Check that your locale is configured " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
            String
    "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, but don't worry if we fail
    -- (these handles might have errors, and we don't want to go into
    -- an infinite loop).
    flushStdHandles :: IO ()
    flushStdHandles :: IO ()
    flushStdHandles = do
      Handle -> IO ()
    hFlush Handle
    stdout IO () -> (forall e. Exception e => e -> IO ()) -> IO ()
    forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
    `catchAny` \e
    _ -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      Handle -> IO ()
    hFlush Handle
    stderr IO () -> (forall e. Exception e => e -> IO ()) -> IO ()
    forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
    `catchAny` \e
    _ -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    safeExit, fastExit :: Int -> IO a
    safeExit :: forall a. Int -> IO a
    safeExit = CInt -> Int -> IO a
    forall a. CInt -> Int -> IO a
    exitHelper CInt
    useSafeExit
    fastExit :: forall a. Int -> IO a
    fastExit = CInt -> Int -> IO a
    forall a. CInt -> Int -> IO a
    exitHelper CInt
    useFastExit

    unreachable :: IO a
    unreachable :: forall a. IO a
    unreachable = String -> IO a
    forall a. String -> IO a
    failIO String
    "If you can read this, shutdownHaskellAndExit did not exit."

    exitHelper :: CInt -> Int -> IO a
    #if defined(mingw32_HOST_OS)
    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 :: forall a. CInt -> Int -> IO a
    exitHelper CInt
    exitKind Int
    r
      | Int
    r Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Int
    0 Bool -> Bool -> Bool
    && Int
    r Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    255
      = CInt -> CInt -> IO ()
    shutdownHaskellAndExit   (Int -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral   Int
    r)  CInt
    exitKind IO () -> IO a -> IO a
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO a
    forall a. IO a
    unreachable
      | Int
    r Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= -Int
    127 Bool -> Bool -> Bool
    && Int
    r Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= -Int
    1
      = CInt -> CInt -> IO ()
    shutdownHaskellAndSignal (Int -> CInt
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (-Int
    r)) CInt
    exitKind IO () -> IO a -> IO a
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO a
    forall a. IO a
    unreachable
      | Bool
    otherwise
      = CInt -> CInt -> IO ()
    shutdownHaskellAndExit   CInt
    0xff                CInt
    exitKind IO () -> IO a -> IO a
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO a
    forall a. IO a
    unreachable

    foreign import ccall "shutdownHaskellAndSignal"
      shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
    #endif

    exitInterrupted :: IO a
    exitInterrupted :: forall a. IO a
    exitInterrupted =
    #if defined(mingw32_HOST_OS)
      safeExit 252
    #else
      -- we must exit via the default action for SIGINT, so that the
      -- parent of this process can take appropriate action (see #2301)
      Int -> IO a
    forall a. Int -> IO a
    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 :: CInt
    useFastExit = CInt
    1
    useSafeExit :: CInt
    useSafeExit = CInt
    0