X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FPrimOps.cmm;h=e5427c78d51de8d739021fa677f61407cffb44f8;hb=661c97c65e5fa47177502e592bb763f752b487ac;hp=d7cc3e82ec2340f4db1ae12ac794724e61920188;hpb=4180687e4fa56dd82407ba950e89bb6e09006fc3;p=ghc-hetmet.git

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index d7cc3e8..e5427c7 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -35,7 +35,9 @@ import base_ControlziExceptionziBase_nestedAtomically_closure;
 import EnterCriticalSection;
 import LeaveCriticalSection;
 import ghczmprim_GHCziBool_False_closure;
+#if !defined(mingw32_HOST_OS)
 import sm_mutex;
+#endif
 
 /*-----------------------------------------------------------------------------
   Array Primitives
@@ -542,9 +544,9 @@ stg_forkzh
 				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));
+  StgTSO_flags(threadid) = %lobits16(
+     TO_W_(StgTSO_flags(threadid)) | 
+     TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
 
   foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];
 
@@ -572,9 +574,9 @@ stg_forkOnzh
 				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));
+  StgTSO_flags(threadid) = %lobits16(
+     TO_W_(StgTSO_flags(threadid)) | 
+     TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
 
   foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
 
@@ -1138,7 +1140,7 @@ stg_newMVarzh
 
 stg_takeMVarzh
 {
-    W_ mvar, val, info, tso;
+    W_ mvar, val, info, tso, q;
 
     /* args: R1 = MVar closure */
     mvar = R1;
@@ -1157,80 +1159,92 @@ stg_takeMVarzh
      * and wait until we're woken up.
      */
     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
+        
+        // Note [mvar-heap-check] We want to do the heap check in the
+        // branch here, to avoid the conditional in the common case.
+        // However, we've already locked the MVar above, so we better
+        // be careful to unlock it again if the the heap check fails.
+        // Unfortunately we don't have an easy way to inject any code
+        // into the heap check generated by the code generator, so we
+        // have to do it in stg_gc_gen (see HeapStackCheck.cmm).
+        HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR, stg_takeMVarzh);
+
+        q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
+
+        SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
+        StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
+        StgMVarTSOQueue_tso(q)  = CurrentTSO;
+
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-	    StgMVar_head(mvar) = CurrentTSO;
+	    StgMVar_head(mvar) = q;
 	} else {
-            foreign "C" setTSOLink(MyCapability() "ptr", 
-                                   StgMVar_tail(mvar) "ptr",
-                                   CurrentTSO) [];
+            StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
+            foreign "C" recordClosureMutated(MyCapability() "ptr",
+                                             StgMVar_tail(mvar)) [];
 	}
-	StgTSO__link(CurrentTSO)       = stg_END_TSO_QUEUE_closure;
+	StgTSO__link(CurrentTSO)       = q;
 	StgTSO_block_info(CurrentTSO)  = mvar;
-        // write barrier for throwTo(), which looks at block_info
-        // if why_blocked==BlockedOnMVar.
-        prim %write_barrier() [];
 	StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
-	StgMVar_tail(mvar) = CurrentTSO;
+	StgMVar_tail(mvar)             = q;
 	
         R1 = mvar;
 	jump stg_block_takemvar;
-  }
-
-  /* we got the value... */
-  val = StgMVar_value(mvar);
-
-  if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure)
-  {
-      /* There are putMVar(s) waiting... 
-       * wake up the first thread on the queue
-       */
-      ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
-
-      /* actually perform the putMVar for the thread that we just woke up */
-      tso = StgMVar_head(mvar);
-      PerformPut(tso,StgMVar_value(mvar));
+    }
+    
+    /* we got the value... */
+    val = StgMVar_value(mvar);
+    
+    q = StgMVar_head(mvar);
+loop:
+    if (q == stg_END_TSO_QUEUE_closure) {
+        /* No further putMVars, MVar is now empty */
+        StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
+        unlockClosure(mvar, stg_MVAR_DIRTY_info);
+        RET_P(val);
+    }
+    if (StgHeader_info(q) == stg_IND_info ||
+        StgHeader_info(q) == stg_MSG_NULL_info) {
+        q = StgInd_indirectee(q);
+        goto loop;
+    }
+    
+    // There are putMVar(s) waiting... wake up the first thread on the queue
+    
+    tso = StgMVarTSOQueue_tso(q);
+    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
+    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+    }
 
-      if (TO_W_(StgTSO_dirty(tso)) == 0) {
-          foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
-      }
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
 
