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