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