Follow changes in the base library

TopHandler now uses the new extensible exceptions module, so we
need to interact with it using the new types.

compiler/ghci/GhciMonad.hs

@@ -28,13 +28,11 @@ import StaticFlags
 
 import Data.Maybe
 import Numeric
-import Exception
 import Data.Array
 import Data.Char
 import Data.Int         ( Int64 )
 import Data.IORef
 import Data.List
-import Data.Typeable
 import System.CPUTime
 import System.Directory
 import System.Environment
@@ -140,9 +138,9 @@ instance Monad GHCi where
 instance Functor GHCi where
     fmap f m = m >>= return . f
 
-ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
-ghciHandleDyn h (GHCi m) = GHCi $ \s -> 
-   Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
+ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
+ghciHandleGhcException h (GHCi m) = GHCi $ \s -> 
+   handleGhcException (\e -> unGHCi (h e) s) (m s)
 
 getGHCiState :: GHCi GHCiState
 getGHCiState   = GHCi $ \r -> readIORef r

compiler/ghci/InteractiveUI.hs

@@ -468,7 +468,7 @@ runGHCi paths maybe_exprs = do
 interactiveLoop :: Bool -> Bool -> GHCi ()
 interactiveLoop is_tty show_prompt =
   -- Ignore ^C exceptions caught here
