From fb1b5b0773c7efd0fba32e580afd91f99b9fcc89 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 18 Sep 2002 10:51:02 +0000 Subject: [PATCH] [project @ 2002-09-18 10:51:01 by simonmar] Fix up exception handling when reading an interface file, and make it compile with 4.08.x again. GhcExceptions weren't being caught by readIface, so an error when reading an interface could be unintentionally fatal (errors should be soft when reading the old interface file for the current module). Also, the Interrupted exception should not be caught by readIface, because we want ^C to behave as normal when reading interface files (currently it causes an interface-file read error rather than interrupting the whole compiler). Some exception-related compatibility functions have been moved from Util to Panic. --- ghc/compiler/main/DriverMkDepend.hs | 4 ++-- ghc/compiler/main/SysTools.lhs | 12 ++-------- ghc/compiler/rename/RnHiFiles.lhs | 4 ++-- ghc/compiler/typecheck/TcRnTypes.lhs | 7 +----- ghc/compiler/utils/Panic.lhs | 42 ++++++++++++++++++++++++++++++++-- ghc/compiler/utils/Util.lhs | 15 ------------ 6 files changed, 47 insertions(+), 37 deletions(-) diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index e4d10db..607ba78 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.22 2002/09/13 15:02:34 simonpj Exp $ +-- $Id: DriverMkDepend.hs,v 1.23 2002/09/18 10:51:01 simonmar Exp $ -- -- GHC Driver -- @@ -31,7 +31,7 @@ import Monad ( when ) import Maybe ( isJust ) #if __GLASGOW_HASKELL__ <= 408 -import Util ( catchJust, ioErrors ) +import Panic ( catchJust, ioErrors ) #endif ------------------------------------------------------------------------------- diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index facf3fc..a6f7bf9 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -115,14 +115,6 @@ import SystemExts ( rawSystem ) #else import System ( system ) #endif - --- Make catch work on older GHCs -#if __GLASGOW_HASKELL__ > 408 -myCatch = Exception.catch -#else -myCatch = catchAllIO -#endif - \end{code} @@ -675,7 +667,7 @@ removeTmpFiles verb fs ("Deleting: " ++ unwords fs) (mapM_ rm fs) where - rm f = removeFile f `myCatch` + rm f = removeFile f `catch` (\_ignored -> when (verb >= 2) $ hPutStrLn stderr ("Warning: deleting non-existent " ++ f) @@ -737,7 +729,7 @@ traceCmd phase_name cmd_line action ; unless n $ do { -- And run it! - ; action `myCatch` handle_exn verb + ; action `catch` handle_exn verb }} where handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n") diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 931c5cf..76f636c 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -688,12 +688,12 @@ findHiFile mod_name hi_boot_file @readIface@ tries just the one file. \begin{code} -readIface :: Module -> String -> IsBootInterface -> TcRn m (Either IOError ParsedIface) +readIface :: Module -> String -> IsBootInterface -> TcRn m (Either Exception ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed readIface mod file_path is_hi_boot_file - = ioToTcRn_no_fail (read_iface mod file_path is_hi_boot_file) + = ioToTcRn (tryMost (read_iface mod file_path is_hi_boot_file)) read_iface mod file_path is_hi_boot_file | is_hi_boot_file -- Read ascii diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 8babf69..0b3cbda 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -9,7 +9,7 @@ module TcRnTypes( thenM, thenM_, returnM, failM, -- Non-standard operations - runTcRn, fixM, recoverM, ioToTcRn, ioToTcRn_no_fail, + runTcRn, fixM, recoverM, ioToTcRn, newMutVar, readMutVar, writeMutVar, getEnv, setEnv, updEnv, unsafeInterleaveM, @@ -173,11 +173,6 @@ Performing arbitrary I/O, plus the read/write var (for efficiency) ioToTcRn :: IO a -> TcRn m a ioToTcRn io = TcRn (\ env -> io) -ioToTcRn_no_fail :: IO a -> TcRn m (Either IOError a) --- Catch any IO error and embody it in the result -ioToTcRn_no_fail io = TcRn (\ env -> catch (io >>= \r -> return (Right r)) - (\ exn -> return (Left exn))) - newMutVar :: a -> TcRn m (TcRef a) newMutVar val = TcRn (\ env -> newIORef val) diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs index 1f677fc..c449997 100644 --- a/ghc/compiler/utils/Panic.lhs +++ b/ghc/compiler/utils/Panic.lhs @@ -13,7 +13,11 @@ module Panic ( GhcException(..), ghcError, progName, panic, panic#, assertPanic, trace, - showException, showGhcException, throwDyn + showException, showGhcException, throwDyn, tryMost, + +#if __GLASGOW_HASKELL__ <= 408 + catchJust, ioErrors, throwTo, +#endif ) where #include "HsVersions.h" @@ -22,7 +26,7 @@ import Config import FastTypes import DYNAMIC -import EXCEPTION +import EXCEPTION as Exception import TRACE ( trace ) import UNSAFE_IO ( unsafePerformIO ) @@ -121,3 +125,37 @@ assertPanic file line = throw (AssertionFailed ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) \end{code} + +\begin{code} +-- | tryMost is like try, but passes through Interrupted and Panic +-- exceptions. Used when we want soft failures when reading interface +-- files, for example. + +tryMost :: IO a -> IO (Either Exception a) +tryMost action = do r <- myTry action; filter r + where + filter (Left e@(DynException d)) + | Just ghc_ex <- fromDynamic d + = case ghc_ex of + Interrupted -> throw e + Panic _ -> throw e + _other -> return (Left e) + filter other + = return other + +#if __GLASGOW_HASKELL__ <= 408 +myTry = tryAllIO +#else +myTry = Exception.try +#endif +\end{code} + +Compatibility stuff: + +\begin{code} +#if __GLASGOW_HASKELL__ <= 408 +catchJust = catchIO +ioErrors = justIoErrors +throwTo = raiseInThread +#endif +\end{code} diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index d7b228e..119ae82 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -44,11 +44,6 @@ module Util ( unzipWith, global, - -#if __GLASGOW_HASKELL__ <= 408 - catchJust, ioErrors, throwTo -#endif - ) where #include "../includes/config.h" @@ -787,13 +782,3 @@ Global variables: global :: a -> IORef a global a = unsafePerformIO (newIORef a) \end{code} - -Compatibility stuff: - -\begin{code} -#if __GLASGOW_HASKELL__ <= 408 -catchJust = catchIO -ioErrors = justIoErrors -throwTo = raiseInThread -#endif -\end{code} -- 1.7.10.4