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