TopHandler.hs 8.22 KB
Newer Older
1
{-# LANGUAGE Trustworthy #-}
2 3 4 5 6
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , MagicHash
           , UnboxedTuples
  #-}
7
{-# OPTIONS_HADDOCK hide #-}
8

9 10 11 12 13
-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.TopHandler
-- Copyright   :  (c) The University of Glasgow, 2001-2002
-- License     :  see libraries/base/LICENSE
14
--
15 16 17
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
18
--
19 20
-- Support for catching exceptions raised during top-level computations
-- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)
21
--
22
-----------------------------------------------------------------------------
23 24

module GHC.TopHandler (
25 26 27
        runMainIO, runIO, runIOFastExit, runNonIO,
        topHandler, topHandlerFastExit,
        reportStackOverflow, reportError,
Simon Marlow's avatar
Simon Marlow committed
28
        flushStdHandles
29
    ) where
30

Simon Marlow's avatar
Simon Marlow committed
31 32
#include "HsBaseConfig.h"

33
import Control.Exception
34
import Data.Maybe
35

Simon Marlow's avatar
Simon Marlow committed
36 37
import Foreign
import Foreign.C
38 39 40
import GHC.Base
import GHC.Conc hiding (throwTo)
import GHC.Real
41 42 43 44
import GHC.IO
import GHC.IO.Handle.FD
import GHC.IO.Handle
import GHC.IO.Exception
Simon Marlow's avatar
Simon Marlow committed
45
import GHC.Weak
46

Ian Lynagh's avatar
Ian Lynagh committed
47 48
#if defined(mingw32_HOST_OS)
import GHC.ConsoleHandler
49 50
#else
import Data.Dynamic (toDyn)
Ian Lynagh's avatar
Ian Lynagh committed
51
#endif
52

53 54
-- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
-- called in the program).  It catches otherwise uncaught exceptions,
55
-- and also flushes stdout\/stderr before exiting.
56
runMainIO :: IO a -> IO a
57 58
runMainIO main =
    do
Simon Marlow's avatar
Simon Marlow committed
59 60 61
      main_thread_id <- myThreadId
      weak_tid <- mkWeakThreadId main_thread_id
      install_interrupt_handler $ do
62
           m <- deRefWeak weak_tid
Simon Marlow's avatar
Simon Marlow committed
63 64
           case m of
               Nothing  -> return ()
65
               Just tid -> throwTo tid (toException UserInterrupt)
Simon Marlow's avatar
Simon Marlow committed
66
      main -- hs_exit() will flush
67
    `catch`
Simon Marlow's avatar
Simon Marlow committed
68 69 70 71
      topHandler

install_interrupt_handler :: IO () -> IO ()
#ifdef mingw32_HOST_OS
Simon Marlow's avatar
Simon Marlow committed
72
install_interrupt_handler handler = do
Ian Lynagh's avatar
Ian Lynagh committed
73
  _ <- GHC.ConsoleHandler.installHandler $
74
     Catch $ \event ->
Simon Marlow's avatar
Simon Marlow committed
75 76 77 78 79
        case event of
           ControlC -> handler
           Break    -> handler
           Close    -> handler
           _ -> return ()
Simon Marlow's avatar
Simon Marlow committed
80
  return ()
Simon Marlow's avatar
Simon Marlow committed
81
#else
82
#include "rts/Signals.h"
Simon Marlow's avatar
Simon Marlow committed
83 84 85 86
-- specialised version of System.Posix.Signals.installHandler, which
-- isn't available here.
install_interrupt_handler handler = do
   let sig = CONST_SIGINT :: CInt
87 88
   _ <- setHandler sig (Just (const handler, toDyn handler))
   _ <- stg_sig_install sig STG_SIG_RST nullPtr
89 90 91
     -- STG_SIG_RST: the second ^C kills us for real, just in case the
     -- RTS or program is unresponsive.
   return ()
92

Simon Marlow's avatar
Simon Marlow committed
93 94
foreign import ccall unsafe
  stg_sig_install
95 96 97 98
        :: CInt                         -- sig no.
        -> CInt                         -- action code (STG_SIG_HAN etc.)
        -> Ptr ()                       -- (in, out) blocked
        -> IO CInt                      -- (ret) old action code
Simon Marlow's avatar
Simon Marlow committed
99 100
#endif

101 102 103 104 105
-- | 'runIO' is wrapped around every @foreign export@ and @foreign
-- import \"wrapper\"@ to mop up any uncaught exceptions.  Thus, the
-- result of running 'System.Exit.exitWith' in a foreign-exported
-- function is the same as in the main thread: it terminates the
-- program.
106 107
--
runIO :: IO a -> IO a
108
runIO main = catch main topHandler
109

110 111 112 113
-- | Like 'runIO', but in the event of an exception that causes an exit,
-- we don't shut down the system cleanly, we just exit.  This is
-- useful in some cases, because the safe exit version will give other
-- threads a chance to clean up first, which might shut down the
114
-- system in a different way.  For example, try
115 116 117 118 119 120 121 122
--
--   main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
--
-- This will sometimes exit with "interrupted" and code 0, because the
-- main thread is given a chance to shut down when the child thread calls
-- safeExit.  There is a race to shut down between the main and child threads.
--
runIOFastExit :: IO a -> IO a
123
runIOFastExit main = catch main topHandlerFastExit
Don Stewart's avatar
Don Stewart committed
124
        -- NB. this is used by the testsuite driver
