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