GHC/TopHandler.lhs

   1 \begin{code}
   2 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
   3 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
   4 {-# OPTIONS_HADDOCK hide #-}
   5 -----------------------------------------------------------------------------
   6 -- |
   7 -- Module      :  GHC.TopHandler
   8 -- Copyright   :  (c) The University of Glasgow, 2001-2002
   9 -- License     :  see libraries/base/LICENSE
  10 --
  11 -- Maintainer  :  cvs-ghc@haskell.org
  12 -- Stability   :  internal
  13 -- Portability :  non-portable (GHC Extensions)
  14 --
  15 -- Support for catching exceptions raised during top-level computations
  16 -- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)
  17 --
  18 -----------------------------------------------------------------------------
  19
  20 -- #hide
  21 module GHC.TopHandler (
  22    runMainIO, runIO, runIOFastExit, runNonIO,
  23    topHandler, topHandlerFastExit,
  24    reportStackOverflow, reportError,
  25   ) where
  26
  27 #include "HsBaseConfig.h"
  28
  29 import Control.Exception
  30 import Data.Maybe
  31 import Data.Dynamic (toDyn)
  32
  33 import Foreign
  34 import Foreign.C
  35 import GHC.Base
  36 import GHC.Conc hiding (throwTo)
  37 import GHC.Num
  38 import GHC.Real
  39 import GHC.MVar
  40 import GHC.IO
  41 import GHC.IO.Handle.FD
  42 import GHC.IO.Handle
  43 import GHC.IO.Exception
  44 import GHC.Weak
  45 import Data.Typeable
  46 #if defined(mingw32_HOST_OS)
  47 import GHC.ConsoleHandler
  48 #endif
  49
  50 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
  51 -- called in the program).  It catches otherwise uncaught exceptions,
  52 -- and also flushes stdout\/stderr before exiting.
  53 runMainIO :: IO a -> IO a
  54 runMainIO main =
  55     do
  56       main_thread_id <- myThreadId
  57       weak_tid <- mkWeakThreadId main_thread_id
  58       install_interrupt_handler $ do
  59            m <- deRefWeak weak_tid
  60            case m of
  61                Nothing  -> return ()
  62                Just tid -> throwTo tid (toException UserInterrupt)
  63       a <- main
  64       cleanUp
  65       return a
  66     `catch`
  67       topHandler
  68
  69 install_interrupt_handler :: IO () -> IO ()
  70 #ifdef mingw32_HOST_OS
  71 install_interrupt_handler handler = do
  72   _ <- GHC.ConsoleHandler.installHandler $
  73      Catch $ \event ->
  74         case event of
  75            ControlC -> handler
  76            Break    -> handler
  77            Close    -> handler
  78            _ -> return ()
  79   return ()
  80 #else
  81 #include "rts/Signals.h"
  82 -- specialised version of System.Posix.Signals.installHandler, which
  83 -- isn't available here.
  84 install_interrupt_handler handler = do
  85    let sig = CONST_SIGINT :: CInt
  86    _ <- setHandler sig (Just (const handler, toDyn handler))
  87    _ <- stg_sig_install sig STG_SIG_RST nullPtr
  88      -- STG_SIG_RST: the second ^C kills us for real, just in case the
  89      -- RTS or program is unresponsive.
  90    return ()
  91
  92 foreign import ccall unsafe
  93   stg_sig_install
  94         :: CInt                         -- sig no.
  95         -> CInt                         -- action code (STG_SIG_HAN etc.)
  96         -> Ptr ()                       -- (in, out) blocked
  97         -> IO CInt                      -- (ret) old action code
  98 #endif
  99
 100 -- make a weak pointer to a ThreadId: holding the weak pointer doesn't
 101 -- keep the thread alive and prevent it from being identified as
 102 -- deadlocked.  Vitally important for the main thread.
 103 mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
 104 mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
 105    case mkWeak# t# t (unsafeCoerce# 0#) s of
 106       (# s1, w #) -> (# s1, Weak w #)
 107
 108 -- | 'runIO' is wrapped around every @foreign export@ and @foreign
 109 -- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the
 110 -- result of running 'System.Exit.exitWith' in a foreign-exported
 111 -- function is the same as in the main thread: it terminates the
 112 -- program.
 113 --
 114 runIO :: IO a -> IO a
 115 runIO main = catch main topHandler
 116
 117 -- | Like 'runIO', but in the event of an exception that causes an exit,
 118 -- we don't shut down the system cleanly, we just exit.  This is
 119 -- useful in some cases, because the safe exit version will give other
 120 -- threads a chance to clean up first, which might shut down the
 121 -- system in a different way.  For example, try
 122 --
 123 --   main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
 124 --
 125 -- This will sometimes exit with "interrupted" and code 0, because the
 126 -- main thread is given a chance to shut down when the child thread calls
 127 -- safeExit.  There is a race to shut down between the main and child threads.
 128 --
 129 runIOFastExit :: IO a -> IO a
 130 runIOFastExit main = catch main topHandlerFastExit
 131         -- NB. this is used by the testsuite driver
 132
 133 -- | The same as 'runIO', but for non-IO computations.  Used for
 134 -- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
 135 -- are used to export Haskell functions with non-IO types.
 136 --
 137 runNonIO :: a -> IO a
 138 runNonIO a = catch (a `seq` return a) topHandler
 139
 140 topHandler :: SomeException -> IO a
 141 topHandler err = catch (real_handler safeExit err) topHandler
 142
 143 topHandlerFastExit :: SomeException -> IO a
 144 topHandlerFastExit err =
 145   catchException (real_handler fastExit err) topHandlerFastExit
 146
 147 -- Make sure we handle errors while reporting the error!
 148 -- (e.g. evaluating the string passed to 'error' might generate
 149 --  another error, etc.)
 150 --
 151 real_handler :: (Int -> IO a) -> SomeException -> IO a
 152 real_handler exit se@(SomeException exn) =
 153   cleanUp >>
 154   case cast exn of
 155       Just StackOverflow -> do
 156            reportStackOverflow
 157            exit 2
 158
 159       Just UserInterrupt  -> exitInterrupted
 160
 161       _ -> case cast exn of
 162            -- only the main thread gets ExitException exceptions
 163            Just ExitSuccess     -> exit 0
 164            Just (ExitFailure n) -> exit n
 165
 166            -- EPIPE errors received for stdout are ignored (#2699)
 167            _ -> case cast exn of
 168                 Just IOError{ ioe_type = ResourceVanished,
 169                               ioe_errno = Just ioe,
 170                               ioe_handle = Just hdl }
 171                    | Errno ioe == ePIPE, hdl == stdout -> exit 0
 172                 _ -> do reportError se
 173                         exit 1
 174
 175
 176 -- try to flush stdout/stderr, but don't worry if we fail
 177 -- (these handles might have errors, and we don't want to go into
 178 -- an infinite loop).
 179 cleanUp :: IO ()
 180 cleanUp = do
 181   hFlush stdout `catchAny` \_ -> return ()
 182   hFlush stderr `catchAny` \_ -> return ()
 183
 184 -- we have to use unsafeCoerce# to get the 'IO a' result type, since the
 185 -- compiler doesn't let us declare that as the result type of a foreign export.
 186 safeExit :: Int -> IO a
 187 safeExit r = unsafeCoerce# (shutdownHaskellAndExit $ fromIntegral r)
 188
 189 exitInterrupted :: IO a
 190 exitInterrupted =
 191 #ifdef mingw32_HOST_OS
 192   safeExit 252
 193 #else
 194   -- we must exit via the default action for SIGINT, so that the
 195   -- parent of this process can take appropriate action (see #2301)
 196   unsafeCoerce# (shutdownHaskellAndSignal CONST_SIGINT)
 197
 198 foreign import ccall "shutdownHaskellAndSignal"
 199   shutdownHaskellAndSignal :: CInt -> IO ()
 200 #endif
 201
 202 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
 203 -- re-enter Haskell land through finalizers.
 204 foreign import ccall "Rts.h shutdownHaskellAndExit"
 205   shutdownHaskellAndExit :: CInt -> IO ()
 206
 207 fastExit :: Int -> IO a
 208 fastExit r = unsafeCoerce# (stg_exit (fromIntegral r))
 209
 210 foreign import ccall "Rts.h stg_exit"
 211   stg_exit :: CInt -> IO ()
 212 \end{code}