diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 4 | ||||
| -rw-r--r-- | compiler/utils/Panic.lhs | 55 |
2 files changed, 48 insertions, 11 deletions
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index c87c62bf1b..a666220a6e 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 0fb206ca77..faaa62898e 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,7 +51,11 @@ import GHC.ConsoleHandler import GHC.Stack #endif --- | GHC's own exception type +#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} |