-      ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr", 
-                                            StgMVar_head(mvar) "ptr", 1) [];
-      StgMVar_head(mvar) = tso;
+    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
+    ASSERT(StgTSO_block_info(tso) == mvar);
 
-      if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-	  StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
-      }
+    // actually perform the putMVar for the thread that we just woke up
+    PerformPut(tso,StgMVar_value(mvar));
 
-#if defined(THREADED_RTS)
-      unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
-      SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
-      RET_P(val);
-  } 
-  else
-  {
-      /* No further putMVars, MVar is now empty */
-      StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
- 
-#if defined(THREADED_RTS)
-      unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
-      SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
+    // indicate that the MVar operation has now completed.
+    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
+    
+    // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
 
-      RET_P(val);
-  }
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
+    
+    unlockClosure(mvar, stg_MVAR_DIRTY_info);
+    RET_P(val);
 }
 
 
 stg_tryTakeMVarzh
 {
-    W_ mvar, val, info, tso;
+    W_ mvar, val, info, tso, q;
 
     /* args: R1 = MVar closure */
-
     mvar = R1;
 
 #if defined(THREADED_RTS)
@@ -1238,7 +1252,10 @@ stg_tryTakeMVarzh
 #else
     info = GET_INFO(mvar);
 #endif
-
+        
+    /* If the MVar is empty, put ourselves on its blocking queue,
+     * and wait until we're woken up.
+     */
     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
         unlockClosure(mvar, info);
@@ -1248,59 +1265,63 @@ stg_tryTakeMVarzh
 	 */
 	RET_NP(0, stg_NO_FINALIZER_closure);
     }
-
+    
     if (info == stg_MVAR_CLEAN_info) {
-        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr") [];
     }
 
     /* we got the value... */
     val = StgMVar_value(mvar);
+    
+    q = StgMVar_head(mvar);
+loop:
+    if (q == stg_END_TSO_QUEUE_closure) {
+        /* No further putMVars, MVar is now empty */
+        StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
+        unlockClosure(mvar, stg_MVAR_DIRTY_info);
+        RET_NP(1, val);
+    }
+    if (StgHeader_info(q) == stg_IND_info ||
+        StgHeader_info(q) == stg_MSG_NULL_info) {
+        q = StgInd_indirectee(q);
+        goto loop;
+    }
+    
+    // There are putMVar(s) waiting... wake up the first thread on the queue
+    
+    tso = StgMVarTSOQueue_tso(q);
+    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
+    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+    }
 
-    if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
 
-	/* There are putMVar(s) waiting... 
-	 * wake up the first thread on the queue
-	 */
-	ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
+    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
+    ASSERT(StgTSO_block_info(tso) == mvar);
 
-	/* actually perform the putMVar for the thread that we just woke up */
-	tso = StgMVar_head(mvar);
-	PerformPut(tso,StgMVar_value(mvar));
-        if (TO_W_(StgTSO_dirty(tso)) == 0) {
-            foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
-        }
+    // actually perform the putMVar for the thread that we just woke up
+    PerformPut(tso,StgMVar_value(mvar));
 
-        ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr", 
-                                              StgMVar_head(mvar) "ptr", 1) [];
-	StgMVar_head(mvar) = tso;
+    // indicate that the MVar operation has now completed.
+    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
+    
+    // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
 
-	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-	    StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
-	}
-#if defined(THREADED_RTS)
-        unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
-        SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
-    }
-    else 
-    {
-	/* No further putMVars, MVar is now empty */
-	StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
-#if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
-	SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
-    }
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
     
-    RET_NP(1, val);
+    unlockClosure(mvar, stg_MVAR_DIRTY_info);
+    RET_P(val);
 }
 
 
 stg_putMVarzh
 {
-    W_ mvar, val, info, tso;
+    W_ mvar, val, info, tso, q;
 
     /* args: R1 = MVar, R2 = value */
     mvar = R1;
@@ -1317,84 +1338,99 @@ stg_putMVarzh
     }
 
     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
+
+        // see Note [mvar-heap-check] above
+        HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR & R2_PTR, stg_putMVarzh);
+
+        q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
+
+        SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
+        StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
+        StgMVarTSOQueue_tso(q)  = CurrentTSO;
+
 	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-	    StgMVar_head(mvar) = CurrentTSO;
+	    StgMVar_head(mvar) = q;
 	} else {
-            foreign "C" setTSOLink(MyCapability() "ptr", 
-                                   StgMVar_tail(mvar) "ptr",
-                                   CurrentTSO) [];
+            StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
+            foreign "C" recordClosureMutated(MyCapability() "ptr",
+                                             StgMVar_tail(mvar)) [];
 	}
