add GHC.Conc.runSparks (required by GHC patch "Run sparks in batches")

[ghc-base.git] / GHC / TopHandler.lhs

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index c0fcd6b..dffba02 100644 (file)
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -1,4 +1,6 @@
 \begin{code}
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
@@ -24,20 +26,20 @@ module GHC.TopHandler (
 
 #include "HsBaseConfig.h"
 
-import Prelude
-
-import System.IO
 import Control.Exception
-import Control.Concurrent.MVar
+import Data.Maybe
 
 import Foreign
 import Foreign.C
+import GHC.Base
+import GHC.Conc hiding (throwTo)
+import GHC.Num
+import GHC.Real
+import GHC.Handle
 import GHC.IOBase
-import GHC.Exception    ( catchException )
-import GHC.Prim
-import GHC.Conc
 import GHC.Weak
-#ifdef mingw32_HOST_OS
+import Data.Typeable
+#if defined(mingw32_HOST_OS)
 import GHC.ConsoleHandler
 #endif
 
@@ -53,11 +55,11 @@ runMainIO main =
            m <- deRefWeak weak_tid 
            case m of
                Nothing  -> return ()
-               Just tid -> throwTo tid (AsyncException UserInterrupt)
+               Just tid -> throwTo tid (toException UserInterrupt)
       a <- main
       cleanUp
       return a
-    `catchException`
+    `catch`
       topHandler
 
 install_interrupt_handler :: IO () -> IO ()
@@ -77,13 +79,20 @@ install_interrupt_handler handler = do
 -- isn't available here.
 install_interrupt_handler handler = do
    let sig = CONST_SIGINT :: CInt
-   withMVar signalHandlerLock $ \_ ->
+   withSignalHandlerLock $
      alloca $ \p_sp -> do
        sptr <- newStablePtr handler
        poke p_sp sptr
        stg_sig_install sig STG_SIG_RST p_sp nullPtr
        return ()
 
+withSignalHandlerLock :: IO () -> IO ()
+withSignalHandlerLock io
+ = block $ do
+       takeMVar signalHandlerLock
+       catchAny (unblock io) (\e -> do putMVar signalHandlerLock (); throw e)
+       putMVar signalHandlerLock ()
+
 foreign import ccall unsafe
   stg_sig_install
        :: CInt                         -- sig no.
@@ -108,7 +117,7 @@ mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
 -- program.
 --
 runIO :: IO a -> IO a
-runIO main = catchException main topHandler
+runIO main = catch 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
@@ -123,7 +132,7 @@ runIO main = catchException main topHandler
 -- safeExit.  There is a race to shut down between the main and child threads.
 --
 runIOFastExit :: IO a -> IO a
-runIOFastExit main = catchException main topHandlerFastExit
+runIOFastExit main = catch main topHandlerFastExit
         -- NB. this is used by the testsuite driver
 
 -- | The same as 'runIO', but for non-IO computations.  Used for
@@ -131,12 +140,12 @@ runIOFastExit main = catchException main topHandlerFastExit
 -- are used to export Haskell functions with non-IO types.
 --
 runNonIO :: a -> IO a
-runNonIO a = catchException (a `seq` return a) topHandler
+runNonIO a = catch (a `seq` return a) topHandler
 
-topHandler :: Exception -> IO a
-topHandler err = catchException (real_handler safeExit err) topHandler
+topHandler :: SomeException -> IO a
+topHandler err = catch (real_handler safeExit err) topHandler
 
-topHandlerFastExit :: Exception -> IO a
+topHandlerFastExit :: SomeException -> IO a
 topHandlerFastExit err = 
   catchException (real_handler fastExit err) topHandlerFastExit
 
@@ -144,39 +153,25 @@ topHandlerFastExit err =
 -- (e.g. evaluating the string passed to 'error' might generate
 --  another error, etc.)
 --
-real_handler :: (Int -> IO a) -> Exception -> IO a
-real_handler exit exn =
+real_handler :: (Int -> IO a) -> SomeException -> IO a
+real_handler exit se@(SomeException exn) =
   cleanUp >>
-  case exn of
-        AsyncException StackOverflow -> do
+  case cast exn of
+      Just StackOverflow -> do
            reportStackOverflow
            exit 2
 
-        AsyncException UserInterrupt  -> exitInterrupted
+      Just UserInterrupt  -> exitInterrupted
 
-        -- only the main thread gets ExitException exceptions
-        ExitException ExitSuccess     -> exit 0
-        ExitException (ExitFailure n) -> exit n
+      _ -> case cast exn of
+           -- only the main thread gets ExitException exceptions
+           Just ExitSuccess     -> exit 0
+           Just (ExitFailure n) -> exit n
 
-        other -> do
-           reportError other
-           exit 1
+           _ -> do reportError se
+                   exit 1
            
 
-reportStackOverflow :: IO a
-reportStackOverflow = do callStackOverflowHook; return undefined
-
-reportError :: Exception -> IO a
-reportError ex = do
-   handler <- getUncaughtExceptionHandler
-   handler ex
-   return undefined
-
--- SUP: Are the hooks allowed to re-enter Haskell land?  If so, remove
--- the unsafe below.
-foreign import ccall unsafe "stackOverflow"
-        callStackOverflowHook :: IO ()
-
 -- try to flush stdout/stderr, but don't worry if we fail
 -- (these handles might have errors, and we don't want to go into
 -- an infinite loop).
@@ -185,9 +180,6 @@ cleanUp = do
   hFlush stdout `catchAny` \_ -> return ()
   hFlush stderr `catchAny` \_ -> return ()
 
-cleanUpAndExit :: Int -> IO a
-cleanUpAndExit r = do cleanUp; safeExit r
-
 -- we have to use unsafeCoerce# to get the 'IO a' result type, since the
 -- compiler doesn't let us declare that as the result type of a foreign export.
 safeExit :: Int -> IO a