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