Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/206c8fc3ebd64c40ae09742fdea09ffd0f915d5c >--------------------------------------------------------------- commit 206c8fc3ebd64c40ae09742fdea09ffd0f915d5c Author: Simon Marlow <[email protected]> Date: Thu Apr 12 11:21:02 2012 +0100 Allow threads in GHCi to receive BlockedIndefintely* exceptions (#2786) This is a partial fix for #2786. It seems we still don't get NonTermination exceptions for interpreted computations, but we do now get the BlockedIndefinitely family. >--------------------------------------------------------------- compiler/main/InteractiveEval.hs | 4 +- compiler/utils/Panic.lhs | 53 ++++++++++++++++++++++++++++++++----- 2 files changed, 47 insertions(+), 10 deletions(-) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index c87c62b..a666220 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -411,8 +411,8 @@ rethrow dflags io = Exception.catch io $ \se -> do withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do - bracket (modifyMVar_ interruptTargetThread (return . (thread:))) - (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl)) + bracket (pushInterruptTargetThread thread) + (\_ -> popInterruptTargetThread) (\_ -> get_result) -- This function sets up the interpreter for catching breakpoints, and diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index 0fb206c..faaa628 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -24,15 +24,15 @@ module Panic ( Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, - installSignalHandlers, interruptTargetThread + installSignalHandlers, + pushInterruptTargetThread, popInterruptTargetThread ) where #include "HsVersions.h" import Config import FastTypes import Exception -import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar, modifyMVar_, - myThreadId ) +import Control.Concurrent import Data.Dynamic import Debug.Trace ( trace ) import System.IO.Unsafe @@ -51,6 +51,10 @@ import GHC.ConsoleHandler import GHC.Stack #endif +#if __GLASGOW_HASKELL__ >= 705 +import System.Mem.Weak ( Weak, deRefWeak ) +#endif + -- | GHC's own exception type -- error messages all take the form: -- @@ -233,16 +237,16 @@ tryMost action = do r <- try action installSignalHandlers :: IO () installSignalHandlers = do main_thread <- myThreadId - modifyMVar_ interruptTargetThread (return . (main_thread :)) + pushInterruptTargetThread main_thread let interrupt_exn = (toException UserInterrupt) interrupt = do - withMVar interruptTargetThread $ \targets -> - case targets of - [] -> return () - (thread:_) -> throwTo thread interrupt_exn + mt <- popInterruptTargetThread + case mt of + Nothing -> return () + Just t -> throwTo t interrupt_exn -- #if !defined(mingw32_HOST_OS) @@ -268,8 +272,41 @@ installSignalHandlers = do return () #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# NOINLINE interruptTargetThread #-} +interruptTargetThread :: MVar [Weak ThreadId] +interruptTargetThread = unsafePerformIO (newMVar []) + +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + wtid <- mkWeakThreadId tid + modifyMVar_ interruptTargetThread $ + return . (wtid :) + +popInterruptTargetThread :: IO (Maybe ThreadId) +popInterruptTargetThread = + modifyMVar interruptTargetThread $ loop + where + loop [] = return ([], Nothing) + loop (t:ts) = do + r <- deRefWeak t + case r of + Nothing -> loop ts + Just t -> return (ts, Just t) +#else {-# NOINLINE interruptTargetThread #-} interruptTargetThread :: MVar [ThreadId] interruptTargetThread = unsafePerformIO (newMVar []) +pushInterruptTargetThread :: ThreadId -> IO () +pushInterruptTargetThread tid = do + modifyMVar_ interruptTargetThread $ + return . (tid :) + +popInterruptTargetThread :: IO (Maybe ThreadId) +popInterruptTargetThread = + modifyMVar interruptTargetThread $ + \tids -> return $! case tids of [] -> ([], Nothing) + (t:ts) -> (ts, Just t) +#endif \end{code} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
