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