X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FPanic.lhs;h=4f78aabc24b16b2746d5becc2079ca6e74366e96;hb=d436c70d43fb905c63220040168295e473f4b90a;hp=6f7a4a801876deb81c487935a7ed95ae3ff95436;hpb=73e0b2a1af83297d85ca1746f1ffe24d50339699;p=ghc-hetmet.git diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 6f7a4a8..4f78aab 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -17,8 +17,7 @@ module Panic panic, panicFastInt, assertPanic, trace, - Exception.Exception(..), showException, try, tryJust, tryMost, tryUser, - catchJust, throwTo, + Exception.Exception(..), showException, try, tryMost, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -41,7 +40,6 @@ import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar ) import Data.Dynamic import Debug.Trace ( trace ) import System.IO.Unsafe ( unsafePerformIO ) -import System.IO.Error hiding ( try ) import System.Exit import System.Environment \end{code} @@ -50,11 +48,7 @@ GHC's own exception type. \begin{code} ghcError :: GhcException -> a -#if __GLASGOW_HASKELL__ >= 609 ghcError e = Exception.throw e -#else -ghcError e = Exception.throwDyn e -#endif -- error messages all take the form -- @@ -76,9 +70,7 @@ data GhcException | ProgramError String -- error in the user's code, probably deriving Eq -#if __GLASGOW_HASKELL__ >= 609 instance Exception GhcException -#endif progName :: String progName = unsafePerformIO (getProgName) @@ -87,16 +79,8 @@ progName = unsafePerformIO (getProgName) short_usage :: String short_usage = "Usage: For basic information, try the `--help' option." -#if __GLASGOW_HASKELL__ < 609 -showException :: Exception.Exception -> String --- Show expected dynamic exceptions specially -showException (Exception.DynException d) | Just e <- fromDynamic d - = show (e::GhcException) -showException other_exn = show other_exn -#else showException :: Exception e => e -> String showException = show -#endif instance Show GhcException where showsPrec _ e@(ProgramError _) = showGhcException e @@ -130,18 +114,10 @@ showGhcException (Panic s) ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n") throwGhcException :: GhcException -> a -#if __GLASGOW_HASKELL__ < 609 -throwGhcException = Exception.throwDyn -#else throwGhcException = Exception.throw -#endif handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a -#if __GLASGOW_HASKELL__ < 609 -handleGhcException = flip gcatchDyn -#else handleGhcException = ghandle -#endif ghcExceptionTc :: TyCon ghcExceptionTc = mkTyCon "GhcException" @@ -175,68 +151,25 @@ assertPanic file line = -- exceptions. Used when we want soft failures when reading interface -- files, for example. -#if __GLASGOW_HASKELL__ < 609 -tryMost :: IO a -> IO (Either Exception.Exception a) -tryMost action = do r <- try action; filter r - where - filter (Left e@(Exception.DynException d)) - | Just ghc_ex <- fromDynamic d - = case ghc_ex of - Interrupted -> Exception.throw e - Panic _ -> Exception.throw e - _other -> return (Left e) - filter other - = return other -#else -- XXX I'm not entirely sure if this is catching what we really want to catch tryMost :: IO a -> IO (Either SomeException a) tryMost action = do r <- try action case r of - Left se@(SomeException e) -> - case cast e of + Left se -> + case fromException se of -- Some GhcException's we rethrow, Just Interrupted -> throwIO se Just (Panic _) -> throwIO se -- others we return Just _ -> return (Left se) Nothing -> - case cast e of + case fromException se of -- All IOExceptions are returned Just (_ :: IOException) -> return (Left se) -- Anything else is rethrown Nothing -> throwIO se Right v -> return (Right v) -#endif - --- | tryUser is like try, but catches only UserErrors. --- These are the ones that are thrown by the TcRn monad --- to signal an error in the program being compiled -#if __GLASGOW_HASKELL__ < 609 -tryUser :: IO a -> IO (Either Exception.Exception a) -tryUser action = tryJust tc_errors action - where - tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e - tc_errors _other = Nothing -#else -tryUser :: IO a -> IO (Either ErrorCall a) -tryUser io = - do ei <- try io - case ei of - Right v -> return (Right v) - Left se@(SomeException ex) -> - case cast ex of - -- Look for good old fashioned ErrorCall's - Just errorCall -> return (Left errorCall) - Nothing -> - case cast ex of - -- And also for user errors in IO errors. - -- Sigh. - Just ioe - | isUserError ioe -> - return (Left (ErrorCall (ioeGetErrorString ioe))) - _ -> throw se -#endif \end{code} Standard signal handlers for catching ^C, which just throw an @@ -248,11 +181,7 @@ installSignalHandlers. installSignalHandlers :: IO () installSignalHandlers = do let -#if __GLASGOW_HASKELL__ < 609 - interrupt_exn = Exception.DynException (toDyn Interrupted) -#else interrupt_exn = (toException Interrupted) -#endif interrupt = do withMVar interruptTargetThread $ \targets -> @@ -261,8 +190,8 @@ installSignalHandlers = do (thread:_) -> throwTo thread interrupt_exn -- #if !defined(mingw32_HOST_OS) - installHandler sigQUIT (Catch interrupt) Nothing - installHandler sigINT (Catch interrupt) Nothing + _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigINT (Catch interrupt) Nothing return () #else -- GHC 6.3+ has support for console events on Windows