X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FTopHandler.lhs;h=7bedcfea5df5b44fce2e6b2cc544dc0a4231a328;hb=41e8fba828acbae1751628af50849f5352b27873;hp=7077073f863f0d4ac4b98740f567369147100462;hpb=16a3c4090efd35dc6e85da48f9ab9711a51cf0e7;p=ghc-base.git diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs index 7077073..7bedcfe 100644 --- a/GHC/TopHandler.lhs +++ b/GHC/TopHandler.lhs @@ -1,5 +1,14 @@ \begin{code} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ForeignFunctionInterface + , MagicHash + , UnboxedTuples + , PatternGuards + #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.TopHandler @@ -24,19 +33,26 @@ module GHC.TopHandler ( #include "HsBaseConfig.h" -import Prelude - -import System.IO import Control.Exception -import Control.Concurrent.MVar +import Data.Maybe +import Data.Dynamic (toDyn) import Foreign import Foreign.C -import GHC.IOBase -import GHC.Exception -import GHC.Prim -import GHC.Conc +import GHC.Base +import GHC.Conc hiding (throwTo) +import GHC.Num +import GHC.Real +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, @@ -50,43 +66,42 @@ runMainIO main = m <- deRefWeak weak_tid case m of Nothing -> return () - Just tid -> throwTo tid (AsyncException UserInterrupt) + Just tid -> throwTo tid (toException UserInterrupt) a <- main cleanUp return a - `catchException` + `catch` topHandler install_interrupt_handler :: IO () -> IO () #ifdef mingw32_HOST_OS -install_interrupt_handler handler = - GHC.ConsoleHandler.installHandler $ +install_interrupt_handler handler = do + _ <- GHC.ConsoleHandler.installHandler $ Catch $ \event -> case event of ControlC -> handler Break -> handler Close -> 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 - 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 @@ -104,7 +119,7 @@ mkWeakThreadId t@(ThreadId t#) = IO $ \s -> -- program. -- runIO :: IO a -> IO a -runIO main = catchException main topHandler +runIO main = catch main topHandler -- | Like 'runIO', but in the event of an exception that causes an exit, -- we don't shut down the system cleanly, we just exit. This is @@ -119,7 +134,7 @@ runIO main = catchException main topHandler -- safeExit. There is a race to shut down between the main and child threads. -- runIOFastExit :: IO a -> IO a -runIOFastExit main = catchException main topHandlerFastExit +runIOFastExit main = catch main topHandlerFastExit -- NB. this is used by the testsuite driver -- | The same as 'runIO', but for non-IO computations. Used for @@ -127,12 +142,12 @@ runIOFastExit main = catchException main topHandlerFastExit -- are used to export Haskell functions with non-IO types. -- runNonIO :: a -> IO a -runNonIO a = catchException (a `seq` return a) topHandler +runNonIO a = catch (a `seq` return a) topHandler -topHandler :: Exception -> IO a -topHandler err = catchException (real_handler safeExit err) topHandler +topHandler :: SomeException -> IO a +topHandler err = catch (real_handler safeExit err) topHandler -topHandlerFastExit :: Exception -> IO a +topHandlerFastExit :: SomeException -> IO a topHandlerFastExit err = catchException (real_handler fastExit err) topHandlerFastExit @@ -140,49 +155,38 @@ topHandlerFastExit err = -- (e.g. evaluating the string passed to 'error' might generate -- another error, etc.) -- -real_handler :: (Int -> IO a) -> Exception -> IO a -real_handler exit exn = +real_handler :: (Int -> IO a) -> SomeException -> IO a +real_handler exit se@(SomeException exn) = cleanUp >> - case exn of - AsyncException StackOverflow -> do + case cast exn of + Just StackOverflow -> do reportStackOverflow exit 2 - AsyncException UserInterrupt -> exitInterrupted - - -- only the main thread gets ExitException exceptions - ExitException ExitSuccess -> exit 0 - ExitException (ExitFailure n) -> exit n - - other -> do - reportError other - exit 1 + Just UserInterrupt -> exitInterrupted + + _ -> case cast exn of + -- only the main thread gets ExitException exceptions + Just ExitSuccess -> exit 0 + Just (ExitFailure n) -> exit n + + -- 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 :: Exception -> 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). cleanUp :: IO () cleanUp = do - hFlush stdout `catchException` \_ -> return () - hFlush stderr `catchException` \_ -> return () - -cleanUpAndExit :: Int -> IO a -cleanUpAndExit r = do cleanUp; safeExit r + hFlush stdout `catchAny` \_ -> return () + hFlush stderr `catchAny` \_ -> return () -- 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.