\begin{code}
module GHC.TopHandler (
runMainIO, runIO, runIOFastExit, runNonIO,
topHandler, topHandlerFastExit,
reportStackOverflow, reportError,
flushStdHandles
) where
#include "HsBaseConfig.h"
import Control.Exception
import Data.Maybe
import Data.Dynamic (toDyn)
import Foreign
import Foreign.C
import GHC.Base
import GHC.Conc hiding (throwTo)
import GHC.Num
import GHC.Real
import GHC.MVar
import GHC.IO
import GHC.IO.Handle.FD
import GHC.IO.Handle
import GHC.IO.Exception
import GHC.Weak
import Data.Typeable
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
#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
_ -> 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
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
\end{code}