X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2FPrimOps.cmm;h=f2ce41551ad29ada1d30e518dc50bbdad0cc432e;hp=ad761ab2e4e8f8245f7ff74532ea2990f24423b9;hb=2378b2325df64a5ccc5b2e038ac3dbb848dea5f7;hpb=d31dfb32ea936c22628b508c28a36c12e631430a

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index ad761ab..f2ce415 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -27,6 +27,32 @@
 
 #include "Cmm.h"
 
+#ifdef __PIC__
+#ifndef mingw32_HOST_OS
+import __gmpz_init;
+import __gmpz_add;
+import __gmpz_sub;
+import __gmpz_mul;
+import __gmpz_gcd;
+import __gmpn_gcd_1;
+import __gmpn_cmp;
+import __gmpz_tdiv_q;
+import __gmpz_tdiv_r;
+import __gmpz_tdiv_qr;
+import __gmpz_fdiv_qr;
+import __gmpz_divexact;
+import __gmpz_and;
+import __gmpz_xor;
+import __gmpz_ior;
+import __gmpz_com;
+#endif
+import pthread_mutex_lock;
+import pthread_mutex_unlock;
+#endif
+import base_ControlziExceptionziBase_nestedAtomically_closure;
+import EnterCriticalSection;
+import LeaveCriticalSection;
+
 /*-----------------------------------------------------------------------------
   Array Primitives
 
@@ -207,7 +233,7 @@ atomicModifyMutVarzh_fast
    HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, atomicModifyMutVarzh_fast);
 
 #if defined(THREADED_RTS)
-    foreign "C" ACQUIRE_LOCK(atomic_modify_mutvar_mutex "ptr") [R1,R2];
+    ACQUIRE_LOCK(atomic_modify_mutvar_mutex "ptr") [R1,R2];
 #endif
 
    x = StgMutVar_var(R1);
@@ -238,7 +264,7 @@ atomicModifyMutVarzh_fast
    StgThunk_payload(r,0) = z;
 
 #if defined(THREADED_RTS)
-    foreign "C" RELEASE_LOCK(atomic_modify_mutvar_mutex "ptr") [];
+    RELEASE_LOCK(atomic_modify_mutvar_mutex "ptr") [];
 #endif
 
    RET_P(r);
@@ -426,11 +452,11 @@ int64ToIntegerzh_fast
    hi = TO_W_(val >> 32);
    lo = TO_W_(val);
 
-   if ( hi != 0 && hi != 0xFFFFFFFF )  { 
-       words_needed = 2;
-   } else { 
+   if ( hi == 0 || (hi == 0xFFFFFFFF && lo != 0) )  {
        // minimum is one word
        words_needed = 1;
+   } else { 
+       words_needed = 2;
    }
 
    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
@@ -850,6 +876,23 @@ decodeFloatzh_fast
     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 }
 
+decodeFloatzuIntzh_fast
+{ 
+    W_ p;
+    F_ arg;
+    FETCH_MP_TEMP(mp_tmp1);
+    FETCH_MP_TEMP(mp_tmp_w);
+    
+    /* arguments: F1 = Float# */
+    arg = F1;
+    
+    /* Perform the operation */
+    foreign "C" __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg) [];
+    
+    /* returns: (Int# (mantissa), Int# (exponent)) */
+    RET_NN(W_[mp_tmp1], W_[mp_tmp_w]);
+}
+
 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
 
@@ -879,6 +922,28 @@ decodeDoublezh_fast
     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 }
 
+decodeDoublezu2Intzh_fast
+{ 
+    D_ arg;
+    W_ p;
+    FETCH_MP_TEMP(mp_tmp1);
+    FETCH_MP_TEMP(mp_tmp2);
+    FETCH_MP_TEMP(mp_result1);
+    FETCH_MP_TEMP(mp_result2);
+
+    /* arguments: D1 = Double# */
+    arg = D1;
+
+    /* Perform the operation */
+    foreign "C" __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
+                                    mp_result1 "ptr", mp_result2 "ptr",
+                                    arg) [];
+
+    /* returns:
+       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
+    RET_NNNN(W_[mp_tmp1], W_[mp_tmp2], W_[mp_result1], W_[mp_result2]);
+}
+
 /* -----------------------------------------------------------------------------
  * Concurrency primitives
  * -------------------------------------------------------------------------- */
