Don't remove the thread from interruptTargetThread on ^C (#6116)

1 files changed, 18 insertions, 15 deletions

diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs
index faaa62898e..38ee6fc19d 100644
--- a/compiler/utils/Panic.lhs
+++ b/compiler/utils/Panic.lhs
@@ -243,7 +243,7 @@ installSignalHandlers = do
       interrupt_exn = (toException UserInterrupt)
 
       interrupt = do
-        mt <- popInterruptTargetThread
+        mt <- peekInterruptTargetThread
         case mt of
           Nothing -> return ()
           Just t  -> throwTo t interrupt_exn
@@ -280,19 +280,18 @@ interruptTargetThread = unsafePerformIO (newMVar [])
 pushInterruptTargetThread :: ThreadId -> IO ()
 pushInterruptTargetThread tid = do
  wtid <- mkWeakThreadId tid
- modifyMVar_ interruptTargetThread $
-   return . (wtid :)
+ modifyMVar_ interruptTargetThread $ return . (wtid :)
 
-popInterruptTargetThread :: IO (Maybe ThreadId)
-popInterruptTargetThread =
-  modifyMVar interruptTargetThread $ loop
+peekInterruptTargetThread :: IO (Maybe ThreadId)
+peekInterruptTargetThread =
+  withMVar interruptTargetThread $ loop
  where
-   loop [] = return ([], Nothing)
+   loop [] = return Nothing
    loop (t:ts) = do
      r <- deRefWeak t
      case r of
        Nothing -> loop ts
-       Just t  -> return (ts, Just t)
+       Just t  -> return (Just t)
 #else
 {-# NOINLINE interruptTargetThread #-}
 interruptTargetThread :: MVar [ThreadId]
@@ -300,13 +299,17 @@ interruptTargetThread = unsafePerformIO (newMVar [])
 
 pushInterruptTargetThread :: ThreadId -> IO ()
 pushInterruptTargetThread tid = do
- modifyMVar_ interruptTargetThread $
-   return . (tid :)
+ modifyMVar_ interruptTargetThread $ return . (tid :)
 
-popInterruptTargetThread :: IO (Maybe ThreadId)
-popInterruptTargetThread =
-  modifyMVar interruptTargetThread $
-   \tids -> return $! case tids of [] -> ([], Nothing)
-                                   (t:ts) -> (ts, Just t)
+peekInterruptTargetThread :: IO (Maybe ThreadId)
+peekInterruptTargetThread =
+  withMVar interruptTargetThread $ return . listToMaybe
 #endif
+
+popInterruptTargetThread :: IO ()
+popInterruptTargetThread =
+  modifyMVar_ interruptTargetThread $
+   \tids -> return $! case tids of []     -> []
+                                   (t:ts) -> ts
+
 \end{code}