Fix #2783: detect black-hole loops properly

At some point we regressed on detecting simple black-hole loops.  This
happened due to the introduction of duplicate-work detection for
parallelism: a black-hole loop looks very much like duplicate work,
except it's duplicate work being performed by the very same thread.
So we have to detect and handle this case.

4 files changed, 38 insertions, 20 deletions

diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index b23c6c7a48..ce0e555e5f 100644
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -26,7 +26,7 @@ static void raiseAsync (Capability *cap,
 			StgTSO *tso,
 			StgClosure *exception, 
 			rtsBool stop_at_atomically,
-			StgPtr stop_here);
+			StgUpdateFrame *stop_here);
 
 static void removeFromQueues(Capability *cap, StgTSO *tso);
 
@@ -55,12 +55,12 @@ static void performBlockedException (Capability *cap,
 void
 throwToSingleThreaded(Capability *cap, StgTSO *tso, StgClosure *exception)
 {
-    throwToSingleThreaded_(cap, tso, exception, rtsFalse, NULL);
+    throwToSingleThreaded_(cap, tso, exception, rtsFalse);
 }
 
 void
 throwToSingleThreaded_(Capability *cap, StgTSO *tso, StgClosure *exception, 
-		       rtsBool stop_at_atomically, StgPtr stop_here)
+		       rtsBool stop_at_atomically)
 {
     // Thread already dead?
     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
@@ -70,11 +70,11 @@ throwToSingleThreaded_(Capability *cap, StgTSO *tso, StgClosure *exception,
     // Remove it from any blocking queues
     removeFromQueues(cap,tso);
 
-    raiseAsync(cap, tso, exception, stop_at_atomically, stop_here);
+    raiseAsync(cap, tso, exception, stop_at_atomically, NULL);
 }
 
 void
-suspendComputation(Capability *cap, StgTSO *tso, StgPtr stop_here)
+suspendComputation(Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
 {
     // Thread already dead?
     if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) {
@@ -698,10 +698,11 @@ removeFromQueues(Capability *cap, StgTSO *tso)
 
 static void
 raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, 
-	   rtsBool stop_at_atomically, StgPtr stop_here)
+	   rtsBool stop_at_atomically, StgUpdateFrame *stop_here)
 {
     StgRetInfoTable *info;
     StgPtr sp, frame;
+    StgClosure *updatee;
     nat i;
 
     debugTrace(DEBUG_sched,
@@ -728,6 +729,12 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
     // layers should deal with that.
     ASSERT(tso->what_next != ThreadComplete && tso->what_next != ThreadKilled);
 
+    if (stop_here != NULL) {
+        updatee = stop_here->updatee;
+    } else {
+        updatee = NULL;
+    }
+
     // The stack freezing code assumes there's a closure pointer on
     // the top of the stack, so we have to arrange that this is the case...
     //
@@ -739,7 +746,7 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
     }
 
     frame = sp + 1;
-    while (stop_here == NULL || frame < stop_here) {
+    while (stop_here == NULL || frame < (StgPtr)stop_here) {
 
 	// 1. Let the top of the stack be the "current closure"
 	//
@@ -793,11 +800,20 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
 	    //	     printObj((StgClosure *)ap);
 	    //	);
 
-            // Perform the update
-            // TODO: this may waste some work, if the thunk has
-            // already been updated by another thread.
-            UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,
-                           (StgClosure *)ap);
+            if (((StgUpdateFrame *)frame)->updatee == updatee) {
+                // If this update frame points to the same closure as
+                // the update frame further down the stack
+                // (stop_here), then don't perform the update.  We
+                // want to keep the blackhole in this case, so we can
+                // detect and report the loop (#2783).
+                ap = (StgAP_STACK*)updatee;
+            } else {
+                // Perform the update
+                // TODO: this may waste some work, if the thunk has
+                // already been updated by another thread.
+                UPD_IND_NOLOCK(((StgUpdateFrame *)frame)->updatee,
+                               (StgClosure *)ap);
+            }
 
 	    sp += sizeofW(StgUpdateFrame) - 1;
 	    sp[0] = (W_)ap; // push onto stack
diff --git a/rts/RaiseAsync.h b/rts/RaiseAsync.h
index 805281443e..6f7c305d54 100644
--- a/rts/RaiseAsync.h
+++ b/rts/RaiseAsync.h
@@ -20,12 +20,11 @@ void throwToSingleThreaded (Capability *cap,
 void throwToSingleThreaded_ (Capability *cap, 
 			     StgTSO *tso, 
 			     StgClosure *exception, 
-			     rtsBool stop_at_atomically,
-			     StgPtr stop_here);
+			     rtsBool stop_at_atomically);
 
 void suspendComputation (Capability *cap, 
 			 StgTSO *tso, 
-			 StgPtr stop_here);
+			 StgUpdateFrame *stop_here);
 
 nat throwTo (Capability *cap,	         // the Capability we hold 
 	     StgTSO *source,	         // the TSO sending the exception
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 742f3b4987..552c2c9ca6 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -1164,7 +1164,7 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
             // ATOMICALLY_FRAME, aborting the (nested)
             // transaction, and saving the stack of any
             // partially-evaluated thunks on the heap.
-            throwToSingleThreaded_(cap, t, NULL, rtsTrue, NULL);
+            throwToSingleThreaded_(cap, t, NULL, rtsTrue);
             
             ASSERT(get_itbl((StgClosure *)t->sp)->type == ATOMICALLY_FRAME);
         }
diff --git a/rts/ThreadPaused.c b/rts/ThreadPaused.c
index c32a75b9a8..5463deecb8 100644
--- a/rts/ThreadPaused.c
+++ b/rts/ThreadPaused.c
@@ -231,8 +231,10 @@ threadPaused(Capability *cap, StgTSO *tso)
 			   (long)((StgPtr)frame - tso->sp));
 
 		// If this closure is already an indirection, then
-		// suspend the computation up to this point:
-		suspendComputation(cap,tso,(StgPtr)frame);
+		// suspend the computation up to this point.
+		// NB. check raiseAsync() to see what happens when
+		// we're in a loop (#2783).
+		suspendComputation(cap,tso,(StgUpdateFrame*)frame);
 
 		// Now drop the update frame, and arrange to return
 		// the value to the frame underneath:
@@ -242,8 +244,9 @@ threadPaused(Capability *cap, StgTSO *tso)
 
 		// And continue with threadPaused; there might be
 		// yet more computation to suspend.
-		threadPaused(cap,tso);
-		return;
+                frame = (StgClosure *)tso->sp + 2;
+                prev_was_update_frame = rtsFalse;
+                continue;
 	    }
 
 	    if (bh->header.info != &stg_CAF_BLACKHOLE_info) {