From: simonmar Date: Thu, 12 Jan 2006 16:16:28 +0000 (+0000) Subject: [project @ 2006-01-12 16:16:28 by simonmar] X-Git-Tag: final_switch_to_darcs,_this_repo_is_now_live~27 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=44713ec1fa30bab4b6e087d017ca8524f9792b34;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 8fee9ba..112e672 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 7e0ec2f..37d9739 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 3d5cf17..cdfc962 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}