Commit 1f3a7730 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

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.
parent 08a9d734
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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<size> 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<size> 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.
......
......@@ -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
......
......@@ -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
......
......@@ -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 ;
......
......@@ -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:",
......
......@@ -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
......@@ -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
--
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment