Add tests from testsuite/tests/h98

[ghc-base.git] / GHC / TopHandler.lhs

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index b5a7411..7bedcfe 100644 (file)
--- 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