X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FTopHandler.lhs;h=0f55b38ba3b22c0c7edf1324c850f09c8955889f;hb=566d4ea2e4434bf0bedfaa518c31bca42959855d;hp=98ce59b186840feabae8ebb9b89fa6a5bc3bd5c4;hpb=3e803c9d9cf0602b60313b768beec847ee12a69c;p=ghc-base.git

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 98ce59b..0f55b38 100644
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -1,5 +1,6 @@
 \begin{code}
 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
@@ -27,6 +28,7 @@ module GHC.TopHandler (
 
 import Control.Exception
 import Data.Maybe
+import Data.Dynamic (toDyn)
 
 import Foreign
 import Foreign.C
@@ -34,10 +36,16 @@ import GHC.Base
 import GHC.Conc hiding (throwTo)
 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,
@@ -61,7 +69,7 @@ runMainIO main =
 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
@@ -70,32 +78,23 @@ install_interrupt_handler handler = do
            _ -> 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
@@ -164,8 +163,14 @@ real_handler exit se@(SomeException exn) =
            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
@@ -176,9 +181,6 @@ cleanUp = do
   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