GHC/TopHandler.lhs

   1 -- -----------------------------------------------------------------------------
   2 -- $Id: TopHandler.lhs,v 1.5 2002/02/11 12:28:57 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 label "ErrorHdrHook" errorHdrHook :: Ptr ()
  81 #else
  82 foreign import "ErrorHdrHook" errorHdrHook :: Ptr ()
  83 #endif
  84
  85 foreign import ccall "writeErrString__" unsafe
  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 "stackOverflow" unsafe
  91         callStackOverflowHook :: IO ()
  92
  93 foreign import ccall "stg_exit" unsafe
  94         stg_exit :: Int -> IO ()
  95 \end{code}