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