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