\begin{code}
+{-# LANGUAGE CPP
+ , NoImplicitPrelude
+ , ForeignFunctionInterface
+ , MagicHash
+ , UnboxedTuples
+ , PatternGuards
+ #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_HADDOCK hide #-}
+
-----------------------------------------------------------------------------
-- |
-- 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
-#ifdef mingw32_HOST_OS
+import Data.Typeable
+#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
#endif
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 = do
- GHC.ConsoleHandler.installHandler $
+ _ <- GHC.ConsoleHandler.installHandler $
Catch $ \event ->
case event of
ControlC -> 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
-- 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
-- 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
-- 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
-- (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.
projects / ghc-base.git / blobdiff