Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/02c4ab049adeb77b8ee0e3b98fbf0f3026eee453 >--------------------------------------------------------------- commit 02c4ab049adeb77b8ee0e3b98fbf0f3026eee453 Author: Simon Marlow <marlo...@gmail.com> Date: Thu Dec 20 09:18:49 2012 +0000 Redirect asynchronous exceptions to the sandbox thread in runStmt (#1381) See comment for details. We no longer use pushInterruptTargetThread/popInterruptTargetThread, so these could go away in due course. >--------------------------------------------------------------- compiler/main/InteractiveEval.hs | 43 ++++++++++++++++++++++++++++--------- 1 files changed, 32 insertions(+), 11 deletions(-) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index c5f35e5..7fa156a 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -333,9 +333,10 @@ traceRunStatus expr bindings final_ids status <- withBreakAction True (hsc_dflags hsc_env) breakMVar statusMVar $ do - liftIO $ withInterruptsSentTo tid $ do + liftIO $ mask_ $ do putMVar breakMVar () -- awaken the stopped thread - takeMVar statusMVar -- and wait for the result + redirectInterrupts tid $ + takeMVar statusMVar -- and wait for the result traceRunStatus expr bindings final_ids breakMVar statusMVar status history' _other -> @@ -385,14 +386,39 @@ sandboxIO dflags statusMVar thing = in if gopt Opt_GhciSandbox dflags then do tid <- forkIO $ do res <- runIt putMVar statusMVar res -- empty: can't block - withInterruptsSentTo tid $ takeMVar statusMVar + redirectInterrupts tid $ + takeMVar statusMVar + else -- GLUT on OS X needs to run on the main thread. If you -- try to use it from another thread then you just get a -- white rectangle rendered. For this, or anything else -- with such restrictions, you can turn the GHCi sandbox off -- and things will be run in the main thread. + -- + -- BUT, note that the debugging features (breakpoints, + -- tracing, etc.) need the expression to be running in a + -- separate thread, so debugging is only enabled when + -- using the sandbox. runIt +-- +-- While we're waiting for the sandbox thread to return a result, if +-- the current thread receives an asynchronous exception we re-throw +-- it at the sandbox thread and continue to wait. +-- +-- This is for two reasons: +-- +-- * So that ^C interrupts runStmt (e.g. in GHCi), allowing the +-- computation to run its exception handlers before returning the +-- exception result to the caller of runStmt. +-- +-- * clients of the GHC API can terminate a runStmt in progress +-- without knowing the ThreadId of the sandbox thread (#1381) +-- +redirectInterrupts :: ThreadId -> IO a -> IO a +redirectInterrupts target wait + = wait `catch` \e -> do throwTo target (e :: SomeException); wait + -- We want to turn ^C into a break when -fbreak-on-exception is on, -- but it's an async exception and we only break for sync exceptions. -- Idea: if we catch and re-throw it, then the re-throw will trigger @@ -417,12 +443,6 @@ rethrow dflags io = Exception.catch io $ \se -> do Exception.throwIO se -withInterruptsSentTo :: ThreadId -> IO r -> IO r -withInterruptsSentTo thread get_result = do - bracket (pushInterruptTargetThread thread) - (\_ -> popInterruptTargetThread) - (\_ -> get_result) - -- This function sets up the interpreter for catching breakpoints, and -- resets everything when the computation has stopped running. This -- is a not-very-good way to ensure that only the interactive @@ -495,10 +515,11 @@ resume canLogSpan step withVirtualCWD $ do withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do - status <- liftIO $ withInterruptsSentTo tid $ do + status <- liftIO $ mask_ $ do putMVar breakMVar () -- this awakens the stopped thread... - takeMVar statusMVar + redirectInterrupts tid $ + takeMVar statusMVar -- and wait for the result let prevHistoryLst = fromListBL 50 hist hist' = case info of _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