-	StgTSO__link(CurrentTSO)       = stg_END_TSO_QUEUE_closure;
+	StgTSO__link(CurrentTSO)       = q;
 	StgTSO_block_info(CurrentTSO)  = mvar;
-        // write barrier for throwTo(), which looks at block_info
-        // if why_blocked==BlockedOnMVar.
-        prim %write_barrier() [];
 	StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
-	StgMVar_tail(mvar) = CurrentTSO;
-	
+	StgMVar_tail(mvar)             = q;
+
         R1 = mvar;
         R2 = val;
 	jump stg_block_putmvar;
     }
   
-    if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
+    q = StgMVar_head(mvar);
+loop:
+    if (q == stg_END_TSO_QUEUE_closure) {
+	/* No further takes, the MVar is now full. */
+	StgMVar_value(mvar) = val;
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
+	jump %ENTRY_CODE(Sp(0));
+    }
+    if (StgHeader_info(q) == stg_IND_info ||
+        StgHeader_info(q) == stg_MSG_NULL_info) {
+        q = StgInd_indirectee(q);
+        goto loop;
+    }
 
-	/* There are takeMVar(s) waiting: wake up the first one
-	 */
-	ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
+    // There are takeMVar(s) waiting: wake up the first one
+    
+    tso = StgMVarTSOQueue_tso(q);
+    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
+    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+    }
 
-	/* actually perform the takeMVar */
-	tso = StgMVar_head(mvar);
-	PerformTake(tso, val);
-        if (TO_W_(StgTSO_dirty(tso)) == 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;
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
 
-	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-	    StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
-	}
+    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
+    ASSERT(StgTSO_block_info(tso) == mvar);
 
-#if defined(THREADED_RTS)
-    	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) = val;
+    // actually perform the takeMVar
+    PerformTake(tso, val);
 
-#if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
-	SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
-	jump %ENTRY_CODE(Sp(0));
+    // indicate that the MVar operation has now completed.
+    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
+    
+    if (TO_W_(StgTSO_dirty(tso)) == 0) {
+        foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
     }
     
-    /* ToDo: yield afterward for better communication performance? */
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
+
+    unlockClosure(mvar, stg_MVAR_DIRTY_info);
+    jump %ENTRY_CODE(Sp(0));
 }
 
 
 stg_tryPutMVarzh
 {
-    W_ mvar, info, tso;
+    W_ mvar, val, info, tso, q;
 
     /* 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_MVAR_CLEAN_info) {
+        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
     	unlockClosure(mvar, info);
@@ -1402,51 +1438,51 @@ stg_tryPutMVarzh
 	RET_N(0);
     }
   
-    if (info == stg_MVAR_CLEAN_info) {
-        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    q = StgMVar_head(mvar);
+loop:
+    if (q == stg_END_TSO_QUEUE_closure) {
+	/* No further takes, the MVar is now full. */
+	StgMVar_value(mvar) = val;
+    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
+	jump %ENTRY_CODE(Sp(0));
+    }
+    if (StgHeader_info(q) == stg_IND_info ||
+        StgHeader_info(q) == stg_MSG_NULL_info) {
+        q = StgInd_indirectee(q);
+        goto loop;
     }
 
-    if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
+    // There are takeMVar(s) waiting: wake up the first one
+    
+    tso = StgMVarTSOQueue_tso(q);
+    StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
+    if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+        StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
+    }
 
-	/* There are takeMVar(s) waiting: wake up the first one
-	 */
-	ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
-	
-	/* actually perform the takeMVar */
-	tso = StgMVar_head(mvar);
-	PerformTake(tso, R2);
-        if (TO_W_(StgTSO_dirty(tso)) == 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;
+loop2:
+    if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
+        tso = StgTSO__link(tso);
+        goto loop2;
+    }
 
-	if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-	    StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
-	}
+    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
+    ASSERT(StgTSO_block_info(tso) == mvar);
 
-#if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
-        SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
-    }
-    else
-    {
-	/* No further takes, the MVar is now full. */
-	StgMVar_value(mvar) = R2;
+    // actually perform the takeMVar
+    PerformTake(tso, val);
 
-#if defined(THREADED_RTS)
-    	unlockClosure(mvar, stg_MVAR_DIRTY_info);
-#else
-	SET_INFO(mvar,stg_MVAR_DIRTY_info);
-#endif
+    // indicate that the MVar operation has now completed.
+    StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
+    
+    if (TO_W_(StgTSO_dirty(tso)) == 0) {
+        foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
     }
     
-    RET_N(1);
-    /* ToDo: yield afterward for better communication performance? */
+    foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) [];
+
+    unlockClosure(mvar, stg_MVAR_DIRTY_info);
+    jump %ENTRY_CODE(Sp(0));
 }
 
 