@@ -896,6 +961,12 @@ forkzh_fast
   ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
 				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
 				closure "ptr") [];
+
+  /* start blocked if the current thread is blocked */
+  StgTSO_flags(threadid) = 
+     StgTSO_flags(threadid) |  (StgTSO_flags(CurrentTSO) & 
+                                (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));
+
   foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];
 
   // switch at the earliest opportunity
@@ -919,6 +990,12 @@ forkOnzh_fast
   ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
 				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
 				closure "ptr") [];
+
+  /* start blocked if the current thread is blocked */
+  StgTSO_flags(threadid) = 
+     StgTSO_flags(threadid) |  (StgTSO_flags(CurrentTSO) & 
+                                (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));
+
   foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
 
   // switch at the earliest opportunity
@@ -957,18 +1034,45 @@ 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
  * -------------------------------------------------------------------------- */
 
-#ifdef REG_R1
 #define SP_OFF 0
-#define IF_NOT_REG_R1(x) 
-#else
-#define SP_OFF 1
-#define IF_NOT_REG_R1(x) x
-#endif
 
 // Catch retry frame ------------------------------------------------------------
 
@@ -979,7 +1083,6 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
   W_ unused3, "ptr" W_ unused4, "ptr" W_ unused5)
 {
    W_ r, frame, trec, outer;
-   IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )
 
    frame = Sp;
    trec = StgTSO_trec(CurrentTSO);
@@ -989,7 +1092,6 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
      /* Succeeded (either first branch or second branch) */
      StgTSO_trec(CurrentTSO) = outer;
      Sp = Sp + SIZEOF_StgCatchRetryFrame;
-     IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)
      jump %ENTRY_CODE(Sp(SP_OFF));
    } else {
      /* Did not commit: re-execute */
@@ -1015,7 +1117,6 @@ INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
   "ptr" W_ unused3, "ptr" W_ unused4)
 {
   W_ frame, trec, valid, next_invariant, q, outer;
-  IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )
 
   frame = Sp;
   trec = StgTSO_trec(CurrentTSO);
@@ -1059,7 +1160,6 @@ INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
       /* Transaction was valid: commit succeeded */
       StgTSO_trec(CurrentTSO) = NO_TREC;
       Sp = Sp + SIZEOF_StgAtomicallyFrame;
-      IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)
       jump %ENTRY_CODE(Sp(SP_OFF));
     } else {
       /* Transaction was not valid: try again */
@@ -1079,7 +1179,6 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
   "ptr" W_ unused3, "ptr" W_ unused4)
 {
   W_ frame, trec, valid;
-  IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )
 
   frame = Sp;
 
