Eagerly raise a blocked exception when entering 'unblock' or exiting 'block'

This fixes #1047

3 files changed, 57 insertions, 8 deletions

diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index ae123f9421..62d544c350 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -53,15 +53,37 @@
 INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
  		0/*framesize*/, 0/*bitmap*/, RET_SMALL )
 {
+    CInt r;
+
     // Not true: see comments above
     // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
 
-    foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
-					    CurrentTSO "ptr") [R1];
-
     StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
 	~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
 
+    /* Eagerly raise a blocked exception, if there is one */
+    if (StgTSO_blocked_exceptions(CurrentTSO) != END_TSO_QUEUE) {
+        /* 
+         * We have to be very careful here, as in killThread#, since
+         * we are about to raise an async exception in the current
+         * thread, which might result in the thread being killed.
+         */
+        SAVE_THREAD_STATE();
+        r = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
+    					              CurrentTSO "ptr") [R1];
+
+        if (r != 0::CInt) {
+            if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
+                R1 = ThreadFinished;
+                jump StgReturn;
+            } else {
+                LOAD_THREAD_STATE();
+                ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+                jump %ENTRY_CODE(Sp(0));
+            }
+        }
+    }
+
 #ifdef REG_R1
     Sp_adj(1);
     jump %ENTRY_CODE(Sp(0));
@@ -116,16 +138,39 @@ blockAsyncExceptionszh_fast
 
 unblockAsyncExceptionszh_fast
 {
+    CInt r;
+
     /* Args: R1 :: IO a */
     STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
 
     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) {
-	foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
-						CurrentTSO "ptr") [R1];
 
 	StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
 	   ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
 
+        /* Eagerly raise a blocked exception, if there is one */
+        if (StgTSO_blocked_exceptions(CurrentTSO) != END_TSO_QUEUE) {
+            /* 
+             * We have to be very careful here, as in killThread#, since
+             * we are about to raise an async exception in the current
+             * thread, which might result in the thread being killed.
+             */
+            SAVE_THREAD_STATE();
+            r = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
+						      CurrentTSO "ptr") [R1];
+
+            if (r != 0::CInt) {
+                if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
+	            R1 = ThreadFinished;
+	            jump StgReturn;
+	        } else {
+	            LOAD_THREAD_STATE();
+	            ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+	            jump %ENTRY_CODE(Sp(0));
+	        }
+            }
+        }
+
 	/* avoid growing the stack unnecessarily */
 	if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
 	    Sp_adj(1);
diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index d55595309b..d892e95638 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -496,9 +496,11 @@ throwToReleaseTarget (void *tso)
    queue, but not perform any throwTo() immediately.  This might be
    more appropriate when the target thread is the one actually running
    (see Exception.cmm).
+
+   Returns: non-zero if an exception was raised, zero otherwise.
    -------------------------------------------------------------------------- */
 
-void
+int
 maybePerformBlockedException (Capability *cap, StgTSO *tso)
 {
     StgTSO *source;
@@ -514,7 +516,7 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso)
 	// locked it.
 	if (tso->blocked_exceptions == END_TSO_QUEUE) {
 	    unlockTSO(tso);
-	    return;
+	    return 0;
 	}
 
 	// We unblock just the first thread on the queue, and perform
@@ -524,7 +526,9 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso)
 	tso->blocked_exceptions = unblockOne_(cap, source, 
 					      rtsFalse/*no migrate*/);
 	unlockTSO(tso);
+        return 1;
     }
+    return 0;
 }
 
 void
diff --git a/rts/RaiseAsync.h b/rts/RaiseAsync.h
index 3ab96abac2..805281443e 100644
--- a/rts/RaiseAsync.h
+++ b/rts/RaiseAsync.h
@@ -38,7 +38,7 @@ nat throwTo (Capability *cap,	         // the Capability we hold
 void throwToReleaseTarget (void *tso);
 #endif
 
-void maybePerformBlockedException (Capability *cap, StgTSO *tso);
+int  maybePerformBlockedException (Capability *cap, StgTSO *tso);
 void awakenBlockedExceptionQueue  (Capability *cap, StgTSO *tso);
 
 /* Determine whether a thread is interruptible (ie. blocked