\begin{code}
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
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.Err
import GHC.Num
import GHC.Real
-import GHC.Handle
-import GHC.IOBase
+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,
install_interrupt_handler :: IO () -> IO ()
#ifdef mingw32_HOST_OS
install_interrupt_handler handler = do
- GHC.ConsoleHandler.installHandler $
+ _ <- GHC.ConsoleHandler.installHandler $
Catch $ \event ->
case event of
ControlC -> handler
_ -> return ()
return ()
#else
-#include "Signals.h"
+#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
- 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 ()
+ _ <- 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 (StablePtr (IO ())) -- (in, out) Haskell handler
-> Ptr () -- (in, out) blocked
- -> IO CInt -- (ret) action code
+ -> IO CInt -- (ret) old action code
#endif
-- make a weak pointer to a ThreadId: holding the weak pointer doesn't
Just ExitSuccess -> exit 0
Just (ExitFailure n) -> exit n
- _ -> do reportError se
- exit 1
+ -- EPIPE errors received for stdout are ignored (#2699)
+ _ -> case cast exn 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
-- try to flush stdout/stderr, but don't worry if we fail
hFlush stdout `catchAny` \_ -> return ()
hFlush stderr `catchAny` \_ -> return ()
-cleanUpAndExit :: Int -> IO a
-cleanUpAndExit r = do cleanUp; safeExit r
-
-- we have to use unsafeCoerce# to get the 'IO a' result type, since the
-- compiler doesn't let us declare that as the result type of a foreign export.
safeExit :: Int -> IO a