+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' 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
+
+-- make a weak pointer to a ThreadId: holding the weak pointer doesn't
+-- keep the thread alive and prevent it from being identified as
+-- deadlocked. Vitally important for the main thread.
+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' 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.