@@ -1087,9 +1186,6 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
   (valid) = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") [];
   if (valid != 0) {
     /* Previous attempt is still valid: no point trying again yet */
-	  IF_NOT_REG_R1(Sp_adj(-2);
-			Sp(1) = stg_NO_FINALIZER_closure;
-		  	Sp(0) = stg_ut_1_0_unreg_info;)
     jump stg_block_noregs;
   } else {
     /* Previous attempt is no longer valid: try again */
@@ -1103,11 +1199,7 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
 
 // STM catch frame --------------------------------------------------------------
 
-#ifdef REG_R1
 #define SP_OFF 0
-#else
-#define SP_OFF 1
-#endif
 
 /* Catch frames are very similar to update frames, but when entering
  * one we just pop the frame off the stack and perform the correct
@@ -1120,7 +1212,6 @@ INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
 #endif
   "ptr" W_ unused3, "ptr" W_ unused4)
    {
-      IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )
       W_ r, frame, trec, outer;
       frame = Sp;
       trec = StgTSO_trec(CurrentTSO);
@@ -1130,7 +1221,6 @@ INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
         /* Commit succeeded */
         StgTSO_trec(CurrentTSO) = outer;
         Sp = Sp + SIZEOF_StgCatchSTMFrame;
-        IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)
         jump Sp(SP_OFF);
       } else {
         /* Commit failed */
@@ -1161,7 +1251,7 @@ atomicallyzh_fast
 
   /* Nested transactions are not allowed; raise an exception */
   if (old_trec != NO_TREC) {
-     R1 = base_GHCziIOBase_NestedAtomically_closure;
+     R1 = base_ControlziExceptionziBase_nestedAtomically_closure;
      jump raisezh_fast;
   }
 
@@ -1302,9 +1392,6 @@ retry_pop_stack:
     StgHeader_info(frame) = stg_atomically_waiting_frame_info;
     Sp = frame;
     // Fix up the stack in the unregisterised case: the return convention is different.
-    IF_NOT_REG_R1(Sp_adj(-2); 
-		  Sp(1) = stg_NO_FINALIZER_closure;
-		  Sp(0) = stg_ut_1_0_unreg_info;)
     R3 = trec; // passing to stmWaitUnblock()
     jump stg_block_stmwait;
   } else {
@@ -1421,7 +1508,7 @@ isEmptyMVarzh_fast
 {
     /* args: R1 = MVar closure */
 
-    if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
+    if (StgMVar_value(R1) == stg_END_TSO_QUEUE_closure) {
 	RET_N(1);
     } else {
 	RET_N(0);
@@ -1436,7 +1523,8 @@ newMVarzh_fast
     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
   
     mvar = Hp - SIZEOF_StgMVar + WDS(1);
-    SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
+    SET_HDR(mvar,stg_MVAR_DIRTY_info,W_[CCCS]);
+        // MVARs start dirty: generation 0 has no mutable list
     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
@@ -1444,16 +1532,9 @@ newMVarzh_fast
 }
 
 
-/* If R1 isn't available, pass it on the stack */
-#ifdef REG_R1
 #define PerformTake(tso, value)				\
     W_[StgTSO_sp(tso) + WDS(1)] = value;		\
     W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
-#else
-#define PerformTake(tso, value)					\
-    W_[StgTSO_sp(tso) + WDS(1)] = value;			\
-    W_[StgTSO_sp(tso) + WDS(0)] = stg_ut_1_0_unreg_info;
-#endif
 
 #define PerformPut(tso,lval)			\
     StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3);	\
@@ -1471,21 +1552,28 @@ takeMVarzh_fast
 #else
     info = GET_INFO(mvar);
 #endif
+        
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr") [];
+    }
 
     /* If the MVar is empty, put ourselves on its blocking queue,
      * and wait until we're woken up.
      */
-    if (info == stg_EMPTY_MVAR_info) {
+    if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	    StgMVar_head(mvar) = CurrentTSO;
 	} else {
-	    StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
+            foreign "C" setTSOLink(MyCapability() "ptr", 
+                                   StgMVar_tail(mvar) "ptr",
+                                   CurrentTSO) [];
 	}
-	StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
+	StgTSO__link(CurrentTSO)       = stg_END_TSO_QUEUE_closure;
 	StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
 	StgTSO_block_info(CurrentTSO)  = mvar;
 	StgMVar_tail(mvar) = CurrentTSO;
 	
+        R1 = mvar;
 	jump stg_block_takemvar;
   }
 
@@ -1502,24 +1590,23 @@ takeMVarzh_fast
       /* actually perform the putMVar for the thread that we just woke up */
       tso = StgMVar_head(mvar);
       PerformPut(tso,StgMVar_value(mvar));
-      dirtyTSO(tso);
 
