\begin{code}
module GHC.TopHandler (
runMainIO, runIO, runIOFastExit, runNonIO,
topHandler, topHandlerFastExit,
reportStackOverflow, reportError,
) 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.Num
import GHC.Real
import GHC.Handle
import GHC.IOBase
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)
a <- main
cleanUp
return a
`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 "Signals.h"
install_interrupt_handler handler = do
let sig = CONST_SIGINT :: CInt
withSignalHandlerLock $
alloca $ \p_sp -> do
sptr <- newStablePtr handler
poke p_sp sptr
stg_sig_install sig STG_SIG_RST p_sp nullPtr
return ()
withSignalHandlerLock :: IO () -> IO ()
withSignalHandlerLock io
= block $ do
takeMVar signalHandlerLock
catchAny (unblock io) (\e -> do putMVar signalHandlerLock (); throw e)
putMVar signalHandlerLock ()
foreign import ccall unsafe
stg_sig_install
:: CInt
-> CInt
-> Ptr (StablePtr (IO ()))
-> Ptr ()
-> IO CInt
#endif
mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
case mkWeak# t# t (unsafeCoerce# 0#) s of
(# s1, w #) -> (# s1, Weak w #)
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@(SomeException exn) =
cleanUp >>
case cast exn of
Just StackOverflow -> do
reportStackOverflow
exit 2
Just UserInterrupt -> exitInterrupted
_ -> case cast exn of
Just ExitSuccess -> exit 0
Just (ExitFailure n) -> exit n
_ -> do reportError se
exit 1
cleanUp :: IO ()
cleanUp = do
hFlush stdout `catchAny` \_ -> return ()
hFlush stderr `catchAny` \_ -> return ()
safeExit :: Int -> IO a
safeExit r = unsafeCoerce# (shutdownHaskellAndExit $ fromIntegral r)
exitInterrupted :: IO a
exitInterrupted =
#ifdef mingw32_HOST_OS
safeExit 252
#else
unsafeCoerce# (shutdownHaskellAndSignal CONST_SIGINT)
foreign import ccall "shutdownHaskellAndSignal"
shutdownHaskellAndSignal :: CInt -> IO ()
#endif
foreign import ccall "Rts.h shutdownHaskellAndExit"
shutdownHaskellAndExit :: CInt -> IO ()
fastExit :: Int -> IO a
fastExit r = unsafeCoerce# (stg_exit (fromIntegral r))
foreign import ccall "Rts.h stg_exit"
stg_exit :: CInt -> IO ()
\end{code}