+-- | '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 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 "rts/Signals.h"
+-- specialised version of System.Posix.Signals.installHandler, which
+-- isn't available here.
+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
+ -- STG_SIG_RST: the second ^C kills us for real, just in case the
+ -- RTS or program is unresponsive.
+ 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