{-# 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 forall a b. (a -> b) -> a -> b
$ do
           Maybe ThreadId
m <- forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
weak_tid
           case Maybe ThreadId
m of
               Maybe ThreadId
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Just ThreadId
tid -> forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (forall e. Exception e => e -> SomeException
toException AsyncException
UserInterrupt)
      IO a
main -- hs_exit() will flush
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
      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 (forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const IO ()
handler, 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.
   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 = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
main 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 = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
main 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 = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a
a seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return a
a) forall a. SomeException -> IO a
topHandler

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

topHandlerFastExit :: SomeException -> IO a
topHandlerFastExit :: forall a. SomeException -> IO a
topHandlerFastExit SomeException
err =
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catchException (forall a. (Int -> IO a) -> SomeException -> IO a
real_handler forall a. Int -> IO a
fastExit SomeException
err) 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 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 -> forall a. IO a
exitInterrupted

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

      Maybe AsyncException
_ -> case 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
_ -> forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (case 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 forall a. Eq a => a -> a -> Bool
== Errno
ePIPE, Handle
hdl 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
                ) (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
_ =
  forall a. String -> (CString -> IO a) -> IO a
withCAString String
"%s" forall a b. (a -> b) -> a -> b
$ \CString
fmt ->
    forall a. String -> (CString -> IO a) -> IO a
withCAString String
msgStr forall a b. (a -> b) -> a -> b
$ \CString
msg ->
      CString -> CString -> IO ()
errorBelch CString
fmt CString
msg 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" forall a. [a] -> [a] -> [a]
++
        String
"One possible reason for this is that we failed while trying to " forall a. [a] -> [a] -> [a]
++
        String
"encode an error message. Check that your locale is configured " 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 forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
`catchAny` \e
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Handle -> IO ()
hFlush Handle
stderr forall a. IO a -> (forall e. Exception e => e -> IO a) -> IO a
`catchAny` \e
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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