{-# 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 :: forall a. IO a -> IO a
runMainIO IO a
main =
    do
      main_thread_id <- IO ThreadId
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 Weak# ThreadId
w) -> Weak# ThreadId -> IO ()
setMainThread Weak# ThreadId
w
      install_interrupt_handler $ do
           m <- deRefWeak weak_tid
           case m of
               Maybe ThreadId
Nothing  -> () -> IO ()
forall a. a -> IO a
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)
      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(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 :: IO () -> IO ()
install_interrupt_handler IO ()
handler = do
   let sig :: CInt
sig = CONST_SIGINT :: CInt
   _ <- 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))
   _ <- 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 :: 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
forall a b. a -> b -> b
`seq` a -> IO a
forall a. 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"
    c_errorBelch :: CString -> CString -> IO ()

errorBelch :: String -> IO ()
errorBelch :: String -> IO ()
errorBelch String
msg =
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCAString String
"%s" ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
fmt ->
      String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCAString String
msg ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
msg' ->
          CString -> CString -> IO ()
c_errorBelch CString
fmt CString
msg'

disasterHandler :: (Int -> IO a) -> IOError -> IO a
disasterHandler :: forall a. (Int -> IO a) -> IOError -> IO a
disasterHandler Int -> IO a
exit IOError
_ =
    String -> IO ()
errorBelch String
msgStr IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
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.
flushStdHandles :: IO ()
flushStdHandles :: IO ()
flushStdHandles = do
  Handle -> IO ()
hFlush Handle
stdout IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` SomeException -> IO ()
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.
  Handle -> IO ()
hFlush Handle
stderr IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catchException` SomeException -> IO ()
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 :: SomeException -> IO ()
handleExc SomeException
se = do
      handleFinalizerExc <- IO (SomeException -> IO ())
getFinalizerExceptionHandler
      -- Swallow any exceptions thrown by the finalizer exception handler
      handleFinalizerExc se `catchException` (\(SomeException e
_) -> () -> IO ()
forall a. a -> IO a
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) || 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 :: 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 a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
forall a. IO a
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 :: forall a. 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)
  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