X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FPanic.lhs;h=f2e63129b48425392bbd826c087068b93d7d3427;hb=f9cde00b2e1a078e433af81bf9021a96cc613976;hp=95878c4f52e598b6146553f78ec372c2c222988d;hpb=67cb409159fa9136dff942b8baaec25909416022;p=ghc-hetmet.git diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 95878c4..f2e6312 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -9,22 +9,16 @@ It's hard to put these functions anywhere else without causing some unnecessary loops in the module dependency graph. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module Panic ( - GhcException(..), showGhcException, ghcError, progName, + GhcException(..), showGhcException, throwGhcException, handleGhcException, + ghcError, progName, pgmError, - panic, panic#, assertPanic, trace, + panic, panicFastInt, assertPanic, trace, Exception.Exception(..), showException, try, tryJust, tryMost, tryUser, - catchJust, ioErrors, throwTo, + catchJust, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -38,17 +32,16 @@ import FastTypes import System.Posix.Signals #endif /* mingw32_HOST_OS */ -#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 603 +#if defined(mingw32_HOST_OS) import GHC.ConsoleHandler #endif -import Control.Exception +import Exception import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar ) import Data.Dynamic -import qualified Control.Exception as Exception import Debug.Trace ( trace ) import System.IO.Unsafe ( unsafePerformIO ) -import System.IO.Error ( isUserError ) +import System.IO.Error hiding ( try ) import System.Exit import System.Environment \end{code} @@ -57,7 +50,11 @@ 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 -- @@ -79,21 +76,34 @@ 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) {-# NOINLINE progName #-} +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 + showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e showsPrec _ e = showString progName . showString ": " . showGhcException e +showGhcException :: GhcException -> String -> String showGhcException (UsageError str) = showString str . showChar '\n' . showString short_usage showGhcException (PhaseFailed phase code) @@ -119,31 +129,40 @@ showGhcException (Panic s) ++ s ++ "\n\n" ++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n") -#if __GLASGOW_HASKELL__ < 603 -myMkTyConApp = mkAppTy -#else -myMkTyConApp = mkTyConApp +throwGhcException :: GhcException -> a +#if __GLASGOW_HASKELL__ < 609 +throwGhcException = Exception.throwDyn +#else +throwGhcException = Exception.throw #endif +handleGhcException :: (GhcException -> IO a) -> IO a -> IO a +#if __GLASGOW_HASKELL__ < 609 +handleGhcException = flip Exception.catchDyn +#else +handleGhcException = Exception.handle +#endif + +ghcExceptionTc :: TyCon ghcExceptionTc = mkTyCon "GhcException" {-# NOINLINE ghcExceptionTc #-} instance Typeable GhcException where - typeOf _ = myMkTyConApp ghcExceptionTc [] + typeOf _ = mkTyConApp ghcExceptionTc [] \end{code} Panics and asserts. \begin{code} panic, pgmError :: String -> a -panic x = trace ("Panic (" ++ x ++ ")") (Exception.throwDyn (Panic x)) -pgmError x = Exception.throwDyn (ProgramError x) +panic x = throwGhcException (Panic x) +pgmError x = throwGhcException (ProgramError x) -- #-versions because panic can't return an unboxed int, and that's -- what TAG_ is with GHC at the moment. Ugh. (Simon) -- No, man -- Too Beautiful! (Will) -panic# :: String -> FastInt -panic# s = case (panic s) of () -> _ILIT 0 +panicFastInt :: String -> FastInt +panicFastInt s = case (panic s) of () -> _ILIT(0) assertPanic :: String -> Int -> a assertPanic file line = @@ -156,6 +175,7 @@ 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 @@ -167,16 +187,57 @@ tryMost action = do r <- try action; filter r _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 + -- 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 + -- 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 -\end{code} +#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 exception in the target thread. The current target thread is @@ -187,7 +248,11 @@ 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 -> @@ -199,7 +264,7 @@ installSignalHandlers = do installHandler sigQUIT (Catch interrupt) Nothing installHandler sigINT (Catch interrupt) Nothing return () -#elif __GLASGOW_HASKELL__ >= 603 +#else -- GHC 6.3+ has support for console events on Windows -- NOTE: running GHCi under a bash shell for some reason requires -- you to press Ctrl-Break rather than Ctrl-C to provoke @@ -211,8 +276,6 @@ installSignalHandlers = do installHandler (Catch sig_handler) return () -#else - return () -- nothing #endif {-# NOINLINE interruptTargetThread #-}