X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2FRaiseAsync.c;h=b94ccea283ce12fc5b1cfe8cd2a6164452b55a96;hp=bebbcd47228d2443ce236797156861f9ef98d5c8;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=f4692220c7cbdadaa633f50eb2b30b59edb30183

diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index bebbcd4..b94ccea 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -127,7 +127,7 @@ suspendComputation(Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
    Capability, and it is
 
      - NotBlocked, BlockedOnMsgThrowTo,
-       BlockedOnCCall
+       BlockedOnCCall_Interruptible
 
      - or it is masking exceptions (TSO_BLOCKEX)
 
@@ -271,7 +271,7 @@ check_target:
             // might as well just do it now.  The message will
             // be a no-op when it arrives.
             unlockClosure((StgClosure*)m, i);
-            tryWakeupThread(cap, target);
+            tryWakeupThread_(cap, target);
             goto retry;
         }
 
@@ -337,7 +337,7 @@ check_target:
             // thread now anyway and ignore the message when it
             // arrives.
 	    unlockClosure((StgClosure *)mvar, info);
-            tryWakeupThread(cap, target);
+            tryWakeupThread_(cap, target);
             goto retry;
         }
 
@@ -357,14 +357,20 @@ check_target:
 
     case BlockedOnBlackHole:
     {
-        // Revoke the message by replacing it with IND. We're not
-        // locking anything here, so we might still get a TRY_WAKEUP
-        // message from the owner of the blackhole some time in the
-        // future, but that doesn't matter.
-        ASSERT(target->block_info.bh->header.info == &stg_MSG_BLACKHOLE_info);
-        OVERWRITE_INFO(target->block_info.bh, &stg_IND_info);
-        raiseAsync(cap, target, msg->exception, rtsFalse, NULL);
-        return THROWTO_SUCCESS;
+	if (target->flags & TSO_BLOCKEX) {
+            // BlockedOnBlackHole is not interruptible.
+            blockedThrowTo(cap,target,msg);
+	    return THROWTO_BLOCKED;
+	} else {
+            // Revoke the message by replacing it with IND. We're not
+            // locking anything here, so we might still get a TRY_WAKEUP
+            // message from the owner of the blackhole some time in the
+            // future, but that doesn't matter.
+            ASSERT(target->block_info.bh->header.info == &stg_MSG_BLACKHOLE_info);
+            OVERWRITE_INFO(target->block_info.bh, &stg_IND_info);
+            raiseAsync(cap, target, msg->exception, rtsFalse, NULL);
+            return THROWTO_SUCCESS;
+        }
     }
 
     case BlockedOnSTM:
@@ -386,8 +392,29 @@ check_target:
 	    return THROWTO_SUCCESS;
 	}
 
+    case BlockedOnCCall_Interruptible:
+#ifdef THREADED_RTS
+    {
+        Task *task = NULL;
+        // walk suspended_ccalls to find the correct worker thread
+        InCall *incall;
+        for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) {
+            if (incall->suspended_tso == target) {
+                task = incall->task;
+                break;
+            }
+        }
+        if (task != NULL) {
+            raiseAsync(cap, target, msg->exception, rtsFalse, NULL);
+            interruptWorkerTask(task);
+            return THROWTO_SUCCESS;
+        } else {
+            debugTraceCap(DEBUG_sched, cap, "throwTo: could not find worker thread to kill");
+        }
+        // fall to next
+    }
+#endif
     case BlockedOnCCall:
-    case BlockedOnCCall_NoUnblockExc:
 	blockedThrowTo(cap,target,msg);
 	return THROWTO_BLOCKED;
 
@@ -834,9 +861,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
 	    // top of the CATCH_FRAME ready to enter.
 	    //
 	{
-#ifdef PROFILING
 	    StgCatchFrame *cf = (StgCatchFrame *)frame;
-#endif
 	    StgThunk *raise;
 	    
 	    if (exception == NULL) break;
@@ -857,7 +882,12 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
 	     * a surprise exception before we get around to executing the
 	     * handler.
 	     */
-	    tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+            tso->flags |= TSO_BLOCKEX;
+            if ((cf->exceptions_blocked & TSO_INTERRUPTIBLE) == 0) {
+                tso->flags &= ~TSO_INTERRUPTIBLE;
+            } else {
+                tso->flags |= TSO_INTERRUPTIBLE;
+            }
 
 	    /* Put the newly-built THUNK on top of the stack, ready to execute
 	     * when the thread restarts.