GHC/TopHandler.lhs

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