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.

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}