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