X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FRaiseAsync.c;h=b0c70645401717ca1bb3cfa769a84d27ec426ac2;hb=b1a8c262a046812d70371b1caaea21ffe039ced6;hp=9041c06cb278c0513d02e291171168a95f4fbcd9;hpb=b1953bbb1ed3cb16497e5447db7487f0c2d9e41a;p=ghc-hetmet.git

diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index 9041c06..b0c7064 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -401,7 +401,23 @@ check_target:
     }	
 
     case BlockedOnSTM:
-	barf("ToDo");
+	lockTSO(target);
+	// Unblocking BlockedOnSTM threads requires the TSO to be
+	// locked; see STM.c:unpark_tso().
+	if (target->why_blocked != BlockedOnSTM) {
+	    goto retry;
+	}
+	if ((target->flags & TSO_BLOCKEX) &&
+	    ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
+	    blockedThrowTo(source,target);
+	    *out = target;
+	    return THROWTO_BLOCKED;
+	} else {
+	    raiseAsync(cap, target, exception, rtsFalse, NULL);
+	    unblockOne(cap, target);
+	    unlockTSO(target);
+	    return THROWTO_SUCCESS;
+	}
 
     case BlockedOnCCall:
     case BlockedOnCCall_NoUnblockExc: