diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Panic.lhs | 55 |
1 files changed, 46 insertions, 9 deletions
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} |