add GHC.HetMet.{hetmet_kappa,hetmet_kappa_app}

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

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 236f5ff..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,19 +35,24 @@ module GHC.TopHandler (
 
 import Control.Exception
 import Data.Maybe
-import Control.Concurrent.MVar
+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 {-# SOURCE #-} 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,
@@ -63,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
@@ -72,25 +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
-   withMVar signalHandlerLock $ \_ ->
-     alloca $ \p_sp -> do
-       sptr <- newStablePtr handler
-       poke p_sp sptr
-       stg_sig_install sig STG_SIG_RST p_sp nullPtr
-       return ()
+   _ <- 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
@@ -159,24 +170,16 @@ 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
            
 
-reportStackOverflow :: IO a
-reportStackOverflow = do callStackOverflowHook; return undefined
-
-reportError :: SomeException -> IO a
-reportError ex = do
-   handler <- getUncaughtExceptionHandler
-   handler ex
-   return undefined
-
--- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
--- the unsafe below.
-foreign import ccall unsafe "stackOverflow"
-        callStackOverflowHook :: IO ()
-
 -- try to flush stdout/stderr, but don't worry if we fail
 -- (these handles might have errors, and we don't want to go into
 -- an infinite loop).
@@ -185,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