base: Manually unlit .lhs into .hs modules
[ghc.git] / libraries / base / GHC / TopHandler.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE CPP
3 , NoImplicitPrelude
4 , MagicHash
5 , UnboxedTuples
6 #-}
7 {-# OPTIONS_HADDOCK hide #-}
8
9 -----------------------------------------------------------------------------
10 -- |
11 -- Module : GHC.TopHandler
12 -- Copyright : (c) The University of Glasgow, 2001-2002
13 -- License : see libraries/base/LICENSE
14 --
15 -- Maintainer : cvs-ghc@haskell.org
16 -- Stability : internal
17 -- Portability : non-portable (GHC Extensions)
18 --
19 -- Support for catching exceptions raised during top-level computations
20 -- (e.g. @Main.main@, 'Control.Concurrent.forkIO', and foreign exports)
21 --
22 -----------------------------------------------------------------------------
23
24 module GHC.TopHandler (
25 runMainIO, runIO, runIOFastExit, runNonIO,
26 topHandler, topHandlerFastExit,
27 reportStackOverflow, reportError,
28 flushStdHandles
29 ) where
30
31 #include "HsBaseConfig.h"
32
33 import Control.Exception
34 import Data.Maybe
35
36 import Foreign
37 import Foreign.C
38 import GHC.Base
39 import GHC.Conc hiding (throwTo)
40 import GHC.Real
41 import GHC.IO
42 import GHC.IO.Handle.FD
43 import GHC.IO.Handle
44 import GHC.IO.Exception
45 import GHC.Weak
46
47 #if defined(mingw32_HOST_OS)
48 import GHC.ConsoleHandler
49 #else
50 import Data.Dynamic (toDyn)
51 #endif
52
53 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
54 -- called in the program). It catches otherwise uncaught exceptions,
55 -- and also flushes stdout\/stderr before exiting.
56 runMainIO :: IO a -> IO a
57 runMainIO main =
58 do
59 main_thread_id <- myThreadId
60 weak_tid <- mkWeakThreadId main_thread_id
61 install_interrupt_handler $ do
62 m <- deRefWeak weak_tid
63 case m of
64 Nothing -> return ()
65 Just tid -> throwTo tid (toException UserInterrupt)
66 main -- hs_exit() will flush
67 `catch`
68 topHandler
69
70 install_interrupt_handler :: IO () -> IO ()
71 #ifdef mingw32_HOST_OS
72 install_interrupt_handler handler = do
73 _ <- GHC.ConsoleHandler.installHandler $
74 Catch $ \event ->
75 case event of
76 ControlC -> handler
77 Break -> handler
78 Close -> handler
79 _ -> return ()
80 return ()
81 #else
82 #include "rts/Signals.h"
83 -- specialised version of System.Posix.Signals.installHandler, which
84 -- isn't available here.
85 install_interrupt_handler handler = do
86 let sig = CONST_SIGINT :: CInt
87 _ <- setHandler sig (Just (const handler, toDyn handler))
88 _ <- stg_sig_install sig STG_SIG_RST nullPtr
89 -- STG_SIG_RST: the second ^C kills us for real, just in case the
90 -- RTS or program is unresponsive.
91 return ()
92
93 foreign import ccall unsafe
94 stg_sig_install
95 :: CInt -- sig no.
96 -> CInt -- action code (STG_SIG_HAN etc.)
97 -> Ptr () -- (in, out) blocked
98 -> IO CInt -- (ret) old action code
99 #endif
100
101 -- | 'runIO' is wrapped around every @foreign export@ and @foreign
102 -- import \"wrapper\"@ to mop up any uncaught exceptions. Thus, the
103 -- result of running 'System.Exit.exitWith' in a foreign-exported
104 -- function is the same as in the main thread: it terminates the
105 -- program.
106 --
107 runIO :: IO a -> IO a
108 runIO main = catch main topHandler
109
110 -- | Like 'runIO', but in the event of an exception that causes an exit,
111 -- we don't shut down the system cleanly, we just exit. This is
112 -- useful in some cases, because the safe exit version will give other
113 -- threads a chance to clean up first, which might shut down the
114 -- system in a different way. For example, try
115 --
116 -- main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
117 --
118 -- This will sometimes exit with "interrupted" and code 0, because the
119 -- main thread is given a chance to shut down when the child thread calls
120 -- safeExit. There is a race to shut down between the main and child threads.
121 --
122 runIOFastExit :: IO a -> IO a
123 runIOFastExit main = catch main topHandlerFastExit
124 -- NB. this is used by the testsuite driver
125
126 -- | The same as 'runIO', but for non-IO computations. Used for
127 -- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
128 -- are used to export Haskell functions with non-IO types.
129 --
130 runNonIO :: a -> IO a
131 runNonIO a = catch (a `seq` return a) topHandler
132
133 topHandler :: SomeException -> IO a
134 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 -- Make sure we handle errors while reporting the error!
141 -- (e.g. evaluating the string passed to 'error' might generate
142 -- another error, etc.)
143 --
144 real_handler :: (Int -> IO a) -> SomeException -> IO a
145 real_handler exit se = do
146 flushStdHandles -- before any error output
147 case fromException se of
148 Just StackOverflow -> do
149 reportStackOverflow
150 exit 2
151
152 Just UserInterrupt -> exitInterrupted
153
154 _ -> case fromException se of
155 -- only the main thread gets ExitException exceptions
156 Just ExitSuccess -> exit 0
157 Just (ExitFailure n) -> exit n
158
159 -- EPIPE errors received for stdout are ignored (#2699)
160 _ -> case fromException se of
161 Just IOError{ ioe_type = ResourceVanished,
162 ioe_errno = Just ioe,
163 ioe_handle = Just hdl }
164 | Errno ioe == ePIPE, hdl == stdout -> exit 0
165 _ -> do reportError se
166 exit 1
167
168
169 -- try to flush stdout/stderr, but don't worry if we fail
170 -- (these handles might have errors, and we don't want to go into
171 -- an infinite loop).
172 flushStdHandles :: IO ()
173 flushStdHandles = do
174 hFlush stdout `catchAny` \_ -> return ()
175 hFlush stderr `catchAny` \_ -> return ()
176
177 safeExit, fastExit :: Int -> IO a
178 safeExit = exitHelper useSafeExit
179 fastExit = exitHelper useFastExit
180
181 unreachable :: IO a
182 unreachable = fail "If you can read this, shutdownHaskellAndExit did not exit."
183
184 exitHelper :: CInt -> Int -> IO a
185 #ifdef mingw32_HOST_OS
186 exitHelper exitKind r =
187 shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable
188 #else
189 -- On Unix we use an encoding for the ExitCode:
190 -- 0 -- 255 normal exit code
191 -- -127 -- -1 exit by signal
192 -- For any invalid encoding we just use a replacement (0xff).
193 exitHelper exitKind r
194 | r >= 0 && r <= 255
195 = shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable
196 | r >= -127 && r <= -1
197 = shutdownHaskellAndSignal (fromIntegral (-r)) exitKind >> unreachable
198 | otherwise
199 = shutdownHaskellAndExit 0xff exitKind >> unreachable
200
201 foreign import ccall "shutdownHaskellAndSignal"
202 shutdownHaskellAndSignal :: CInt -> CInt -> IO ()
203 #endif
204
205 exitInterrupted :: IO a
206 exitInterrupted =
207 #ifdef mingw32_HOST_OS
208 safeExit 252
209 #else
210 -- we must exit via the default action for SIGINT, so that the
211 -- parent of this process can take appropriate action (see #2301)
212 safeExit (-CONST_SIGINT)
213 #endif
214
215 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
216 -- re-enter Haskell land through finalizers.
217 foreign import ccall "Rts.h shutdownHaskellAndExit"
218 shutdownHaskellAndExit :: CInt -> CInt -> IO ()
219
220 useFastExit, useSafeExit :: CInt
221 useFastExit = 1
222 useSafeExit = 0