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