From 1f3a7730cd7f831344d2a3b74a0ce700c382e858 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Fri, 3 Oct 2008 14:02:16 +0000 Subject: [PATCH] Use an extensible-exceptions package when bootstrapping Ifdefs for whether we had extensible exceptions or not were spreading through GHC's source, and things would only have got worse for the next 2-3 years, so instead we now use an implementation of extensible exceptions built on top of the old exception type. --- compiler/ghc.cabal.in | 5 ++-- compiler/ghci/InteractiveUI.hs | 20 ++----------- compiler/main/ErrUtils.lhs | 10 ------- compiler/main/GHC.hs | 25 ++-------------- compiler/main/HscTypes.lhs | 50 ------------------------------- compiler/main/InteractiveEval.hs | 24 ++------------- compiler/typecheck/TcRnMonad.lhs | 4 --- compiler/typecheck/TcSplice.lhs | 20 +++---------- compiler/utils/Exception.hs | 46 +++------------------------- compiler/utils/IOEnv.hs | 4 --- compiler/utils/Panic.lhs | 61 ++++---------------------------------- libraries/Makefile | 4 +++ packages | 1 + 13 files changed, 30 insertions(+), 244 deletions(-) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 7596dde..bf077aa 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -94,8 +94,9 @@ Library if flag(stage1) Include-Dirs: stage1 - if impl(ghc < 6.9) - Extensions: PatternSignatures + if impl(ghc < 6.9) + Build-Depends: extensible-exceptions + Extensions: PatternSignatures else Include-Dirs: stage2plus Install-Includes: HsVersions.h, ghc_boot_platform.h diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index b1baecd..b5d66a1 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -85,7 +85,6 @@ import System.Directory import System.IO import System.IO.Error as IO import Data.Char -import Data.Dynamic import Data.Array import Control.Monad as Monad import Text.Printf @@ -1820,28 +1819,15 @@ handler exception = do ghciHandle handler (showException exception >> return False) showException :: SomeException -> GHCi () -#if __GLASGOW_HASKELL__ < 609 -showException (DynException dyn) = - case fromDynamic dyn of - Nothing -> io (putStrLn ("*** Exception: (unknown)")) - Just Interrupted -> io (putStrLn "Interrupted.") - Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError - Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto - Just other_ghc_ex -> io (print other_ghc_ex) - -showException other_exception - = io (putStrLn ("*** Exception: " ++ show other_exception)) -#else -showException (SomeException e) = - io $ case cast e of +showException se = + io $ case fromException se of Just Interrupted -> putStrLn "Interrupted." -- omit the location for CmdLineError: Just (CmdLineError s) -> putStrLn s -- ditto: Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "") Just other_ghc_ex -> print other_ghc_ex - Nothing -> putStrLn ("*** Exception: " ++ show e) -#endif + Nothing -> putStrLn ("*** Exception: " ++ show se) ----------------------------------------------------------------------------- -- recursive exception handlers diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 7f5914e..d98fddb 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -83,26 +83,16 @@ data ErrMsg = ErrMsg { -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic -- whether to qualify an External Name) at the error occurrence -#if __GLASGOW_HASKELL__ >= 609 instance Exception ErrMsg -#endif instance Show ErrMsg where show em = showSDoc (errMsgShortDoc em) throwErrMsg :: ErrMsg -> a -#if __GLASGOW_HASKELL__ < 609 -throwErrMsg = throwDyn -#else throwErrMsg = throw -#endif handleErrMsg :: ExceptionMonad m => (ErrMsg -> m a) -> m a -> m a -#if __GLASGOW_HASKELL__ < 609 -handleErrMsg = flip gcatchDyn -#else handleErrMsg = ghandle -#endif -- So we can throw these things as exceptions errMsgTc :: TyCon diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index f2f97d8..3d8ade9 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -298,9 +298,6 @@ import Data.IORef import System.FilePath import System.IO import System.IO.Error ( try, isDoesNotExistError ) -#if __GLASGOW_HASKELL__ >= 609 -import Data.Typeable (cast) -#endif import Prelude hiding (init) @@ -314,38 +311,22 @@ import Prelude hiding (init) defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a defaultErrorHandler dflags inner = -- top-level exception handler: any unrecognised exception is a compiler bug. -#if __GLASGOW_HASKELL__ < 609 ghandle (\exception -> liftIO $ do hFlush stdout - case exception of - -- an IO exception probably isn't our fault, so don't panic - IOException _ -> - fatalErrorMsg dflags (text (show exception)) - AsyncException StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - ExitException _ -> throw exception - _ -> - fatalErrorMsg dflags (text (show (Panic (show exception)))) - exitWith (ExitFailure 1) - ) $ -#else - ghandle (\(SomeException exception) -> liftIO $ do - hFlush stdout - case cast exception of + case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> fatalErrorMsg dflags (text (show ioe)) - _ -> case cast exception of + _ -> case fromException exception of Just StackOverflow -> fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") - _ -> case cast exception of + _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> fatalErrorMsg dflags (text (show (Panic (show exception)))) exitWith (ExitFailure 1) ) $ -#endif -- program errors: messages with locations attached. Sometimes it is -- convenient to just throw these as exceptions. diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 83dda3f..343e75d 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -146,11 +146,7 @@ import MonadUtils import Bag ( emptyBag, unionBags, isEmptyBag ) import Data.Dynamic ( Typeable ) import qualified Data.Dynamic as Dyn -#if __GLASGOW_HASKELL__ < 609 -import Data.Dynamic ( toDyn, fromDyn, fromDynamic ) -#else import Bag ( bagToList ) -#endif import ErrUtils ( ErrorMessages, WarningMessages, Messages ) import System.FilePath @@ -181,8 +177,6 @@ mkSrcErr :: ErrorMessages -> SourceError srcErrorMessages :: SourceError -> ErrorMessages mkApiErr :: SDoc -> GhcApiError -#if __GLASGOW_HASKELL__ >= 609 - -- | A source error is an error that is caused by one or more errors in the -- source code. A 'SourceError' is thrown by many functions in the -- compilation pipeline. Inside GHC these errors are merely printed via @@ -242,43 +236,6 @@ instance Exception GhcApiError mkApiErr = GhcApiError -#else ------------------------------------------------------------------------- --- implementation for bootstrapping without extensible exceptions - -data SourceException = SourceException ErrorMessages -sourceExceptionTc :: Dyn.TyCon -sourceExceptionTc = Dyn.mkTyCon "SourceException" -{-# NOINLINE sourceExceptionTc #-} -instance Typeable SourceException where - typeOf _ = Dyn.mkTyConApp sourceExceptionTc [] - --- Source error has to look like a normal exception. Throwing a DynException --- directly would not allow us to use the Exception monad. We also cannot --- make it part of GhcException as that would lead to circular imports. - -type SourceError = Exception -type GhcApiError = Exception - -mkSrcErr msgs = DynException . toDyn $ SourceException msgs - -mkApiErr = IOException . userError . showSDoc - -srcErrorMessages (DynException ms) = - let SourceException msgs = (fromDyn ms (panic "SourceException expected")) - in msgs -srcErrorMessages _ = panic "SourceError expected" - -handleSourceError :: ExceptionMonad m => (Exception -> m a) -> m a -> m a -handleSourceError handler act = - gcatch act - (\e -> case e of - DynException dyn - | Just (SourceException _) <- fromDynamic dyn - -> handler e - _ -> throw e) -#endif - -- | A monad that allows logging of warnings. class Monad m => WarnLogMonad m where setWarnings :: WarningMessages -> m () @@ -345,10 +302,6 @@ instance MonadIO Ghc where instance ExceptionMonad Ghc where gcatch act handle = Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s -#if __GLASGOW_HASKELL__ < 609 - gcatchDyn act handler = - Ghc $ \s -> unGhc act s `gcatchDyn` \e -> unGhc (handler e) s -#endif instance WarnLogMonad Ghc where setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns -- | Return 'Warnings' accumulated so far. @@ -378,9 +331,6 @@ instance MonadIO m => MonadIO (GhcT m) where instance ExceptionMonad m => ExceptionMonad (GhcT m) where gcatch act handle = GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s -#if __GLASGOW_HASKELL__ < 609 - gcatchDyn _act _handler = error "cannot use GhcT in stage1" -#endif instance MonadIO m => WarnLogMonad (GhcT m) where setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index e5d91c9..9fe7504 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -350,32 +350,13 @@ sandboxIO dflags statusMVar thing = -- not "Interrupted", we unset the exception flag before throwing. -- rethrow :: DynFlags -> IO a -> IO a -#if __GLASGOW_HASKELL__ < 609 -rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn - case e of - -- If -fbreak-on-error, we break unconditionally, - -- but with care of not breaking twice - _ | dopt Opt_BreakOnError dflags && - not(dopt Opt_BreakOnException dflags) - -> poke exceptionFlag 1 - - -- If it is an "Interrupted" exception, we allow - -- a possible break by way of -fbreak-on-exception - DynException d | Just Interrupted <- fromDynamic d - -> return () - - -- In any other case, we don't want to break - _ -> poke exceptionFlag 0 - - Exception.throwIO e -#else -rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do +rethrow dflags io = Exception.catch io $ \se -> do -- If -fbreak-on-error, we break unconditionally, -- but with care of not breaking twice if dopt Opt_BreakOnError dflags && not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 - else case cast e of + else case fromException se of -- If it is an "Interrupted" exception, we allow -- a possible break by way of -fbreak-on-exception Just Interrupted -> return () @@ -383,7 +364,6 @@ rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do _ -> poke exceptionFlag 0 Exception.throwIO se -#endif withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index a2474c1..1d562e3 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -543,11 +543,7 @@ discardWarnings thing_inside \begin{code} -#if __GLASGOW_HASKELL__ < 609 -try_m :: TcRn r -> TcRn (Either Exception r) -#else try_m :: TcRn r -> TcRn (Either IOException r) -#endif -- Does try_m, with a debug-trace on failure try_m thing = do { mb_r <- tryM thing ; diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 7139fa8..6d33b16 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -63,7 +63,6 @@ import Maybe import BasicTypes import Panic import FastString -import Data.Typeable (cast) import Exception import qualified Language.Haskell.TH as TH @@ -71,11 +70,7 @@ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) -#if __GLASGOW_HASKELL__ < 609 -import qualified Exception ( userErrors ) -#else import System.IO.Error -#endif \end{code} Note [Template Haskell levels] @@ -599,24 +594,17 @@ runMeta convert expr ; case either_tval of Right v -> return v -#if __GLASGOW_HASKELL__ < 609 - Left exn | Just s <- Exception.userErrors exn - , s == "IOEnv failure" - -> failM -- Error already in Tc monad - | otherwise -> failWithTc (mk_msg "run" exn) -- Exception -#else - Left (SomeException exn) -> - case cast exn of + Left se -> + case fromException se of Just (ErrorCall "IOEnv failure") -> failM -- Error already in Tc monad _ -> - case cast exn of + case fromException se of Just ioe | isUserError ioe && (ioeGetErrorString ioe == "IOEnv failure") -> failM -- Error already in Tc monad - _ -> failWithTc (mk_msg "run" exn) -- Exception -#endif + _ -> failWithTc (mk_msg "run" se) -- Exception }}} where mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index 8d5d438..3242292 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -7,40 +7,21 @@ module Exception where import Prelude hiding (catch) -import Control.Exception #if __GLASGOW_HASKELL__ < 609 -import Data.Typeable ( Typeable ) - -type SomeException = Exception - -onException :: IO a -> IO () -> IO a -onException io what = io `catch` \e -> do what - throw e +import Control.Exception.Extensible as Control.Exception +#else +import Control.Exception #endif catchIO :: IO a -> (IOException -> IO a) -> IO a -#if __GLASGOW_HASKELL__ >= 609 catchIO = catch -#else -catchIO io handler = io `catch` handler' - where handler' (IOException ioe) = handler ioe - handler' e = throw e -#endif handleIO :: (IOException -> IO a) -> IO a -> IO a handleIO = flip catchIO tryIO :: IO a -> IO (Either IOException a) -#if __GLASGOW_HASKELL__ >= 609 tryIO = try -#else -tryIO io = do ei <- try io - case ei of - Right v -> return (Right v) - Left (IOException ioe) -> return (Left ioe) - Left e -> throwIO e -#endif -- | A monad that can catch exceptions. A minimal definition -- requires a definition of 'gcatch'. @@ -51,12 +32,7 @@ tryIO io = do ei <- try io class Monad m => ExceptionMonad m where -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary -- exception handling monad instead of just 'IO'. -#if __GLASGOW_HASKELL__ >= 609 gcatch :: Exception e => m a -> (e -> m a) -> m a -#else - gcatch :: m a -> (Exception -> m a) -> m a - gcatchDyn :: Typeable e => m a -> (e -> m a) -> m a -#endif -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary -- exception handling monad instead of just 'IO'. @@ -79,28 +55,17 @@ class Monad m => ExceptionMonad m where instance ExceptionMonad IO where gcatch = catch -#if __GLASGOW_HASKELL__ < 609 - gcatchDyn = catchDyn -#endif gbracket = bracket gfinally = finally -#if __GLASGOW_HASKELL__ >= 609 gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) -#else -gtry :: (ExceptionMonad m) => m a -> m (Either Exception a) -#endif gtry act = gcatch (act >>= \a -> return (Right a)) (\e -> return (Left e)) -- | Generalised version of 'Control.Exception.handle', allowing an arbitrary -- exception handling monad instead of just 'IO'. -#if __GLASGOW_HASKELL__ >= 609 ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a -#else -ghandle :: (ExceptionMonad m) => (Exception -> m a) -> m a -> m a -#endif ghandle = flip gcatch -- | Always executes the first argument. If this throws an exception the @@ -108,8 +73,5 @@ ghandle = flip gcatch gonException :: (ExceptionMonad m) => m a -> m b -> m a gonException ioA cleanup = ioA `gcatch` \e -> do cleanup -#if __GLASGOW_HASKELL__ >= 609 throw (e :: SomeException) -#else - throw e -#endif + diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 394a1c8..9332a8b 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -95,11 +95,7 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) --------------------------- -#if __GLASGOW_HASKELL__ < 609 -tryM :: IOEnv env r -> IOEnv env (Either Exception r) -#else tryM :: IOEnv env r -> IOEnv env (Either IOException r) -#endif -- Reflect UserError exceptions (only) into IOEnv monad -- Other exceptions are not caught; they are simply propagated as exns -- diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 0e049b0..e6c385c 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, tryUser, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -50,11 +49,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 +71,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 +80,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 +115,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,62 +152,40 @@ 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 IOException a) tryUser io = do ei <- try io case ei of Right v -> return (Right v) - Left se@(SomeException ex) -> - case cast ex of + Left se -> + case fromException se of Just ioe | isUserError ioe -> return (Left ioe) _ -> throw se -#endif \end{code} Standard signal handlers for catching ^C, which just throw an @@ -242,11 +197,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 -> diff --git a/libraries/Makefile b/libraries/Makefile index 43220f6..01dd45b 100644 --- a/libraries/Makefile +++ b/libraries/Makefile @@ -135,6 +135,10 @@ cabal-bin: cabal-bin.hs bootstrapping.conf: cabal-bin echo "[]" > $@.tmp + -cd extensible-exceptions && $(CABAL) clean --distpref=dist-bootstrapping + cd extensible-exceptions && $(CABAL) configure --distpref=dist-bootstrapping --with-compiler=$(GHC) --with-hc-pkg=$(GHC_PKG) --package-db=$(HERE_ABS)/$@.tmp + cd extensible-exceptions && $(CABAL) build --distpref=dist-bootstrapping + cd extensible-exceptions && $(CABAL) install --distpref=dist-bootstrapping --inplace -cd filepath && $(CABAL) clean --distpref=dist-bootstrapping cd filepath && $(CABAL) configure --distpref=dist-bootstrapping --with-compiler=$(GHC) --with-hc-pkg=$(GHC_PKG) --package-db=$(HERE_ABS)/$@.tmp cd filepath && $(CABAL) build --distpref=dist-bootstrapping diff --git a/packages b/packages index 547e4bf..c12d7a7 100644 --- a/packages +++ b/packages @@ -27,6 +27,7 @@ libraries/Cabal packages/Cabal darcs libraries/containers packages/containers darcs libraries/directory packages/directory darcs libraries/editline packages/editline darcs +libraries/extensible-exceptions packages/extensible-exceptions darcs libraries/filepath packages/filepath darcs libraries/ghc-prim packages/ghc-prim darcs libraries/haskell98 packages/haskell98 darcs -- 1.7.10.4