X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FPanic.lhs;h=4f78aabc24b16b2746d5becc2079ca6e74366e96;hp=95878c4f52e598b6146553f78ec372c2c222988d;hb=9d0c8f842e35dde3d570580cf62a32779f66a6de;hpb=67cb409159fa9136dff942b8baaec25909416022 diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 95878c4..4f78aab 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -9,22 +9,15 @@ 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, + Exception.Exception(..), showException, try, tryMost, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -38,17 +31,15 @@ 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.Exit import System.Environment \end{code} @@ -57,7 +48,7 @@ GHC's own exception type. \begin{code} ghcError :: GhcException -> a -ghcError e = Exception.throwDyn e +ghcError e = Exception.throw e -- error messages all take the form -- @@ -79,21 +70,24 @@ data GhcException | ProgramError String -- error in the user's code, probably deriving Eq +instance Exception GhcException + +progName :: String progName = unsafePerformIO (getProgName) {-# NOINLINE progName #-} +short_usage :: String short_usage = "Usage: For basic information, try the `--help' option." - -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 + +showException :: Exception e => e -> String +showException = show 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 +113,32 @@ 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 -#endif +throwGhcException :: GhcException -> a +throwGhcException = Exception.throw + +handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a +handleGhcException = ghandle +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,27 +151,26 @@ assertPanic file line = -- exceptions. Used when we want soft failures when reading interface -- files, for example. -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 - --- | 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 -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} +-- 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 -> + 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 fromException se of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) +\end{code} Standard signal handlers for catching ^C, which just throw an exception in the target thread. The current target thread is @@ -187,7 +181,7 @@ installSignalHandlers. installSignalHandlers :: IO () installSignalHandlers = do let - interrupt_exn = Exception.DynException (toDyn Interrupted) + interrupt_exn = (toException Interrupted) interrupt = do withMVar interruptTargetThread $ \targets -> @@ -196,10 +190,10 @@ 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 () -#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 +205,6 @@ installSignalHandlers = do installHandler (Catch sig_handler) return () -#else - return () -- nothing #endif {-# NOINLINE interruptTargetThread #-}