[project @ 2006-01-12 16:16:28 by simonmar]

GHC.runStmt: run the statement in a new thread to insulate the
environment from bad things that the user code might do, such as fork
a thread to send an exception back at a later time.  In order to do
this, we had to keep track of which thread the ^C exception should go
to in a global variable.

Also, bullet-proof the top-level exception handler in GHCi a bit;
there was a small window where an exception could get through, so if
you lean on ^C for a while then press enter you could cause GHCi to
exit.

3 files changed, 50 insertions, 30 deletions

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 8fee9ba19f..112e6723db 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -282,15 +282,18 @@ runGHCi paths maybe_expr = do
   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 
 
-interactiveLoop is_tty show_prompt = do
+interactiveLoop is_tty show_prompt =
   -- Ignore ^C exceptions caught here
   ghciHandleDyn (\e -> case e of 
-			Interrupted -> ghciUnblock (
+			Interrupted -> do
 #if defined(mingw32_HOST_OS)
-						io (putStrLn "") >> 
+				io (putStrLn "")
 #endif
-						interactiveLoop is_tty show_prompt)
-			_other      -> return ()) $ do
+				interactiveLoop is_tty show_prompt
+			_other      -> return ()) $ 
+
+  ghciUnblock $ do -- unblock necessary if we recursed from the 
+		   -- exception handler above.
 
   -- read commands from stdin
 #ifdef USE_READLINE
diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index 7e0ec2ffed..37d9739919 100644
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -228,18 +228,21 @@ import Outputable
 import SysTools		( cleanTempFilesExcept )
 import BasicTypes
 import TcType           ( tcSplitSigmaTy, isDictTy )
-
-import Directory        ( getModificationTime, doesFileExist )
-import Maybe		( isJust, isNothing, fromJust )
 import Maybes		( expectJust, mapCatMaybes )
-import List		( partition, nub )
-import qualified List
-import Monad		( unless, when )
-import System		( exitWith, ExitCode(..) )
-import Time		( ClockTime )
-import EXCEPTION as Exception hiding (handle)
-import DATA_IOREF
-import IO
+
+import Control.Concurrent
+import System.Directory ( getModificationTime, doesFileExist )
+import Data.Maybe	( isJust, isNothing, fromJust )
+import Data.List	( partition, nub )
+import qualified Data.List as List
+import Control.Monad	( unless, when )
+import System.Exit	( exitWith, ExitCode(..) )
+import System.Time	( ClockTime )
+import Control.Exception as Exception hiding (handle)
+import Data.IORef
+import System.IO
+import System.IO.Error	( try, isDoesNotExistError )
+import System.IO.Unsafe	( unsafePerformIO )
 import Prelude hiding (init)
 
 -- -----------------------------------------------------------------------------
@@ -303,6 +306,8 @@ defaultCleanupHandler dflags inner =
 init :: [String] -> IO [String]
 init args = do
    -- catch ^C
+   main_thread <- myThreadId
+   putMVar interruptTargetThread [main_thread]
    installSignalHandlers
 
    -- Grab the -B option if there is one
@@ -1458,7 +1463,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
 	case maybe_buf of
 	   Just (_,t) -> check_timestamp old_summary location src_fn t
 	   Nothing    -> do
-		m <- IO.try (getModificationTime src_fn)
+		m <- System.IO.Error.try (getModificationTime src_fn)
 		case m of
 		   Right t -> check_timestamp old_summary location src_fn t
 		   Left e | isDoesNotExistError e -> find_it
@@ -1980,14 +1985,17 @@ runStmt (Session ref) expr
 			writeIORef ref new_hsc_env
 			return (RunOk names)
 
-
--- We run the statement in a "sandbox" to protect the rest of the
--- system from anything the expression might do.  For now, this
--- consists of just wrapping it in an exception handler, but see below
--- for another version.
-
+-- When running a computation, we redirect ^C exceptions to the running
+-- thread.  ToDo: we might want a way to continue even if the target
+-- thread doesn't die when it receives the exception... "this thread
+-- is not responding".
 sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = Exception.try thing
+sandboxIO thing = do
+  m <- newEmptyMVar
+  ts <- takeMVar interruptTargetThread
+  child <- forkIO (do res <- Exception.try thing; putMVar m res)
+  putMVar interruptTargetThread (child:ts)
+  takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
 
 {-
 -- This version of sandboxIO runs the expression in a completely new
diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs
index 3d5cf1707c..cdfc9628b9 100644
--- a/ghc/compiler/utils/Panic.lhs
+++ b/ghc/compiler/utils/Panic.lhs
@@ -19,7 +19,7 @@ module Panic
      Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
      catchJust, ioErrors, throwTo,
 
-     installSignalHandlers, 
+     installSignalHandlers, interruptTargetThread
    ) where
 
 #include "HsVersions.h"
@@ -49,7 +49,7 @@ import EXCEPTION	( throwTo )
 import EXCEPTION	( catchJust, tryJust, ioErrors )
 #endif
 
-import CONCURRENT	( myThreadId )
+import CONCURRENT	( myThreadId, MVar, ThreadId, withMVar, newEmptyMVar )
 import DYNAMIC
 import qualified EXCEPTION as Exception
 import TRACE		( trace )
@@ -209,16 +209,21 @@ throwTo   = Exception.raiseInThread
 \end{code}
 
 Standard signal handlers for catching ^C, which just throw an
-exception in the main thread.  NOTE: must be called from the main
-thread.
+exception in the target thread.  The current target thread is
+the thread at the head of the list in the MVar passed to
+installSignalHandlers.
 
 \begin{code}
 installSignalHandlers :: IO ()
 installSignalHandlers = do
-  main_thread <- myThreadId
   let
       interrupt_exn = Exception.DynException (toDyn Interrupted)
-      interrupt = throwTo main_thread interrupt_exn
+
+      interrupt = do
+	withMVar interruptTargetThread $ \targets ->
+	  case targets of
+	   [] -> return ()
+	   (thread:_) -> throwTo thread interrupt_exn
   --
 #if !defined(mingw32_HOST_OS)
   installHandler sigQUIT (Catch interrupt) Nothing 
@@ -239,4 +244,8 @@ installSignalHandlers = do
 #else
   return () -- nothing
 #endif
+
+{-# NOINLINE interruptTargetThread #-}
+interruptTargetThread :: MVar [ThreadId]
+interruptTargetThread = unsafePerformIO newEmptyMVar
 \end{code}