125

126 127 128 129 130
-- | The same as 'runIO', but for non-IO computations.  Used for
-- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
-- are used to export Haskell functions with non-IO types.
--
runNonIO :: a -> IO a
131
runNonIO a = catch (a `seq` return a) topHandler
132

133 134
topHandler :: SomeException -> IO a
topHandler err = catch (real_handler safeExit err) topHandler
135

136
topHandlerFastExit :: SomeException -> IO a
137
topHandlerFastExit err =
138
  catchException (real_handler fastExit err) topHandlerFastExit
139

140 141 142 143
-- Make sure we handle errors while reporting the error!
-- (e.g. evaluating the string passed to 'error' might generate
--  another error, etc.)
--
144
real_handler :: (Int -> IO a) -> SomeException -> IO a
145
real_handler exit se = do
Simon Marlow's avatar
Simon Marlow committed
146
  flushStdHandles -- before any error output
147
  case fromException se of
148
      Just StackOverflow -> do
Don Stewart's avatar
Don Stewart committed
149 150
           reportStackOverflow
           exit 2
151

152
      Just UserInterrupt  -> exitInterrupted
Simon Marlow's avatar
Simon Marlow committed
153

154
      _ -> case fromException se of
155 156 157
           -- only the main thread gets ExitException exceptions
           Just ExitSuccess     -> exit 0
           Just (ExitFailure n) -> exit n
158

159
           -- EPIPE errors received for stdout are ignored (#2699)
Austin Seipp's avatar
Austin Seipp committed
160
           _ -> catch (case fromException se of
161 162 163 164 165 166
                Just IOError{ ioe_type = ResourceVanished,
                              ioe_errno = Just ioe,
                              ioe_handle = Just hdl }
                   | Errno ioe == ePIPE, hdl == stdout -> exit 0
                _ -> do reportError se
                        exit 1
Austin Seipp's avatar
Austin Seipp committed
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193
                ) (disasterHandler exit) -- See Note [Disaster with iconv]

-- don't use errorBelch() directly, because we cannot call varargs functions
-- using the FFI.
foreign import ccall unsafe "HsBase.h errorBelch2"
   errorBelch :: CString -> CString -> IO ()

disasterHandler :: (Int -> IO a) -> IOError -> IO a
disasterHandler exit _ =
  withCAString "%s" $ \fmt ->
    withCAString msgStr $ \msg ->
      errorBelch fmt msg >> exit 1
  where msgStr = "encountered an exception while trying to report an exception"

{- Note [Disaster with iconv]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When using iconv, it's possible for things like iconv_open to fail in
restricted environments (like an initram or restricted container), but
when this happens the error raised inevitably calls `peekCString`,
which depends on the users locale, which depends on using
`iconv_open`... which causes an infinite loop.

This occurrence is also known as tickets #10298 and #7695. So to work
around it we just set _another_ error handler and bail directly by
calling the RTS, without iconv at all.
-}
194

195

196 197 198
-- try to flush stdout/stderr, but don't worry if we fail
-- (these handles might have errors, and we don't want to go into
-- an infinite loop).
Simon Marlow's avatar
Simon Marlow committed
199 200
flushStdHandles :: IO ()
flushStdHandles = do
201 202
  hFlush stdout `catchAny` \_ -> return ()
  hFlush stderr `catchAny` \_ -> return ()
203

204 205 206 207
safeExit, fastExit :: Int -> IO a
safeExit = exitHelper useSafeExit
fastExit = exitHelper useFastExit

208 209 210
unreachable :: IO a
unreachable = fail "If you can read this, shutdownHaskellAndExit did not exit."

211 212 213
exitHelper :: CInt -> Int -> IO a
#ifdef mingw32_HOST_OS
exitHelper exitKind r =
214
  shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable
215 216 217 218 219 220 221
#else
-- On Unix we use an encoding for the ExitCode:
--      0 -- 255  normal exit code
--   -127 -- -1   exit by signal
-- For any invalid encoding we just use a replacement (0xff).
exitHelper exitKind r
  | r >= 0 && r <= 255
222
  = shutdownHaskellAndExit   (fromIntegral   r)  exitKind >> unreachable
223
  | r >= -127 && r <= -1
224
  = shutdownHaskellAndSignal (fromIntegral (-r)) exitKind >> unreachable
225
  | otherwise
226
  = shutdownHaskellAndExit   0xff                exitKind >> unreachable
227 228 229 230

foreign import ccall "shutdownHaskellAndSignal"
  shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
#endif
231

Simon Marlow's avatar
Simon Marlow committed
232
exitInterrupted :: IO a
233
exitInterrupted =
Simon Marlow's avatar
Simon Marlow committed
234 235 236 237 238
#ifdef mingw32_HOST_OS
  safeExit 252
#else
  -- we must exit via the default action for SIGINT, so that the
  -- parent of this process can take appropriate action (see #2301)
239
  safeExit (-CONST_SIGINT)
Simon Marlow's avatar
Simon Marlow committed
240 241
#endif

242 243
-- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
-- re-enter Haskell land through finalizers.
244
foreign import ccall "Rts.h shutdownHaskellAndExit"
245
  shutdownHaskellAndExit :: CInt -> CInt -> IO ()
246

247 248 249
useFastExit, useSafeExit :: CInt
useFastExit = 1
useSafeExit = 0