@@ -1845,12 +1881,71 @@ stg_asyncDoProczh
 }
 #endif
 
-// noDuplicate# tries to ensure that none of the thunks under
-// evaluation by the current thread are also under evaluation by
-// another thread.  It relies on *both* threads doing noDuplicate#;
-// the second one will get blocked if they are duplicating some work.
+/* -----------------------------------------------------------------------------
+ * noDuplicate#
+ *
+ * noDuplicate# tries to ensure that none of the thunks under
+ * evaluation by the current thread are also under evaluation by
+ * another thread.  It relies on *both* threads doing noDuplicate#;
+ * the second one will get blocked if they are duplicating some work.
+ *
+ * The idea is that noDuplicate# is used within unsafePerformIO to
+ * ensure that the IO operation is performed at most once.
+ * noDuplicate# calls threadPaused which acquires an exclusive lock on
+ * all the thunks currently under evaluation by the current thread.
+ *
+ * Consider the following scenario.  There is a thunk A, whose
+ * evaluation requires evaluating thunk B, where thunk B is an
+ * unsafePerformIO.  Two threads, 1 and 2, bother enter A.  Thread 2
+ * is pre-empted before it enters B, and claims A by blackholing it
+ * (in threadPaused).  Thread 1 now enters B, and calls noDuplicate#.
+ *
+ *      thread 1                      thread 2
+ *   +-----------+                 +---------------+
+ *   |    -------+-----> A <-------+-------        |
+ *   |  update   |   BLACKHOLE     | marked_update |
+ *   +-----------+                 +---------------+
+ *   |           |                 |               | 
+ *        ...                             ...
+ *   |           |                 +---------------+
+ *   +-----------+
+ *   |     ------+-----> B
+ *   |  update   |   BLACKHOLE
+ *   +-----------+
+ *
+ * At this point: A is a blackhole, owned by thread 2.  noDuplicate#
+ * calls threadPaused, which walks up the stack and
+ *  - claims B on behalf of thread 1
+ *  - then it reaches the update frame for A, which it sees is already
+ *    a BLACKHOLE and is therefore owned by another thread.  Since
+ *    thread 1 is duplicating work, the computation up to the update
+ *    frame for A is suspended, including thunk B.
+ *  - thunk B, which is an unsafePerformIO, has now been reverted to
+ *    an AP_STACK which could be duplicated - BAD!
+ *  - The solution is as follows: before calling threadPaused, we
+ *    leave a frame on the stack (stg_noDuplicate_info) that will call
+ *    noDuplicate# again if the current computation is suspended and
+ *    restarted.
+ *
+ * See the test program in concurrent/prog003 for a way to demonstrate
+ * this.  It needs to be run with +RTS -N3 or greater, and the bug
+ * only manifests occasionally (once very 10 runs or so).
+ * -------------------------------------------------------------------------- */
+
+INFO_TABLE_RET(stg_noDuplicate, RET_SMALL)
+{
+    Sp_adj(1);
+    jump stg_noDuplicatezh;
+}
+
 stg_noDuplicatezh
 {
+    STK_CHK_GEN( WDS(1), NO_PTRS, stg_noDuplicatezh );
+    // leave noDuplicate frame in case the current
+    // computation is suspended and restarted (see above).
+    Sp_adj(-1);
+    Sp(0) = stg_noDuplicate_info;
+
     SAVE_THREAD_STATE();
     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
     foreign "C" threadPaused (MyCapability() "ptr", CurrentTSO "ptr") [];
@@ -1860,10 +1955,18 @@ stg_noDuplicatezh
     } else {
         LOAD_THREAD_STATE();
         ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
+        // remove the stg_noDuplicate frame if it is still there.
+        if (Sp(0) == stg_noDuplicate_info) {
+            Sp_adj(1);
+        }
         jump %ENTRY_CODE(Sp(0));
     }
 }
 
+/* -----------------------------------------------------------------------------
+   Misc. primitives
+   -------------------------------------------------------------------------- */
+
 stg_getApStackValzh
 {
    W_ ap_stack, offset, val, ok;
@@ -1882,10 +1985,6 @@ stg_getApStackValzh
    RET_NP(ok,val);
 }
 
-/* -----------------------------------------------------------------------------
-   Misc. primitives
-   -------------------------------------------------------------------------- */
-
 // Write the cost center stack of the first argument on stderr; return
 // the second.  Possibly only makes sense for already evaluated
 // things?