From: simonmar <unknown>
Date: Fri, 9 Feb 2001 10:08:09 +0000 (+0000)
Subject: [project @ 2001-02-09 10:08:09 by simonmar]
X-Git-Tag: Approximately_9120_patches~2704
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=13896d87b75817b068f80d873f828b64403e8023;p=ghc-hetmet.git

[project @ 2001-02-09 10:08:09 by simonmar]
Unblock async exceptions in the recursive exception handler, so if we
somehow get stuck in a loop in here we'll probably be able to ^C out
of it.
---

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index d8f8f97..a420ff6 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.35 2001/02/08 14:58:28 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.36 2001/02/09 10:08:09 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -27,6 +27,7 @@ import PprType		{- instance Outputable Type; do not delete -}
 import Panic		( GhcException(..) )
 
 import Exception
+import Dynamic
 #ifndef NO_READLINE
 import Readline
 #endif
@@ -209,20 +210,24 @@ readlineLoop = do
 -- and carries on.
 runCommand :: String -> GHCi Bool
 runCommand c = 
-  ghciHandle ( 
-     \other_exception 
-        -> io (do putStrLn ("*** Exception: " ++ show other_exception)
-		  return False)
-  ) $
-  ghciHandleDyn
-    (\dyn -> case dyn of
-		PhaseFailed phase code ->
+  ghciHandle ( \exception -> 
+	(case exception of
+	   DynException dyn -> 
+	      case fromDynamic dyn of
+		Nothing -> io (putStrLn ("*** Exception: (unknown)"))
+		Just ghc_ex -> 
+		  case ghc_ex of
+		    PhaseFailed phase code ->
 			io ( putStrLn ("Phase " ++ phase ++ " failed (code "
 				        ++ show code ++ ")"))
-		Interrupted -> io (putStrLn "Interrupted.")
-		_ -> io (putStrLn (show (dyn :: GhcException)))
-             >> return False
-    ) $
+		    Interrupted -> io (putStrLn "Interrupted.")
+		    other -> io (putStrLn (show (ghc_ex :: GhcException)))
+
+	   other -> io (putStrLn ("*** Exception: " ++ show exception))
+
+	) >> return False
+     ) $
+
    doCommand c
 
 doCommand (':' : command) = specialCommand command
@@ -575,13 +580,20 @@ setLastExpr last_expr
 
 io m = GHCi $ \s -> m >>= \a -> return (s,a)
 
+-----------------------------------------------------------------------------
 -- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- 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 h (GHCi m) = GHCi $ \s -> 
-   Exception.catch (m s) (\e -> unGHCi (ghciHandle h (h e)) s)
+   Exception.catch (m s) 
+	(\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
 
-ghciHandleDyn h (GHCi m) = GHCi $ \s -> 
-   Exception.catchDyn (m s) (\e -> unGHCi (ghciHandleDyn h (h e)) s)
+ghciUnblock :: GHCi a -> GHCi a
+ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 
 -----------------------------------------------------------------------------
 -- package loader