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
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}
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
-}
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).
-}
-- 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, () #)
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.
#include "HsBaseConfig.h"
-import Control.OldException as Old
+import Control.Exception
import Data.Maybe
import Control.Concurrent.MVar
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,
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 ()
-- 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
-- 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
-- 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
-- (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
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}
projects / ghc-base.git / commitdiff