-#if defined(GRAN) || defined(PAR)
-      /* ToDo: check 2nd arg (mvar) is right */
-      ("ptr" tso) = foreign "C" unblockOne(StgMVar_head(mvar),mvar) [];
-      StgMVar_head(mvar) = tso;
-#else
-      ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", 
-				         StgMVar_head(mvar) "ptr") [];
+      if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+          foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
+      }
+
+      ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr", 
+                                            StgMVar_head(mvar) "ptr", 1) [];
       StgMVar_head(mvar) = tso;
-#endif
 
       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	  StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
       }
 
 #if defined(THREADED_RTS)
-      unlockClosure(mvar, stg_FULL_MVAR_info);
+      unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+      SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
       RET_P(val);
   } 
@@ -1529,9 +1616,9 @@ takeMVarzh_fast
       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
  
 #if defined(THREADED_RTS)
-      unlockClosure(mvar, stg_EMPTY_MVAR_info);
+      unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-      SET_INFO(mvar,stg_EMPTY_MVAR_info);
+      SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
 
       RET_P(val);
@@ -1553,9 +1640,9 @@ tryTakeMVarzh_fast
     info = GET_INFO(mvar);
 #endif
 
-    if (info == stg_EMPTY_MVAR_info) {
+    if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
-        unlockClosure(mvar, stg_EMPTY_MVAR_info);
+        unlockClosure(mvar, info);
 #endif
 	/* HACK: we need a pointer to pass back, 
 	 * so we abuse NO_FINALIZER_closure
@@ -1563,6 +1650,10 @@ tryTakeMVarzh_fast
 	RET_NP(0, stg_NO_FINALIZER_closure);
     }
 
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
     /* we got the value... */
     val = StgMVar_value(mvar);
 
@@ -1576,23 +1667,21 @@ tryTakeMVarzh_fast
 	/* actually perform the putMVar for the thread that we just woke up */
 	tso = StgMVar_head(mvar);
 	PerformPut(tso,StgMVar_value(mvar));
-        dirtyTSO(tso);
+        if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+            foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
+        }
 
-#if defined(GRAN) || defined(PAR)
-	/* ToDo: check 2nd arg (mvar) is right */
-	("ptr" tso) = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") [];
-	StgMVar_head(mvar) = tso;
-#else
-	("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr",
-					   StgMVar_head(mvar) "ptr") [];
+        ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr", 
+                                              StgMVar_head(mvar) "ptr", 1) [];
 	StgMVar_head(mvar) = tso;
-#endif
 
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	    StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
 	}
 #if defined(THREADED_RTS)
-        unlockClosure(mvar, stg_FULL_MVAR_info);
+        unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+        SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     else 
@@ -1600,9 +1689,9 @@ tryTakeMVarzh_fast
 	/* No further putMVars, MVar is now empty */
 	StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_EMPTY_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-	SET_INFO(mvar,stg_EMPTY_MVAR_info);
+	SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     
@@ -1612,28 +1701,37 @@ 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
 
-    if (info == stg_FULL_MVAR_info) {
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
+    if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	    StgMVar_head(mvar) = CurrentTSO;
 	} else {
-	    StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
+            foreign "C" setTSOLink(MyCapability() "ptr", 
+                                   StgMVar_tail(mvar) "ptr",
+                                   CurrentTSO) [];
 	}
-	StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
+	StgTSO__link(CurrentTSO)       = stg_END_TSO_QUEUE_closure;
 	StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
 	StgTSO_block_info(CurrentTSO)  = mvar;
 	StgMVar_tail(mvar) = CurrentTSO;
 	
+        R1 = mvar;
+        R2 = val;
 	jump stg_block_putmvar;
     }
   
@@ -1645,36 +1743,35 @@ putMVarzh_fast
 
 	/* actually perform the takeMVar */
 	tso = StgMVar_head(mvar);
-	PerformTake(tso, R2);
-        dirtyTSO(tso);
+	PerformTake(tso, val);
+        if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+            foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
+        }
       
-#if defined(GRAN) || defined(PAR)
-	/* ToDo: check 2nd arg (mvar) is right */
-	("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
+        ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr", 
+                                              StgMVar_head(mvar) "ptr", 1) [];
 	StgMVar_head(mvar) = tso;
