{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP
, NoImplicitPrelude
, MagicHash
, UnboxedTuples
#-}
{-# OPTIONS_HADDOCK hide #-}
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
runMainIO :: IO a -> IO a
runMainIO main =
do
main_thread_id <- myThreadId
weak_tid <- mkWeakThreadId main_thread_id
install_interrupt_handler $ do
m <- deRefWeak weak_tid
case m of
Nothing -> return ()
Just tid -> throwTo tid (toException UserInterrupt)
main
`catch`
topHandler
install_interrupt_handler :: IO () -> IO ()
#ifdef 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"
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
return ()
foreign import ccall unsafe
stg_sig_install
:: CInt
-> CInt
-> Ptr ()
-> IO CInt
#endif
runIO :: IO a -> IO a
runIO main = catch main topHandler
runIOFastExit :: IO a -> IO a
runIOFastExit main = catch main topHandlerFastExit
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
real_handler :: (Int -> IO a) -> SomeException -> IO a
real_handler exit se = do
flushStdHandles
case fromException se of
Just StackOverflow -> do
reportStackOverflow
exit 2
Just UserInterrupt -> exitInterrupted
_ -> case fromException se of
Just ExitSuccess -> exit 0
Just (ExitFailure n) -> exit n
_ -> 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)
foreign import ccall unsafe "HsBase.h errorBelch2"
errorBelch :: CString -> CString -> IO ()
disasterHandler :: (Int -> IO a) -> IOError -> IO a
disasterHandler exit _ =
withCAString "%s" $ \fmt ->
withCAString msgStr $ \msg ->
errorBelch fmt msg >> exit 1
where
msgStr =
"encountered an exception while trying to report an exception." ++
"One possible reason for this is that we failed while trying to " ++
"encode an error message. Check that your locale is configured " ++
"properly."
flushStdHandles :: IO ()
flushStdHandles = do
hFlush stdout `catchAny` \_ -> return ()
hFlush stderr `catchAny` \_ -> return ()
safeExit, fastExit :: Int -> IO a
safeExit = exitHelper useSafeExit
fastExit = exitHelper useFastExit
unreachable :: IO a
unreachable = fail "If you can read this, shutdownHaskellAndExit did not exit."
exitHelper :: CInt -> Int -> IO a
#ifdef mingw32_HOST_OS
exitHelper exitKind r =
shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable
#else
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
foreign import ccall "shutdownHaskellAndSignal"
shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
#endif
exitInterrupted :: IO a
exitInterrupted =
#ifdef mingw32_HOST_OS
safeExit 252
#else
safeExit (-CONST_SIGINT)
#endif
foreign import ccall "Rts.h shutdownHaskellAndExit"
shutdownHaskellAndExit :: CInt -> CInt -> IO ()
useFastExit, useSafeExit :: CInt
useFastExit = 1
useSafeExit = 0