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
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)
-- -----------------------------------------------------------------------------
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
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
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
Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
catchJust, ioErrors, throwTo,
- installSignalHandlers,
+ installSignalHandlers, interruptTargetThread
) where
#include "HsVersions.h"
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 )
\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
#else
return () -- nothing
#endif
+
+{-# NOINLINE interruptTargetThread #-}
+interruptTargetThread :: MVar [ThreadId]
+interruptTargetThread = unsafePerformIO newEmptyMVar
\end{code}