[commit: ghc] master: Fix to 02c4ab049: use a weak pointer to the sandbox thread (9c6dd15)

[Simon Marlow]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/9c6dd15b206bddc860a537cc059284ba4b6aa80f

>---------------------------------------------------------------

commit 9c6dd15b206bddc860a537cc059284ba4b6aa80f
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Wed Jan 30 10:34:28 2013 +0000

    Fix to 02c4ab049: use a weak pointer to the sandbox thread
    
    Otherwise, the sandbox thread cannot be considered deadlocked by the
    RTS, and conc033(ghci) hangs (amongst others).

>---------------------------------------------------------------

 compiler/main/InteractiveEval.hs |   13 ++++++++++++-
 1 files changed, 12 insertions(+), 1 deletions(-)

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 8d64900..4b23ad0 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -71,6 +71,7 @@ import Outputable
 import FastString
 import MonadUtils
 
+import System.Mem.Weak
 import System.Directory
 import Data.Dynamic
 import Data.Either
@@ -415,9 +416,19 @@ sandboxIO dflags statusMVar thing =
 --  * clients of the GHC API can terminate a runStmt in progress
 --    without knowing the ThreadId of the sandbox thread (#1381)
 --
+-- NB. use a weak pointer to the thread, so that the thread can still
+-- be considered deadlocked by the RTS and sent a BlockedIndefinitely
+-- exception.  A symptom of getting this wrong is that conc033(ghci)
+-- will hang.
+--
 redirectInterrupts :: ThreadId -> IO a -> IO a
 redirectInterrupts target wait
-  = wait `catch` \e -> do throwTo target (e :: SomeException); wait
+  = do wtid <- mkWeakThreadId target
+       wait `catch` \e -> do
+          m <- deRefWeak wtid
+          case m of
+            Nothing -> wait
+            Just target -> do throwTo target (e :: SomeException); wait
 
 -- We want to turn ^C into a break when -fbreak-on-exception is on,
 -- but it's an async exception and we only break for sync exceptions.