[project @ 2002-03-11 14:53:51 by simonmar]
[packages/base.git] / GHC / TopHandler.lhs
1 -- -----------------------------------------------------------------------------
2 -- $Id: TopHandler.lhs,v 1.6 2002/03/11 14:53:51 simonmar Exp $
3 --
4 -- (c) The University of Glasgow, 2001
5 --
6 -- GHC.TopHandler
7 --
8 -- 'Top-level' IO actions want to catch exceptions (e.g., forkIO and 
9 -- GHC.Main.mainIO) and report them - topHandler is the exception
10 -- handler they should use for this:
11
12 -- make sure we handle errors while reporting the error!
13 -- (e.g. evaluating the string passed to 'error' might generate
14 --  another error, etc.)
15
16 -- These functions can't go in GHC.Main, because GHC.Main isn't
17 -- included in HSstd.o (because GHC.Main depends on Main, which
18 -- doesn't exist yet...).
19
20 \begin{code}
21 module GHC.TopHandler (
22    runMain, reportStackOverflow, reportError 
23   ) where
24
25 import Prelude
26
27 import System.IO
28
29 import Foreign.C.String
30 import Foreign.Ptr
31 import GHC.IOBase
32 import GHC.Exception
33
34 -- runMain is applied to Main.main by TcModule
35 runMain :: IO a -> IO ()
36 runMain main = catchException (main >> return ()) topHandler
37   
38 topHandler :: Exception -> IO ()
39 topHandler err = catchException (real_handler err) topHandler
40
41 real_handler :: Exception -> IO ()
42 real_handler ex =
43   case ex of
44         AsyncException StackOverflow -> reportStackOverflow True
45
46         -- only the main thread gets ExitException exceptions
47         ExitException ExitSuccess     -> shutdownHaskellAndExit 0
48         ExitException (ExitFailure n) -> shutdownHaskellAndExit n
49
50         Deadlock    -> reportError True 
51                         "no threads to run:  infinite loop or deadlock?"
52   
53         ErrorCall s -> reportError True s
54         other       -> reportError True (showsPrec 0 other "\n")
55
56 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
57 -- re-enter Haskell land through finalizers.
58 foreign import ccall "shutdownHaskellAndExit" 
59   shutdownHaskellAndExit :: Int -> IO ()
60
61 reportStackOverflow :: Bool -> IO ()
62 reportStackOverflow bombOut = do
63    (hFlush stdout) `catchException` (\ _ -> return ())
64    callStackOverflowHook
65    if bombOut then
66      stg_exit 2
67     else
68      return ()
69
70 reportError :: Bool -> String -> IO ()
71 reportError bombOut str = do
72    (hFlush stdout) `catchException` (\ _ -> return ())
73    withCStringLen str $ \(cstr,len) -> do
74      writeErrString errorHdrHook cstr len
75      if bombOut 
76         then stg_exit 1
77         else return ()
78
79 #ifndef ILX
80 foreign import ccall "&ErrorHdrHook" errorHdrHook :: Ptr ()
81 #else
82 foreign import ccall "ErrorHdrHook" errorHdrHook :: Ptr ()
83 #endif
84
85 foreign import ccall unsafe "writeErrString__"
86         writeErrString :: Ptr () -> CString -> Int -> IO ()
87
88 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
89 -- the unsafe below.
90 foreign import ccall unsafe "stackOverflow"
91         callStackOverflowHook :: IO ()
92
93 foreign import ccall unsafe "stg_exit"
94         stg_exit :: Int -> IO ()
95 \end{code}