X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FTopHandler.lhs;h=7bedcfea5df5b44fce2e6b2cc544dc0a4231a328;hb=a223a71a0d40523d2fb3a6b84b5da37d9fc719b8;hp=422b8b0d35934628cacb6385b8f48d066f642356;hpb=7069b9af8594c6f4f199e71224547d39077acb38;p=ghc-base.git

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 422b8b0..7bedcfe 100644
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -1,6 +1,14 @@
 \begin{code}
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , ForeignFunctionInterface
+           , MagicHash
+           , UnboxedTuples
+           , PatternGuards
+  #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.TopHandler
@@ -27,6 +35,7 @@ module GHC.TopHandler (
 
 import Control.Exception
 import Data.Maybe
+import Data.Dynamic (toDyn)
 
 import Foreign
 import Foreign.C
@@ -34,8 +43,11 @@ 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)
@@ -64,7 +76,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
@@ -73,32 +85,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
@@ -167,8 +170,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
@@ -179,9 +188,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