Commit 44713ec1 authored by simonmar's avatar simonmar
Browse files

[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.
parent de910f06
......@@ -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
......
......@@ -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
......
......@@ -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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment