ghc/lib/std/PrelTopHandler.lhs

   1 -- -----------------------------------------------------------------------------
   2 -- $Id: PrelTopHandler.lhs,v 1.5 2001/08/17 11:13:04 rrt Exp $
   3 --
   4 -- (c) The University of Glasgow, 2001
   5 --
   6 -- PrelTopHandler
   7 --
   8 -- 'Top-level' IO actions want to catch exceptions (e.g., forkIO and
   9 -- PrelMain.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 PrelMain, because PrelMain isn't
  17 -- included in HSstd.o (because PrelMain depends on Main, which
  18 -- doesn't exist yet...).
  19
  20 \begin{code}
  21 module PrelTopHandler (
  22    topHandler, reportStackOverflow, reportError
  23   ) where
  24
  25 import IO
  26
  27 import PrelCString
  28 import PrelPtr
  29 import PrelIOBase
  30 import PrelException
  31
  32 topHandler :: Exception -> IO ()
  33 topHandler err = catchException (real_handler err) topHandler
  34
  35 real_handler :: Exception -> IO ()
  36 real_handler ex =
  37   case ex of
  38         AsyncException StackOverflow -> reportStackOverflow True
  39
  40         -- only the main thread gets ExitException exceptions
  41         ExitException ExitSuccess     -> shutdownHaskellAndExit 0
  42         ExitException (ExitFailure n) -> shutdownHaskellAndExit n
  43
  44         ErrorCall s -> reportError True s
  45         other       -> reportError True (showsPrec 0 other "\n")
  46
  47 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
  48 -- re-enter Haskell land through finalizers.
  49 foreign import ccall "shutdownHaskellAndExit"
  50   shutdownHaskellAndExit :: Int -> IO ()
  51
  52 reportStackOverflow :: Bool -> IO ()
  53 reportStackOverflow bombOut = do
  54    (hFlush stdout) `catchException` (\ _ -> return ())
  55    callStackOverflowHook
  56    if bombOut then
  57      stg_exit 2
  58     else
  59      return ()
  60
  61 reportError :: Bool -> String -> IO ()
  62 reportError bombOut str = do
  63    (hFlush stdout) `catchException` (\ _ -> return ())
  64    withCStringLen str $ \(cstr,len) -> do
  65      writeErrString errorHdrHook cstr len
  66      if bombOut
  67         then stg_exit 1
  68         else return ()
  69
  70 #ifndef ILX
  71 foreign label "ErrorHdrHook" errorHdrHook :: Ptr ()
  72 #else
  73 foreign import "_ErrorHdrHook" errorHdrHook :: Ptr ()
  74 #endif
  75
  76 foreign import ccall "writeErrString__" unsafe
  77         writeErrString :: Ptr () -> CString -> Int -> IO ()
  78
  79 -- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
  80 -- the unsafe below.
  81 foreign import ccall "stackOverflow" unsafe
  82         callStackOverflowHook :: IO ()
  83
  84 foreign import ccall "stg_exit" unsafe
  85         stg_exit :: Int -> IO ()
  86 \end{code}