+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 "Signals.h"
+-- specialised version of System.Posix.Signals.installHandler, which
+-- isn't available here.
+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 -- sig no.
+ -> CInt -- action code (STG_SIG_HAN etc.)
+ -> Ptr (StablePtr (IO ())) -- (in, out) Haskell handler
+ -> Ptr () -- (in, out) blocked
+ -> IO CInt -- (ret) action code
+#endif