-#else
-	("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
-	StgMVar_head(mvar) = tso;
-#endif
 
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	    StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
 	}
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_EMPTY_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+        SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
 	jump %ENTRY_CODE(Sp(0));
     }
     else
     {
 	/* No further takes, the MVar is now full. */
-	StgMVar_value(mvar) = R2;
+	StgMVar_value(mvar) = val;
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_FULL_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-	SET_INFO(mvar,stg_FULL_MVAR_info);
+	SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
 	jump %ENTRY_CODE(Sp(0));
     }
@@ -1696,13 +1793,17 @@ tryPutMVarzh_fast
     info = GET_INFO(mvar);
 #endif
 
-    if (info == stg_FULL_MVAR_info) {
+    if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_FULL_MVAR_info);
+    	unlockClosure(mvar, info);
 #endif
 	RET_N(0);
     }
   
+    if (info == stg_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
 
 	/* There are takeMVar(s) waiting: wake up the first one
@@ -1712,23 +1813,22 @@ tryPutMVarzh_fast
 	/* actually perform the takeMVar */
 	tso = StgMVar_head(mvar);
 	PerformTake(tso, R2);
-        dirtyTSO(tso);
+        if (TO_W_(StgTSO_flags(tso)) & TSO_DIRTY == 0) {
+            foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
+        }
       
-#if defined(GRAN) || defined(PAR)
-	/* ToDo: check 2nd arg (mvar) is right */
-	("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
-	StgMVar_head(mvar) = tso;
-#else
-	("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
+        ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr", 
+                                              StgMVar_head(mvar) "ptr", 1) [];
 	StgMVar_head(mvar) = tso;
-#endif
 
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 	    StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
 	}
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_EMPTY_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
+#else
+        SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     else
@@ -1737,9 +1837,9 @@ tryPutMVarzh_fast
 	StgMVar_value(mvar) = R2;
 
 #if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_FULL_MVAR_info);
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
 #else
-	SET_INFO(mvar,stg_FULL_MVAR_info);
+	SET_INFO(mvar,stg_MVAR_DIRTY_info);
 #endif
     }
     
@@ -1869,7 +1969,7 @@ unpackClosurezh_fast
 // TODO: Consider the absence of ptrs or nonptrs as a special case ?
 
     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
-    info  = %GET_STD_INFO(R1);
+    info  = %GET_STD_INFO(UNTAG(R1));
 
     // Some closures have non-standard layout, so we omit those here.
     W_ type;
@@ -1899,6 +1999,9 @@ out:
 
     ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast);
 
+    W_ clos;
+    clos = UNTAG(R1);
+
     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
 
@@ -1907,7 +2010,7 @@ out:
     p = 0;
 for:
     if(p < ptrs) {
-    	 W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(R1,p);
+    	 W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
 	 p = p + 1;
 	 goto for;
     }
@@ -1917,7 +2020,7 @@ for:
     p = 0;
 for2:
     if(p < nptrs) {
-    	 W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(R1, p+ptrs);
+    	 W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
     	 p = p + 1;
 	 goto for2;
     }
@@ -1932,11 +2035,11 @@ for2:
  * macro in Schedule.h).
  */
 #define APPEND_TO_BLOCKED_QUEUE(tso)			\
-    ASSERT(StgTSO_link(tso) == END_TSO_QUEUE);		\
+    ASSERT(StgTSO__link(tso) == END_TSO_QUEUE);		\
     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {	\
       W_[blocked_queue_hd] = tso;			\
     } else {						\
-      StgTSO_link(W_[blocked_queue_tl]) = tso;		\
+      foreign "C" setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso) []; \
     }							\
     W_[blocked_queue_tl] = tso;
 
