GHC/TopHandler.lhs

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