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}