X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FPrimOps.cmm;h=53de7249c4039e2ffdf52b4957e2a7a8d1e944ac;hb=bb7ffa1642e2110e26e1243c42a8a24adafa985d;hp=4a7d398b6a5e249b939f8155d624f62198f9d60f;hpb=bc111b7d3d03e49f999bd869cbac0ad5e2160b9b;p=ghc-hetmet.git

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 4a7d398..53de724 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1034,6 +1034,39 @@ isCurrentThreadBoundzh_fast
   RET_N(r);
 }
 
+threadStatuszh_fast
+{
+    /* args: R1 :: ThreadId# */
+    W_ tso;
+    W_ why_blocked;
+    W_ what_next;
+    W_ ret;
+
+    tso = R1;
+    loop:
+      if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+          tso = StgTSO__link(tso);
+          goto loop;
+      }
+
+    what_next   = TO_W_(StgTSO_what_next(tso));
+    why_blocked = TO_W_(StgTSO_why_blocked(tso));
+    // Note: these two reads are not atomic, so they might end up
+    // being inconsistent.  It doesn't matter, since we
+    // only return one or the other.  If we wanted to return the
+    // contents of block_info too, then we'd have to do some synchronisation.
+
+    if (what_next == ThreadComplete) {
+        ret = 16;  // NB. magic, matches up with GHC.Conc.threadStatus
+    } else {
+        if (what_next == ThreadKilled) {
+            ret = 17;
+        } else {
+            ret = why_blocked;
+        }
+    }
+    RET_N(ret);
+}
 
 /* -----------------------------------------------------------------------------
  * TVar primitives
@@ -1570,6 +1603,7 @@ takeMVarzh_fast
 	StgTSO_block_info(CurrentTSO)  = mvar;
 	StgMVar_tail(mvar) = CurrentTSO;
 	
+        R1 = mvar;
 	jump stg_block_takemvar;
   }
 
@@ -1587,7 +1621,7 @@ takeMVarzh_fast
       tso = StgMVar_head(mvar);
       PerformPut(tso,StgMVar_value(mvar));
 
-      if (StgTSO_flags(tso) & TSO_DIRTY == 0) {
+      if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
           foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
       }
 
@@ -1663,7 +1697,7 @@ tryTakeMVarzh_fast
 	/* actually perform the putMVar for the thread that we just woke up */
 	tso = StgMVar_head(mvar);
 	PerformPut(tso,StgMVar_value(mvar));
-        if (StgTSO_flags(tso) & TSO_DIRTY == 0) {
+        if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
             foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
         }
 
@@ -1697,13 +1731,14 @@ tryTakeMVarzh_fast
 
 putMVarzh_fast
 {
-    W_ mvar, info, tso;
+    W_ mvar, val, info, tso;
 
     /* args: R1 = MVar, R2 = value */
     mvar = R1;
+    val  = R2;
 
 #if defined(THREADED_RTS)
-    ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [R2];
+    ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
 #else
     info = GET_INFO(mvar);
 #endif
@@ -1725,6 +1760,8 @@ putMVarzh_fast
 	StgTSO_block_info(CurrentTSO)  = mvar;
 	StgMVar_tail(mvar) = CurrentTSO;
 	
+        R1 = mvar;
+        R2 = val;
 	jump stg_block_putmvar;
     }
   
@@ -1736,8 +1773,8 @@ putMVarzh_fast
 
 	/* actually perform the takeMVar */
 	tso = StgMVar_head(mvar);
-	PerformTake(tso, R2);
-        if (StgTSO_flags(tso) & TSO_DIRTY == 0) {
+	PerformTake(tso, val);
+        if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
             foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
         }
       
@@ -1759,7 +1796,7 @@ putMVarzh_fast
     else
     {
 	/* No further takes, the MVar is now full. */
-	StgMVar_value(mvar) = R2;
+	StgMVar_value(mvar) = val;
 
 #if defined(THREADED_RTS)
     	unlockClosure(mvar, stg_MVAR_DIRTY_info);
@@ -1806,7 +1843,7 @@ tryPutMVarzh_fast
 	/* actually perform the takeMVar */
 	tso = StgMVar_head(mvar);
 	PerformTake(tso, R2);
-        if (StgTSO_flags(tso) & TSO_DIRTY == 0) {
+        if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
             foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
         }