Warning police: Make some prototypes from the RTS known

[haskell-directory.git] / GHC / TopHandler.lhs

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 186fd8e..3c64fc8 100644 (file)
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -14,8 +14,9 @@
 --
 -----------------------------------------------------------------------------
 
+-- #hide
 module GHC.TopHandler (
-   runMainIO, runIO, runNonIO, reportStackOverflow, reportError
+   runMainIO, runIO, runIOFastExit, runNonIO, reportStackOverflow, reportError
   ) where
 
 import Prelude
@@ -23,13 +24,14 @@ import Prelude
 import System.IO
 import Control.Exception
 
+import Foreign.C       ( CInt )
 import GHC.IOBase
 import GHC.Exception
 import GHC.Prim (unsafeCoerce#)
 
 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
 -- called in the program).  It catches otherwise uncaught exceptions,
--- and also flushes stdout/stderr before exiting.
+-- and also flushes stdout\/stderr before exiting.
 runMainIO :: IO a -> IO a
 runMainIO main = (do a <- main; cleanUp; return a) `catchException` topHandler
 
@@ -42,6 +44,22 @@ runMainIO main = (do a <- main; cleanUp; return a) `catchException` topHandler
 runIO :: IO a -> IO a
 runIO main = catchException main topHandler
 
+-- | Like 'runIO', but in the event of an exception that causes an exit,
+-- we don't shut down the system cleanly, we just exit.  This is
+-- useful in some cases, because the safe exit version will give other
+-- threads a chance to clean up first, which might shut down the
+-- system in a different way.  For example, try 
+--
+--   main = forkIO (runIO (exitWith (ExitFailure 1))) >> threadDelay 10000
+--
+-- This will sometimes exit with "interrupted" and code 0, because the
+-- main thread is given a chance to shut down when the child thread calls
+-- safeExit.  There is a race to shut down between the main and child threads.
+--
+runIOFastExit :: IO a -> IO a
+runIOFastExit main = catchException main topHandlerFastExit
+       -- NB. this is used by the testsuite driver
+
 -- | The same as 'runIO', but for non-IO computations.  Used for
 -- wrapping @foreign export@ and @foreign import \"wrapper\"@ when these
 -- are used to export Haskell functions with non-IO types.
@@ -50,26 +68,31 @@ runNonIO :: a -> IO a
 runNonIO a = catchException (a `seq` return a) topHandler
 
 topHandler :: Exception -> IO a
-topHandler err = catchException (real_handler err) topHandler
+topHandler err = catchException (real_handler safeExit err) topHandler
+
+topHandlerFastExit :: Exception -> IO a
+topHandlerFastExit err = 
+  catchException (real_handler fastExit err) topHandlerFastExit
 
 -- Make sure we handle errors while reporting the error!
 -- (e.g. evaluating the string passed to 'error' might generate
 --  another error, etc.)
 --
-real_handler :: Exception -> IO a
-real_handler ex =
-  case ex of
+real_handler :: (Int -> IO a) -> Exception -> IO a
+real_handler exit exn =
+  cleanUp >>
+  case exn of
        AsyncException StackOverflow -> do
           reportStackOverflow
-          safeExit 2
+          exit 2
 
        -- only the main thread gets ExitException exceptions
-       ExitException ExitSuccess     -> safeExit 0
-       ExitException (ExitFailure n) -> safeExit n
+       ExitException ExitSuccess     -> exit 0
+       ExitException (ExitFailure n) -> exit n
 
        other -> do
           reportError other
-          safeExit 1
+          exit 1
           
 
 reportStackOverflow :: IO a
@@ -104,6 +127,12 @@ safeExit r = unsafeCoerce# (shutdownHaskellAndExit r)
 
 -- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
 -- re-enter Haskell land through finalizers.
-foreign import ccall "shutdownHaskellAndExit" 
+foreign import ccall "Rts.h shutdownHaskellAndExit"
   shutdownHaskellAndExit :: Int -> IO ()
+
+fastExit :: Int -> IO a
+fastExit r = unsafeCoerce# (stg_exit (fromIntegral r))
+
+foreign import ccall "Rts.h stg_exit"
+  stg_exit :: CInt -> IO ()
 \end{code}