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

diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index 9041c06..b71e126 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -13,10 +13,13 @@
 #include "RaiseAsync.h"
 #include "SMP.h"
 #include "Schedule.h"
-#include "Storage.h"
+#include "LdvProfile.h"
 #include "Updates.h"
 #include "STM.h"
 #include "Sanity.h"
+#if defined(mingw32_HOST_OS)
+#include "win32/IOManager.h"
+#endif
 
 static void raiseAsync (Capability *cap,
 			StgTSO *tso,
@@ -153,8 +156,8 @@ throwTo (Capability *cap,	// the Capability we hold
 	// ASSERT(get_itbl(target)->type == TSO);
     }
 
-    debugTrace(DEBUG_sched, "throwTo: from thread %d to thread %d",
-	       source->id, target->id);
+    debugTrace(DEBUG_sched, "throwTo: from thread %lu to thread %lu",
+	       (unsigned long)source->id, (unsigned long)target->id);
 
 #ifdef DEBUG
     if (traceClass(DEBUG_sched)) {
@@ -240,7 +243,7 @@ check_target:
     {
 	Capability *target_cap;
 
-	wb();
+	write_barrier();
 	target_cap = target->cap;
 	if (target_cap == cap && (target->flags & TSO_BLOCKEX) == 0) {
 	    // It's on our run queue and not blocking exceptions
@@ -401,7 +404,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:
@@ -418,6 +437,9 @@ check_target:
     case BlockedOnRead:
     case BlockedOnWrite:
     case BlockedOnDelay:
+#if defined(mingw32_HOST_OS)
+    case BlockedOnDoProc:
+#endif
 	if ((target->flags & TSO_BLOCKEX) &&
 	    ((target->flags & TSO_INTERRUPTIBLE) == 0)) {
 	    blockedThrowTo(source,target);
@@ -442,13 +464,13 @@ check_target:
 static void
 blockedThrowTo (StgTSO *source, StgTSO *target)
 {
-    debugTrace(DEBUG_sched, "throwTo: blocking on thread %d", target->id);
+    debugTrace(DEBUG_sched, "throwTo: blocking on thread %lu", (unsigned long)target->id);
     source->link = target->blocked_exceptions;
     target->blocked_exceptions = source;
     dirtyTSO(target); // we modified the blocked_exceptions queue
     
     source->block_info.tso = target;
-    wb(); // throwTo_exception *must* be visible if BlockedOnException is.
+    write_barrier(); // throwTo_exception *must* be visible if BlockedOnException is.
     source->why_blocked = BlockedOnException;
 }
 
@@ -474,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;
@@ -492,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
@@ -502,7 +526,9 @@ maybePerformBlockedException (Capability *cap, StgTSO *tso)
 	tso->blocked_exceptions = unblockOne_(cap, source, 
 					      rtsFalse/*no migrate*/);
 	unlockTSO(tso);
+        return 1;
     }
+    return 0;
 }
 
 void
@@ -916,10 +942,12 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
 	}
 
 	case STOP_FRAME:
+	{
 	    // We've stripped the entire stack, the thread is now dead.
 	    tso->what_next = ThreadKilled;
 	    tso->sp = frame + sizeofW(StgStopFrame);
 	    return;
+	}
 
 	case CATCH_FRAME:
 	    // If we find a CATCH_FRAME, and we've got an exception to raise,
@@ -991,14 +1019,17 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
 	    // whether the transaction is valid or not because its
 	    // possible validity cannot have caused the exception
 	    // and will not be visible after the abort.
-	    debugTrace(DEBUG_stm, 
-		       "found atomically block delivering async exception");
 
+		{
             StgTRecHeader *trec = tso -> trec;
             StgTRecHeader *outer = stmGetEnclosingTRec(trec);
+	    debugTrace(DEBUG_stm, 
+		       "found atomically block delivering async exception");
             stmAbortTransaction(cap, trec);
+	    stmFreeAbortedTRec(cap, trec);
             tso -> trec = outer;
 	    break;
+	    };
 	    
 	default:
 	    break;