Follow Digraph changes in GHC; patch from Max Bolingbroke

[ghc-hetmet.git] / compiler / main / InteractiveEval.hs

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 44846ff..dd55dd5 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -45,7 +45,7 @@ import TcRnDriver
 import Type             hiding (typeKind)
 import TcType           hiding (typeKind)
 import InstEnv
-import Var              hiding (setIdType)
+import Var
 import Id
 import IdInfo
 import Name             hiding ( varName )
@@ -78,7 +78,7 @@ import Foreign
 import Foreign.C
 import GHC.Exts
 import Data.Array
-import Control.Exception as Exception
+import Exception
 import Control.Concurrent
 import Data.List (sortBy)
 import Data.IORef
@@ -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
@@ -407,7 +423,7 @@ resume (Session ref) step
        resume = ic_resume ic
 
    case resume of
-     [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+     [] -> ghcError (ProgramError "not stopped at a breakpoint")
      (r:rs) -> do
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the
@@ -458,16 +474,16 @@ moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan)
 moveHist fn (Session ref) = do
   hsc_env <- readIORef ref
   case ic_resume (hsc_IC hsc_env) of
-     [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+     [] -> ghcError (ProgramError "not stopped at a breakpoint")
      (r:rs) -> do
         let ix = resumeHistoryIx r
             history = resumeHistory r
             new_ix = fn ix
         --
         when (new_ix > length history) $
-           throwDyn (ProgramError "no more logged breakpoints")
+           ghcError (ProgramError "no more logged breakpoints")
         when (new_ix < 0) $
-           throwDyn (ProgramError "already at the beginning of the history")
+           ghcError (ProgramError "already at the beginning of the history")
 
         let
           update_ic apStack mb_info = do
@@ -775,12 +791,12 @@ vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 mkTopLevEnv hpt modl
   = case lookupUFM hpt (moduleName modl) of
-      Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ 
+      Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ 
                                                 showSDoc (ppr modl)))
       Just details ->
         case mi_globals (hm_iface details) of
                Nothing  -> 
-                  throwDyn (ProgramError ("mkTopLevEnv: not interpreted " 
+                  ghcError (ProgramError ("mkTopLevEnv: not interpreted " 
                                                ++ showSDoc (ppr modl)))
                Just env -> return env