From: Ian Lynagh <igloo@earth.li>
Date: Thu, 31 Jul 2008 15:35:53 +0000 (+0000)
Subject: TopHandler now uses the new extensible exceptions
X-Git-Tag: 6_10_branch_has_been_forked~113
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=34a1ed6a7c6639b49ba2fee733c2c7387af6a2e0;p=ghc-base.git

TopHandler now uses the new extensible exceptions
---

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index e6197d9..1b61036 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -111,7 +111,7 @@ import {-# SOURCE #-} GHC.TopHandler ( reportError, reportStackOverflow )
 import Data.Maybe
 
 import GHC.Base
-import GHC.IOBase hiding ( Exception, BlockedOnDeadMVar, BlockedIndefinitely )
+import GHC.IOBase
 import GHC.Num          ( Num(..) )
 import GHC.Real         ( fromIntegral, div )
 #ifndef mingw32_HOST_OS
@@ -121,13 +121,12 @@ import GHC.Base         ( Int(..) )
 import GHC.Read         ( Read )
 import GHC.Enum         ( Enum )
 #endif
-import GHC.Exception    ( throw )
+import GHC.Exception    ( SomeException(..), throw )
 import GHC.Pack         ( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
 import GHC.Show         ( Show(..), showString )
 import Data.Typeable
-import Control.OldException hiding (throwTo)
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -237,20 +236,22 @@ numCapabilities = unsafePerformIO $  do
 
 foreign import ccall "&n_capabilities" n_capabilities :: Ptr CInt
 
-childHandler :: Exception -> IO ()
+childHandler :: SomeException -> IO ()
 childHandler err = catchException (real_handler err) childHandler
 
-real_handler :: Exception -> IO ()
-real_handler ex =
-  case ex of
-        -- ignore thread GC and killThread exceptions:
-        BlockedOnDeadMVar            -> return ()
-        BlockedIndefinitely          -> return ()
-        AsyncException ThreadKilled  -> return ()
-
-        -- report all others:
-        AsyncException StackOverflow -> reportStackOverflow
-        other       -> reportError other
+real_handler :: SomeException -> IO ()
+real_handler se@(SomeException ex) =
+  -- ignore thread GC and killThread exceptions:
+  case cast ex of
+  Just BlockedOnDeadMVar                -> return ()
+  _ -> case cast ex of
+       Just BlockedIndefinitely         -> return ()
+       _ -> case cast ex of
+            Just ThreadKilled           -> return ()
+            _ -> case cast ex of
+                 -- report all others:
+                 Just StackOverflow     -> reportStackOverflow
+                 _                      -> reportError se
 
 {- | 'killThread' terminates the given thread (GHC only).
 Any work already done by the thread isn\'t
@@ -263,7 +264,7 @@ terms of 'throwTo':
 
 -}
 killThread :: ThreadId -> IO ()
-killThread tid = throwTo tid (AsyncException ThreadKilled)
+killThread tid = throwTo tid (toException ThreadKilled)
 
 {- | 'throwTo' raises an arbitrary exception in the target thread (GHC only).
 
@@ -296,7 +297,7 @@ a pending 'throwTo'.  This is arguably undesirable behaviour.
 
  -}
 -- XXX This is duplicated in Control.{Old,}Exception
-throwTo :: ThreadId -> Exception -> IO ()
+throwTo :: ThreadId -> SomeException -> IO ()
 throwTo (ThreadId id) ex = IO $ \ s ->
    case (killThread# id ex s) of s1 -> (# s1, () #)
 
@@ -495,7 +496,7 @@ orElse :: STM a -> STM a -> STM a
 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 
 -- |Exception handling within STM actions.
-catchSTM :: STM a -> (Exception -> STM a) -> STM a
+catchSTM :: STM a -> (SomeException -> STM a) -> STM a
 catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
 
 -- | Low-level primitive on which always and alwaysSucceeds are built.
diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index e2da473..236f5ff 100644
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -25,7 +25,7 @@ module GHC.TopHandler (
 
 #include "HsBaseConfig.h"
 
-import Control.OldException as Old
+import Control.Exception
 import Data.Maybe
 import Control.Concurrent.MVar
 
@@ -37,8 +37,9 @@ import GHC.Err
 import GHC.Num
 import GHC.Real
 import {-# SOURCE #-} GHC.Handle
-import GHC.IOBase hiding (Exception)
+import GHC.IOBase
 import GHC.Weak
+import Data.Typeable
 
 -- | 'runMainIO' is wrapped around 'Main.main' (or whatever main is
 -- called in the program).  It catches otherwise uncaught exceptions,
@@ -52,11 +53,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
-    `Old.catch`
+    `catch`
       topHandler
 
 install_interrupt_handler :: IO () -> IO ()
@@ -107,7 +108,7 @@ mkWeakThreadId t@(ThreadId t#) = IO $ \s ->
 -- program.
 --
 runIO :: IO a -> IO a
-runIO main = Old.catch 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
@@ -122,7 +123,7 @@ runIO main = Old.catch main topHandler
 -- safeExit.  There is a race to shut down between the main and child threads.
 --
 runIOFastExit :: IO a -> IO a
-runIOFastExit main = Old.catch 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
@@ -130,12 +131,12 @@ runIOFastExit main = Old.catch main topHandlerFastExit
 -- are used to export Haskell functions with non-IO types.
 --
 runNonIO :: a -> IO a
-runNonIO a = Old.catch (a `seq` return a) topHandler
+runNonIO a = catch (a `seq` return a) topHandler
 
-topHandler :: Exception -> IO a
-topHandler err = Old.catch (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
 
@@ -143,29 +144,29 @@ 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 :: SomeException -> IO a
 reportError ex = do
    handler <- getUncaughtExceptionHandler
    handler ex
diff --git a/GHC/TopHandler.lhs-boot b/GHC/TopHandler.lhs-boot
index 3c5fb1b..8a5304b 100644
--- a/GHC/TopHandler.lhs-boot
+++ b/GHC/TopHandler.lhs-boot
@@ -3,8 +3,8 @@
 module GHC.TopHandler ( reportError, reportStackOverflow ) where
 
 import GHC.IOBase (IO)
-import Control.OldException (Exception)
+import Control.Exception (SomeException)
 
-reportError :: Exception -> IO a
+reportError :: SomeException -> IO a
 reportStackOverflow :: IO a
 \end{code}