-  ghciHandleDyn (\e -> case e of 
+  ghciHandleGhcException (\e -> case e of 
 			Interrupted -> do
 #if defined(mingw32_HOST_OS)
 				io (putStrLn "")
@@ -504,7 +504,7 @@ checkPerms _ =
   return True
 #else
 checkPerms name =
-  Util.handle (\_ -> return False) $ do
+  handleIO (\_ -> return False) $ do
      st <- getFileStatus name
      me <- getRealUserID
      if fileOwner st /= me then do
@@ -650,7 +650,7 @@ queryQueue = do
 runCommands :: GHCi (Maybe String) -> GHCi ()
 runCommands = runCommands' handler
 
-runCommands' :: (Exception -> GHCi Bool) -- Exception handler
+runCommands' :: (SomeException -> GHCi Bool) -- Exception handler
              -> GHCi (Maybe String) -> GHCi ()
 runCommands' eh getCmd = do
   mb_cmd <- noSpace queryQueue
@@ -1822,14 +1822,15 @@ completeHomeModuleOrFile=completeNone
 -- raising another exception.  We therefore don't put the recursive
 -- handler arond the flushing operation, so if stderr is closed
 -- GHCi will just die gracefully rather than going into an infinite loop.
-handler :: Exception -> GHCi Bool
+handler :: SomeException -> GHCi Bool
 
 handler exception = do
   flushInterpBuffers
   io installSignalHandlers
   ghciHandle handler (showException exception >> return False)
 
-showException :: Exception -> GHCi ()
+showException :: SomeException -> GHCi ()
+#if __GLASGOW_HASKELL__ < 609
 showException (DynException dyn) =
   case fromDynamic dyn of
     Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
@@ -1840,6 +1841,17 @@ showException (DynException dyn) =
 
 showException other_exception
   = io (putStrLn ("*** Exception: " ++ show other_exception))
+#else
+showException (SomeException e) =
+  io $ case cast e 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
 
 -----------------------------------------------------------------------------
 -- recursive exception handlers
@@ -1848,7 +1860,7 @@ showException other_exception
 -- in an exception loop (eg. let a = error a in a) the ^C exception
 -- may never be delivered.  Thanks to Marcin for pointing out the bug.
 
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
+ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
 ghciHandle h (GHCi m) = GHCi $ \s -> 
    Exception.catch (m s) 
 	(\e -> unGHCi (ghciUnblock (h e)) s)
@@ -1856,7 +1868,7 @@ ghciHandle h (GHCi m) = GHCi $ \s ->
 ghciUnblock :: GHCi a -> GHCi a
 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 
-ghciTry :: GHCi a -> GHCi (Either Exception a)
+ghciTry :: GHCi a -> GHCi (Either SomeException a)
 ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s) 
 
 -- ----------------------------------------------------------------------------
@@ -2174,7 +2186,7 @@ findBreakByCoord mb_file (line, col) arr
 do_bold :: Bool
 do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
     where mTerm = System.Environment.getEnv "TERM"
-                  `Exception.catch` \_ -> return "TERM not set"
+                  `catchIO` \_ -> return "TERM not set"
 
 start_bold :: String
 start_bold = "\ESC[1m"

compiler/ghci/Linker.lhs

@@ -1131,7 +1131,7 @@ mkSOName root
 -- name. They are searched for in different paths than normal libraries.
 loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
 loadFramework extraPaths rootname
-   = do { either_dir <- Exception.try getHomeDirectory
+   = do { either_dir <- tryIO getHomeDirectory
         ; let homeFrameworkPath = case either_dir of
                                   Left _ -> []
                                   Right dir -> [dir ++ "/Library/Frameworks"]

compiler/main/DriverMkDepend.hs

@@ -31,6 +31,7 @@ import SrcLoc
 import Data.List
 import FastString
 
+import Exception
 import ErrUtils         ( debugTraceMsg, putMsg )
 
 import System.Exit      ( ExitCode(..), exitWith )
@@ -126,9 +127,9 @@ beginMkDependHS dflags = do
                         then return ()
                         else chuck
 
-           catchJust ioErrors slurp
+           catchIO slurp
                 (\e -> if isEOFError e then return () else ioError e)
-           catchJust ioErrors chuck
+           catchIO chuck
                 (\e -> if isEOFError e then return () else ioError e)
 
            return (Just makefile_hdl)
@@ -295,7 +296,7 @@ endMkDependHS dflags
                 hPutStrLn tmp_hdl l
                 slurp
 
-        catchJust ioErrors slurp
+        catchIO slurp
                 (\e -> if isEOFError e then return () else ioError e)
 
         hClose hdl

compiler/main/DriverPipeline.hs

@@ -1120,7 +1120,7 @@ runPhase_MoveBinary dflags input_fn dep_packages
            pvm_executable_base = "=" ++ input_fn
            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
         -- nuke old binary; maybe use configur'ed names for cp and rm?
-        Panic.try (removeFile pvm_executable)
+        tryIO (removeFile pvm_executable)
         -- move the newly created binary into PVM land
         copy dflags "copying PVM executable" input_fn pvm_executable
         -- generate a wrapper script for running a parallel prg under PVM

compiler/main/ErrUtils.lhs

@@ -8,7 +8,7 @@ module ErrUtils (
 	Message, mkLocMessage, printError,
 	Severity(..),
 
-	ErrMsg, WarnMsg,
+	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
 	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
@@ -44,6 +44,7 @@ import System.Exit	( ExitCode(..), exitWith )
 import Data.Dynamic
 import Data.List
 import System.IO
+import Exception
 
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
@@ -81,6 +82,27 @@ 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 :: (ErrMsg -> IO a) -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 609
+handleErrMsg = flip catchDyn
+#else
+handleErrMsg = handle
+#endif
+
 -- So we can throw these things as exceptions
 errMsgTc :: TyCon
 errMsgTc = mkTyCon "ErrMsg"

compiler/main/GHC.hs

@@ -274,11 +274,14 @@ import qualified Data.List as List
 import Control.Monad
 import System.Exit	( exitWith, ExitCode(..) )
 import System.Time	( ClockTime, getClockTime )
-import Exception hiding (handle)
+import Exception
 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)
 
 
@@ -290,33 +293,55 @@ import Prelude hiding (init)
 -- the top level of your program.  The default handlers output the error
 -- message(s) to stderr and exit cleanly.
 defaultErrorHandler :: DynFlags -> IO a -> IO a
-defaultErrorHandler dflags inner = 
+defaultErrorHandler dflags inner =
   -- top-level exception handler: any unrecognised exception is a compiler bug.
+#if __GLASGOW_HASKELL__ < 609
   handle (\exception -> 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")
-		_other ->
-		  fatalErrorMsg dflags (text (show (Panic (show exception))))
-	   exitWith (ExitFailure 1)
+           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
+  handle (\(SomeException exception) -> do
+           hFlush stdout
+           case cast 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
+                     Just StackOverflow ->
+                         fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+                     _ -> case cast 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.
-  handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
-			exitWith (ExitFailure 1)) $
+  handleErrMsg
+            (\em -> do printBagOfErrors dflags (unitBag em)
+                       exitWith (ExitFailure 1)) $
 
   -- error messages propagated as exceptions
-  handleDyn (\dyn -> do
+  handleGhcException
+            (\ge -> do
   		hFlush stdout
-  		case dyn of
+  		case ge of
 		     PhaseFailed _ code -> exitWith code
 		     Interrupted -> exitWith (ExitFailure 1)
-		     _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
+		     _ -> do fatalErrorMsg dflags (text (show ge))
 			     exitWith (ExitFailure 1)
 	    ) $
   inner
@@ -328,13 +353,13 @@ defaultErrorHandler dflags inner =
 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 defaultCleanupHandler dflags inner = 
     -- make sure we clean up after ourselves
-    later (do cleanTempFiles dflags
+    inner `onException`
+          (do cleanTempFiles dflags
               cleanTempDirs dflags
           )
           -- exceptions will be blocked while we clean the temporary files,
           -- so there shouldn't be any difficulty if we receive further
           -- signals.
-    inner
 
 
 -- | Starts a new session.  A session consists of a set of loaded
@@ -465,7 +490,8 @@ guessTarget file Nothing
 	if exists
 	   then return (Target (TargetFile lhs_file Nothing) Nothing)
 	   else do
-        throwDyn (ProgramError (showSDoc $
+        throwGhcException
+                 (ProgramError (showSDoc $
                  text "target" <+> quotes (text file) <+> 
                  text "is not a module name or a source file"))
      where 
@@ -1661,7 +1687,8 @@ downsweep :: HscEnv
 		-- in which case there can be repeats
 downsweep hsc_env old_summaries excl_mods allow_dup_roots
    = -- catch error messages and return them
-     handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
+     handleErrMsg
+               (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
        rootSummaries <- mapM getRootSummary roots
        let root_map = mkRootMap rootSummaries
        checkDuplicates root_map
@@ -1678,7 +1705,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
 	   = do exists <- doesFileExist file
 		if exists 
 		    then summariseFile hsc_env old_summaries file mb_phase maybe_buf
-		    else throwDyn $ mkPlainErrMsg noSrcSpan $
+		    else throwErrMsg $ mkPlainErrMsg noSrcSpan $
 			   text "can't find file:" <+> text file
 	getRootSummary (Target (TargetModule modl) maybe_buf)
  	   = do maybe_summary <- summariseModule hsc_env old_summary_map False 
@@ -1928,7 +1955,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
 
 	when (mod_name /= wanted_mod) $
-		throwDyn $ mkPlainErrMsg mod_loc $ 
+		throwErrMsg $ mkPlainErrMsg mod_loc $ 
 			      text "File name does not match module name:" 
 			      $$ text "Saw:" <+> quotes (ppr mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -1995,21 +2022,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
-  = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+  = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
 				
 noHsFileErr :: SrcSpan -> String -> a
 noHsFileErr loc path
-  = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+  = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
  
 packageModErr :: ModuleName -> a
 packageModErr mod
-  = throwDyn $ mkPlainErrMsg noSrcSpan $
+  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
 	text "module" <+> quotes (ppr mod) <+> text "is a package module"
 
 multiRootsErr :: [ModSummary] -> IO ()
 multiRootsErr [] = panic "multiRootsErr"
 multiRootsErr summs@(summ1:_)
-  = throwDyn $ mkPlainErrMsg noSrcSpan $
+  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
 	text "module" <+> quotes (ppr mod) <+> 
 	text "is defined in multiple files:" <+>
 	sep (map text files)

compiler/main/HeaderInfo.hs

@@ -70,7 +70,7 @@ getImports dflags buf filename source_filename = do
 	      return (source_imps, ordinary_imps, mod)
   
 parseError :: SrcSpan -> Message -> a
-parseError span err = throwDyn $ mkPlainErrMsg span err
+parseError span err = throwErrMsg $ mkPlainErrMsg span err
 
 isSourceIdecl :: ImportDecl name -> Bool
 isSourceIdecl (ImportDecl _ s _ _ _) = s

compiler/main/InteractiveEval.hs

@@ -90,13 +90,13 @@ import Foreign.StablePtr
 data RunResult
   = RunOk [Name] 		-- ^ names bound by this evaluation
   | RunFailed	 		-- ^ statement failed compilation
-  | RunException Exception	-- ^ statement raised an exception
+  | RunException SomeException	-- ^ statement raised an exception
   | RunBreak ThreadId [Name] (Maybe BreakInfo)
 
 data Status
    = Break Bool HValue BreakInfo ThreadId
           -- ^ the computation hit a breakpoint (Bool <=> was an exception)
-   | Complete (Either Exception [HValue])
+   | Complete (Either SomeException [HValue])
           -- ^ the computation completed with either an exception or a value
 
 data Resume
@@ -338,6 +338,7 @@ 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,
@@ -355,7 +356,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                    _    -> poke exceptionFlag 0
 
                 Exception.throwIO e
-
+#else
+rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> 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
+                         -- If it is an "Interrupted" exception, we allow
+                         --  a possible break by way of -fbreak-on-exception
+                         Just Interrupted -> return ()
+                         -- In any other case, we don't want to break
+                         _ -> poke exceptionFlag 0
+
+                Exception.throwIO se
+#endif
 
 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 withInterruptsSentTo thread get_result = do

compiler/main/Packages.lhs

@@ -55,6 +55,7 @@ import Distribution.Text
 import Distribution.Version
 import FastString
 import ErrUtils         ( debugTraceMsg, putMsg, Message )
+import Exception
 
 import System.Directory
 import System.FilePath
@@ -172,7 +173,7 @@ initPackages dflags = do
 
 readPackageConfigs :: DynFlags -> IO PackageConfigMap
 readPackageConfigs dflags = do
-   e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
+   e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
    system_pkgconfs <- getSystemPackageConfigs dflags
 
    let pkgconfs = case e_pkg_path of
@@ -215,7 +216,7 @@ getSystemPackageConfigs dflags = do
 	-- unless the -no-user-package-conf flag was given.
 	-- We only do this when getAppUserDataDirectory is available 
 	-- (GHC >= 6.3).
-   user_pkgconf <- handle (\_ -> return []) $ do
+   user_pkgconf <- do
       appdir <- getAppUserDataDirectory "ghc"
       let 
      	 pkgconf = appdir
@@ -225,6 +226,7 @@ getSystemPackageConfigs dflags = do
       if (flg && dopt Opt_ReadUserPackageConf dflags)
 	then return [pkgconf]
 	else return []
+    `catchIO` (\_ -> return [])
 
    return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf])
 

compiler/typecheck/TcRnMonad.lhs

@@ -40,7 +40,8 @@ import StaticFlags
 import FastString
 import Panic
 import Util
- 
+import Exception
+
 import System.IO
 import Data.IORef
 import Control.Monad
@@ -536,7 +537,11 @@ discardWarnings thing_inside
 
 
 \begin{code}
+#if __GLASGOW_HASKELL__ < 609
 try_m :: TcRn r -> TcRn (Either Exception r)
+#else
+try_m :: TcRn r -> TcRn (Either ErrorCall r)
+#endif
 -- Does try_m, with a debug-trace on failure
 try_m thing 
   = do { mb_r <- tryM thing ;

compiler/typecheck/TcSplice.lhs

@@ -63,13 +63,17 @@ import Maybe
 import BasicTypes
 import Panic
 import FastString
+import Data.Typeable (cast)
+import Exception
 
 import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
 import qualified Language.Haskell.TH.Syntax as TH
 
 import GHC.Exts		( unsafeCoerce#, Int#, Int(..) )
+#if __GLASGOW_HASKELL__ < 609
 import qualified Exception ( userErrors )
+#endif
 \end{code}
 
 Note [Template Haskell levels]
@@ -593,10 +597,18 @@ 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) -> do
+                    case cast exn of
+                        Just (ErrorCall "IOEnv failure") ->
+                            failM -- Error already in Tc monad
+                        _ -> failWithTc (mk_msg "run" exn)	-- Exception
+#endif
         }}}
   where
     mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",

compiler/utils/Exception.hs

 
 module Exception
     (
+    module Control.Exception,
+    module Exception
+    )
+    where
+
+import Prelude hiding (catch)
+import Control.Exception
+
+#if __GLASGOW_HASKELL__ < 609
+type SomeException = Exception
+
+onException :: IO a -> IO () -> IO a
+onException io what = io `catch` \e -> do what
+                                          throw e
+#endif
+
+catchIO :: IO a -> (IOException -> IO a) -> IO a
 #if __GLASGOW_HASKELL__ >= 609
-    module Control.OldException
+catchIO = catch
 #else
-    module Control.Exception
+catchIO io handler = io `catch` handler'
+    where handler' (IOException ioe) = handler ioe
+          handler' e                 = throw e
 #endif
-    )
-    where
 
-import Prelude ()
+handleIO :: (IOException -> IO a) -> IO a -> IO a
+handleIO = flip catchIO
 
+tryIO :: IO a -> IO (Either IOException a)
 #if __GLASGOW_HASKELL__ >= 609
-import Control.OldException
+tryIO = try
 #else
-import Control.Exception
+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
 

compiler/utils/IOEnv.hs

@@ -23,7 +23,8 @@ module IOEnv (
         IORef, newMutVar, readMutVar, writeMutVar, updMutVar
   ) where
 
-import Panic            ( try, tryUser, tryMost, Exception(..) )
+import Exception
+import Panic
 
 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
 import System.IO.Unsafe ( unsafeInterleaveIO )
@@ -94,7 +95,11 @@ 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 ErrorCall r)
+#endif
 -- Reflect UserError exceptions (only) into IOEnv monad
 -- Other exceptions are not caught; they are simply propagated as exns
 --
@@ -104,13 +109,14 @@ tryM :: IOEnv env r -> IOEnv env (Either Exception r)
 -- begin compiled!
 tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env))
 
-tryAllM :: IOEnv env r -> IOEnv env (Either Exception r)
+-- XXX We shouldn't be catching everything, e.g. timeouts
+tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)
 -- Catch *all* exceptions
 -- This is used when running a Template-Haskell splice, when
 -- even a pattern-match failure is a programmer error
 tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))
 
-tryMostM :: IOEnv env r -> IOEnv env (Either Exception r)
+tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)
 tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))
 
 ---------------------------

compiler/utils/Panic.lhs

@@ -11,13 +11,14 @@ some unnecessary loops in the module dependency graph.
 \begin{code}
 module Panic  
    ( 
-     GhcException(..), showGhcException, ghcError, progName, 
+     GhcException(..), showGhcException, throwGhcException, handleGhcException,
+     ghcError, progName,
      pgmError,
 
      panic, panicFastInt, assertPanic, trace,
      
      Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
-     catchJust, ioErrors, throwTo,
+     catchJust, throwTo,
 
      installSignalHandlers, interruptTargetThread
    ) where
@@ -40,7 +41,7 @@ import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
 import Data.Dynamic
 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}
@@ -49,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
 --
@@ -71,18 +76,27 @@ data GhcException