58da8717298f40edbb3ef5632afe4f8837f9d572
[ghc.git] / libraries / base / GHC / TopHandler.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP
3 , NoImplicitPrelude
4 , MagicHash
5 , UnboxedTuples
6 , UnliftedFFITypes
7 #-}
8 {-# OPTIONS_HADDOCK hide #-}
9
10 -----------------------------------------------------------------------------
11 -- |
12 -- Module : GHC.TopHandler
13 -- Copyright : (c) The University of Glasgow, 2001-2002
14 -- License : see libraries/base/LICENSE
15 --
16 -- Maintainer : cvs-ghc@haskell.org
17 -- Stability : internal
18 -- Portability : non-portable (GHC Extensions)
19 --
20 -- Support for catching exceptions raised during top-level computations
21 -- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)
22 --
23 -----------------------------------------------------------------------------
24
25 module GHC.TopHandler (
26 runMainIO, runIO, runIOFastExit, runNonIO,
27 topHandler, topHandlerFastExit,
28 reportStackOverflow, reportError,
29 flushStdHandles
30 ) where
31
32 #include "HsBaseConfig.h"
33
34 import Control.Exception
35 import Data.Maybe
36
37 import Foreign
38 import Foreign.C
39 import GHC.Base
40 import GHC.Conc hiding (throwTo)
41 import GHC.Real
42 import GHC.IO
43 import GHC.IO.Handle.FD
44 import GHC.IO.Handle
45 import GHC.IO.Exception
46 import GHC.Weak
47
48 #if defined(mingw32_HOST_OS)
49 import GHC.ConsoleHandler
50 #else
51 import Data.Dynamic (toDyn)
52 #endif
53
54 -- Note [rts_setMainThread must be called unsafely]
55 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
56 --
57 -- rts_setMainThread must be called as unsafe, because it
58 -- dereferences the Weak# and manipulates the raw Haskell value
59 -- behind it. Therefore, it must not race with a garbage collection.
60
61 -- Note [rts_setMainThread has an unsound type]
62 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
63 --
64 -- 'rts_setMainThread' is imported with type Weak# ThreadId -> IO (),
65 -- but this is an unsound type for it: it grabs the /key/ of the
66 -- 'Weak#' object, which isn't tracked by the type at all.
67 -- That this works at all is a consequence of the fact that
68 -- 'mkWeakThreadId' produces a 'Weak#' with a 'ThreadId#' as the key
69 -- This is fairly robust, in that 'mkWeakThreadId' wouldn't work
70 -- otherwise, but it still is sufficiently non-trivial to justify an
71 -- ASSERT in rts/TopHandler.c.
72
73 -- see Note [rts_setMainThread must be called unsafely] and
74 -- Note [rts_setMainThread has an unsound type]
75 foreign import ccall unsafe "rts_setMainThread"
76 setMainThread :: Weak# ThreadId -> IO ()
77
78 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
79 -- called in the program). It catches otherwise uncaught exceptions,
80 -- and also flushes stdout\/stderr before exiting.
81 runMainIO :: IO a -> IO a
82 runMainIO main =
83 do
84 main_thread_id <- myThreadId
85 weak_tid <- mkWeakThreadId main_thread_id
86 case weak_tid of (Weak w) -> setMainThread w
87 install_interrupt_handler $ do
88 m <- deRefWeak weak_tid
89 case m of
90 Nothing -> return ()
91 Just tid -> throwTo tid (toException UserInterrupt)
92 main -- hs_exit() will flush
93 `catch`
94 topHandler
95
96 install_interrupt_handler :: IO () -> IO ()
97 #ifdef mingw32_HOST_OS
98 install_interrupt_handler handler = do
99 _ <- GHC.ConsoleHandler.installHandler $
100 Catch $ \event ->
101 case event of
102 ControlC -> handler
103 Break -> handler
104 Close -> handler
105 _ -> return ()
106 return ()
107 #else
108 #include "rts/Signals.h"
109 -- specialised version of System.Posix.Signals.installHandler, which
110 -- isn't available here.
111 install_interrupt_handler handler = do
112 let sig = CONST_SIGINT :: CInt
113 _ <- setHandler sig (Just (const handler, toDyn handler))
114 _ <- stg_sig_install sig STG_SIG_RST nullPtr
115 -- STG_SIG_RST: the second ^C kills us for real, just in case the
116 -- RTS or program is unresponsive.
117 return ()
118
119 foreign import ccall unsafe
120 stg_sig_install
121 :: CInt -- sig no.
122 -> CInt -- action code (STG_SIG_HAN etc.)
123 -> Ptr () -- (in, out) blocked
124 -> IO CInt -- (ret) old action code
125 #endif
126
127 -- | 'runIO' is wrapped around every @foreign export@ and @foreign
128 -- import \"wrapper\"@ to mop up any uncaught exceptions. Thus, the
129 -- result of running 'System.Exit.exitWith' in a foreign-exported
130 -- function is the same as in the main thread: it terminates the
131 -- program.
132 --
133 runIO :: IO a -> IO a
134 runIO main = catch main topHandler
135
136 -- | Like 'runIO', but in the event of an exception that causes an exit,
137 -- we don't shut down the system cleanly, we just exit. This is
138 -- useful in some cases, because the safe exit version will give other
139 -- threads a chance to clean up first, which might shut down the
140 -- system in a different way. For example, try
141 --
142 -- main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
143 --
144 -- This will sometimes exit with "interrupted" and code 0, because the
145 -- main thread is given a chance to shut down when the child thread calls
146 -- safeExit. There is a race to shut down between the main and child threads.
147 --
148 runIOFastExit :: IO a -> IO a
149 runIOFastExit main = catch main topHandlerFastExit
150 -- NB. this is used by the testsuite driver
151
152 -- | The same as 'runIO', but for non-IO computations. Used for
153 -- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
154 -- are used to export Haskell functions with non-IO types.
155 --
156 runNonIO :: a -> IO a
157 runNonIO a = catch (a `seq` return a) topHandler
158
159 topHandler :: SomeException -> IO a
160 topHandler err = catch (real_handler safeExit err) topHandler
161
162 topHandlerFastExit :: SomeException -> IO a
163 topHandlerFastExit err =
164 catchException (real_handler fastExit err) topHandlerFastExit
165
166 -- Make sure we handle errors while reporting the error!
167 -- (e.g. evaluating the string passed to 'error' might generate
168 -- another error, etc.)
169 --
170 real_handler :: (Int -> IO a) -> SomeException -> IO a
171 real_handler exit se = do
172 flushStdHandles -- before any error output
173 case fromException se of
174 Just StackOverflow -> do
175 reportStackOverflow
176 exit 2
177
178 Just UserInterrupt -> exitInterrupted
179
180 Just HeapOverflow -> do
181 reportHeapOverflow
182 exit 251
183
184 _ -> case fromException se of
185 -- only the main thread gets ExitException exceptions
186 Just ExitSuccess -> exit 0
187 Just (ExitFailure n) -> exit n
188
189 -- EPIPE errors received for stdout are ignored (#2699)
190 _ -> catch (case fromException se of
191 Just IOError{ ioe_type = ResourceVanished,
192 ioe_errno = Just ioe,
193 ioe_handle = Just hdl }
194 | Errno ioe == ePIPE, hdl == stdout -> exit 0
195 _ -> do reportError se
196 exit 1
197 ) (disasterHandler exit) -- See Note [Disaster with iconv]
198
199 -- don't use errorBelch() directly, because we cannot call varargs functions
200 -- using the FFI.
201 foreign import ccall unsafe "HsBase.h errorBelch2"
202 errorBelch :: CString -> CString -> IO ()
203
204 disasterHandler :: (Int -> IO a) -> IOError -> IO a
205 disasterHandler exit _ =
206 withCAString "%s" $ \fmt ->
207 withCAString msgStr $ \msg ->
208 errorBelch fmt msg >> exit 1
209 where
210 msgStr =
211 "encountered an exception while trying to report an exception." ++
212 "One possible reason for this is that we failed while trying to " ++
213 "encode an error message. Check that your locale is configured " ++
214 "properly."
215
216 {- Note [Disaster with iconv]
217 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
218
219 When using iconv, it's possible for things like iconv_open to fail in
220 restricted environments (like an initram or restricted container), but
221 when this happens the error raised inevitably calls `peekCString`,
222 which depends on the users locale, which depends on using
223 `iconv_open`... which causes an infinite loop.
224
225 This occurrence is also known as tickets #10298 and #7695. So to work
226 around it we just set _another_ error handler and bail directly by
227 calling the RTS, without iconv at all.
228 -}
229
230
231 -- try to flush stdout/stderr, but don't worry if we fail
232 -- (these handles might have errors, and we don't want to go into
233 -- an infinite loop).
234 flushStdHandles :: IO ()
235 flushStdHandles = do
236 hFlush stdout `catchAny` \_ -> return ()
237 hFlush stderr `catchAny` \_ -> return ()
238
239 safeExit, fastExit :: Int -> IO a
240 safeExit = exitHelper useSafeExit
241 fastExit = exitHelper useFastExit
242
243 unreachable :: IO a
244 unreachable = fail "If you can read this, shutdownHaskellAndExit did not exit."
245
246 exitHelper :: CInt -> Int -> IO a
247 #ifdef mingw32_HOST_OS
248 exitHelper exitKind r =
249 shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable
250 #else
251 -- On Unix we use an encoding for the ExitCode:
252 -- 0 -- 255 normal exit code
253 -- -127 -- -1 exit by signal
254 -- For any invalid encoding we just use a replacement (0xff).
255 exitHelper exitKind r
256 | r >= 0 && r <= 255
257 = shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable
258 | r >= -127 && r <= -1
259 = shutdownHaskellAndSignal (fromIntegral (-r)) exitKind >> unreachable
260 | otherwise
261 = shutdownHaskellAndExit 0xff exitKind >> unreachable
262
263 foreign import ccall "shutdownHaskellAndSignal"
264 shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
265 #endif
266
267 exitInterrupted :: IO a
268 exitInterrupted =
269 #ifdef mingw32_HOST_OS
270 safeExit 252
271 #else
272 -- we must exit via the default action for SIGINT, so that the
273 -- parent of this process can take appropriate action (see #2301)
274 safeExit (-CONST_SIGINT)
275 #endif
276
277 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
278 -- re-enter Haskell land through finalizers.
279 foreign import ccall "Rts.h shutdownHaskellAndExit"
280 shutdownHaskellAndExit :: CInt -> CInt -> IO ()
281
282 useFastExit, useSafeExit :: CInt
283 useFastExit = 1
284 useSafeExit = 0