{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , MagicHash
           , UnboxedTuples
           , 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.FD
import GHC.IO.Handle
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 :: IO a -> IO a
runMainIO main :: 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 w :: 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
               Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Just tid :: 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 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 :: IO a -> IO a
runIO main :: 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 :: IO a -> IO a
runIOFastExit main :: 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 :: a -> IO a
runNonIO a :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
a) SomeException -> IO a
forall a. SomeException -> IO a
topHandler

topHandler :: SomeException -> IO a
topHandler :: SomeException -> IO a
topHandler err :: 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 :: SomeException -> IO a
topHandlerFastExit err :: 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 :: (Int -> IO a) -> SomeException -> IO a
real_handler exit :: Int -> IO a
exit se :: 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 StackOverflow -> do
           IO ()
reportStackOverflow
           Int -> IO a
exit 2

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

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

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

           -- EPIPE errors received for stdout are ignored (#2699)
           _ -> 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 ioe :: CInt
ioe,
                              ioe_handle :: IOError -> Maybe Handle
ioe_handle = Just hdl :: 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 0
                _ -> do SomeException -> IO ()
reportError SomeException
se
                        Int -> IO a
exit 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 :: (Int -> IO a) -> IOError -> IO a
disasterHandler exit :: Int -> IO a
exit _ =
  String -> (CString -> IO a) -> IO a
forall a. String -> (CString -> IO a) -> IO a
withCAString "%s" ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \fmt :: 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
$ \msg :: 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 1
  where
    msgStr :: String
msgStr =
        "encountered an exception while trying to report an exception.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "One possible reason for this is that we failed while trying to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "encode an error message. Check that your locale is configured " String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "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` \_ -> () -> 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` \_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

unreachable :: IO a
unreachable :: IO a
unreachable = String -> IO a
forall a. String -> IO a
failIO "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 :: CInt -> Int -> IO a
exitHelper exitKind :: CInt
exitKind r :: Int
r
  | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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
>= -127 Bool -> Bool -> Bool
&& Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= -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   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 :: 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 = 1
useSafeExit :: CInt
useSafeExit = 0