GHC/TopHandler.lhs

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