@@ -1944,7 +2047,7 @@ waitReadzh_fast
 {
     /* args: R1 */
 #ifdef THREADED_RTS
-    foreign "C" barf("waitRead# on threaded RTS");
+    foreign "C" barf("waitRead# on threaded RTS") never returns;
 #else
 
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
@@ -1961,7 +2064,7 @@ waitWritezh_fast
 {
     /* args: R1 */
 #ifdef THREADED_RTS
-    foreign "C" barf("waitWrite# on threaded RTS");
+    foreign "C" barf("waitWrite# on threaded RTS") never returns;
 #else
 
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
@@ -1986,7 +2089,7 @@ delayzh_fast
 #endif
 
 #ifdef THREADED_RTS
-    foreign "C" barf("delay# on threaded RTS");
+    foreign "C" barf("delay# on threaded RTS") never returns;
 #else
 
     /* args: R1 (microsecond delay amount) */
@@ -1998,7 +2101,7 @@ delayzh_fast
     /* could probably allocate this on the heap instead */
     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
 					    stg_delayzh_malloc_str);
-    reqID = foreign "C" addDelayRequest(R1);
+    (reqID) = foreign "C" addDelayRequest(R1);
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
     StgAsyncIOResult_errCode(ares) = 0;
@@ -2017,7 +2120,11 @@ delayzh_fast
     W_ time;
     W_ divisor;
     (time) = foreign "C" getourtimeofday() [R1];
-    divisor = TO_W_(RtsFlags_MiscFlags_tickInterval(RtsFlags))*1000;
+    divisor = TO_W_(RtsFlags_MiscFlags_tickInterval(RtsFlags));
+    if (divisor == 0) {
+        divisor = 50;
+    }
+    divisor = divisor * 1000;
     target = ((R1 + divisor - 1) / divisor) /* divide rounding up */
            + time + 1; /* Add 1 as getourtimeofday rounds down */
     StgTSO_block_info(CurrentTSO) = target;
@@ -2028,15 +2135,15 @@ delayzh_fast
 while:
     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
 	prev = t;
-	t = StgTSO_link(t);
+	t = StgTSO__link(t);
 	goto while;
     }
 
-    StgTSO_link(CurrentTSO) = t;
+    StgTSO__link(CurrentTSO) = t;
     if (prev == NULL) {
 	W_[sleeping_queue] = CurrentTSO;
     } else {
-	StgTSO_link(prev) = CurrentTSO;
+        foreign "C" setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO) [];
     }
     jump stg_block_noregs;
 #endif
@@ -2052,7 +2159,7 @@ asyncReadzh_fast
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncRead# on threaded RTS");
+    foreign "C" barf("asyncRead# on threaded RTS") never returns;
 #else
 
     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
@@ -2060,10 +2167,10 @@ asyncReadzh_fast
     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
 
     /* could probably allocate this on the heap instead */
-    "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+    ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
 					    stg_asyncReadzh_malloc_str)
 			[R1,R2,R3,R4];
-    reqID = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr") [];
+    (reqID) = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr") [];
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
     StgAsyncIOResult_errCode(ares) = 0;
@@ -2080,17 +2187,17 @@ asyncWritezh_fast
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncWrite# on threaded RTS");
+    foreign "C" barf("asyncWrite# on threaded RTS") never returns;
 #else
 
     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
 
-    "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+    ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
 					    stg_asyncWritezh_malloc_str)
 			[R1,R2,R3,R4];
-    reqID = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr") [];
+    (reqID) = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr") [];
 
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
@@ -2108,7 +2215,7 @@ asyncDoProczh_fast
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncDoProc# on threaded RTS");
+    foreign "C" barf("asyncDoProc# on threaded RTS") never returns;
 #else
 
     /* args: R1 = proc, R2 = param */
@@ -2116,10 +2223,10 @@ asyncDoProczh_fast
     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
 
     /* could probably allocate this on the heap instead */
-    "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+    ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
 					    stg_asyncDoProczh_malloc_str) 
 				[R1,R2];
-    reqID = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr") [];
+    (reqID) = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr") [];
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
     StgAsyncIOResult_errCode(ares) = 0;