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.Exception
  37 import GHC.Prim
  38 import GHC.Conc
  39 import GHC.Weak
  40 #ifdef mingw32_HOST_OS
  41 import GHC.ConsoleHandler
  42 #endif
  43
  44 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
  45 -- called in the program).  It catches otherwise uncaught exceptions,
  46 -- and also flushes stdout\/stderr before exiting.
  47 runMainIO :: IO a -> IO a
  48 runMainIO main =
  49     do
  50       main_thread_id <- myThreadId
  51       weak_tid <- mkWeakThreadId main_thread_id
  52       install_interrupt_handler $ do
  53            m <- deRefWeak weak_tid
  54            case m of
  55                Nothing  -> return ()
  56                Just tid -> throwTo tid (AsyncException UserInterrupt)
  57       a <- main
  58       cleanUp
  59       return a
  60     `catchException`
  61       topHandler
  62
  63 install_interrupt_handler :: IO () -> IO ()
  64 #ifdef mingw32_HOST_OS
  65 install_interrupt_handler handler = do
  66   GHC.ConsoleHandler.installHandler $
  67      Catch $ \event ->
  68         case event of
  69            ControlC -> handler
  70            Break    -> handler
  71            Close    -> handler
  72            _ -> return ()
  73   return ()
  74 #else
  75 #include "Signals.h"
  76 -- specialised version of System.Posix.Signals.installHandler, which
  77 -- isn't available here.
  78 install_interrupt_handler handler = do
  79    let sig = CONST_SIGINT :: CInt
  80    withMVar signalHandlerLock $ \_ ->
  81      alloca $ \p_sp -> do
  82        sptr <- newStablePtr handler
  83        poke p_sp sptr
  84        stg_sig_install sig STG_SIG_RST p_sp nullPtr
  85        return ()
  86
  87 foreign import ccall unsafe
  88   stg_sig_install
  89         :: CInt                         -- sig no.
  90         -> CInt                         -- action code (STG_SIG_HAN etc.)
  91         -> Ptr (StablePtr (IO ()))      -- (in, out) Haskell handler
  92         -> Ptr ()                       -- (in, out) blocked
  93         -> IO CInt                      -- (ret) action code
  94 #endif
  95
  96 -- make a weak pointer to a ThreadId: holding the weak pointer doesn't
  97 -- keep the thread alive and prevent it from being identified as
  98 -- deadlocked.  Vitally important for the main thread.
  99 mkWeakThreadId :: ThreadId -> IO (Weak ThreadId)
 100 mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
 101    case mkWeak# t# t (unsafeCoerce# 0#) s of
 102       (# s1, w #) -> (# s1, Weak w #)
 103
 104 -- | 'runIO' is wrapped around every @foreign export@ and @foreign
 105 -- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the
 106 -- result of running 'System.Exit.exitWith' in a foreign-exported
 107 -- function is the same as in the main thread: it terminates the
 108 -- program.
 109 --
 110 runIO :: IO a -> IO a
 111 runIO main = catchException main topHandler
 112
 113 -- | Like 'runIO', but in the event of an exception that causes an exit,
 114 -- we don't shut down the system cleanly, we just exit.  This is
 115 -- useful in some cases, because the safe exit version will give other
 116 -- threads a chance to clean up first, which might shut down the
 117 -- system in a different way.  For example, try
 118 --
 119 --   main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
 120 --
 121 -- This will sometimes exit with "interrupted" and code 0, because the
 122 -- main thread is given a chance to shut down when the child thread calls
 123 -- safeExit.  There is a race to shut down between the main and child threads.
 124 --
 125 runIOFastExit :: IO a -> IO a
 126 runIOFastExit main = catchException main topHandlerFastExit
 127         -- NB. this is used by the testsuite driver
 128
 129 -- | The same as 'runIO', but for non-IO computations.  Used for
 130 -- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
 131 -- are used to export Haskell functions with non-IO types.
 132 --
 133 runNonIO :: a -> IO a
 134 runNonIO a = catchException (a `seq` return a) topHandler
 135
 136 topHandler :: Exception -> IO a
 137 topHandler err = catchException (real_handler safeExit err) topHandler
 138
 139 topHandlerFastExit :: Exception -> IO a
 140 topHandlerFastExit err =
 141   catchException (real_handler fastExit err) topHandlerFastExit
 142
 143 -- Make sure we handle errors while reporting the error!
 144 -- (e.g. evaluating the string passed to 'error' might generate
 145 --  another error, etc.)
 146 --
 147 real_handler :: (Int -> IO a) -> Exception -> IO a
 148 real_handler exit exn =
 149   cleanUp >>
 150   case exn of
 151         AsyncException StackOverflow -> do
 152            reportStackOverflow
 153            exit 2
 154
 155         AsyncException UserInterrupt  -> exitInterrupted
 156
 157         -- only the main thread gets ExitException exceptions
 158         ExitException ExitSuccess     -> exit 0
 159         ExitException (ExitFailure n) -> exit n
 160
 161         other -> do
 162            reportError other
 163            exit 1
 164
 165
 166 reportStackOverflow :: IO a
 167 reportStackOverflow = do callStackOverflowHook; return undefined
 168
 169 reportError :: Exception -> IO a
 170 reportError ex = do
 171    handler <- getUncaughtExceptionHandler
 172    handler ex
 173    return undefined
 174
 175 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
 176 -- the unsafe below.
 177 foreign import ccall unsafe "stackOverflow"
 178         callStackOverflowHook :: IO ()
 179
 180 -- try to flush stdout/stderr, but don't worry if we fail
 181 -- (these handles might have errors, and we don't want to go into
 182 -- an infinite loop).
 183 cleanUp :: IO ()
 184 cleanUp = do
 185   hFlush stdout `catchException` \_ -> return ()
 186   hFlush stderr `catchException` \_ -> return ()
 187
 188 cleanUpAndExit :: Int -> IO a
 189 cleanUpAndExit r = do cleanUp; safeExit r
 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}