GHC/TopHandler.lhs

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