Annotate thread stop events with the owner of the black hole

So we can now get these in ThreadScope:

  19487000: cap 1: stopping thread 6 (blocked on black hole owned by thread 4)

Note: needs an update to ghc-events.  Older ThreadScopes will just
ignore the new information.

includes/rts/EventLogFormat.h

@@ -101,7 +101,7 @@
  */
 #define EVENT_CREATE_THREAD        0 /* (thread)               */
 #define EVENT_RUN_THREAD           1 /* (thread)               */
-#define EVENT_STOP_THREAD          2 /* (thread, status)       */
+#define EVENT_STOP_THREAD          2 /* (thread, status, blockinfo) */
 #define EVENT_THREAD_RUNNABLE      3 /* (thread)               */
 #define EVENT_MIGRATE_THREAD       4 /* (thread, new_cap)      */
 #define EVENT_RUN_SPARK            5 /* (thread)               */
@@ -138,6 +138,17 @@
  * #define ThreadYielding 3
  * #define ThreadBlocked  4
  * #define ThreadFinished 5
+ * #define ForeignCall                  6
+ * #define BlockedOnMVar                7
+ * #define BlockedOnBlackHole           8
+ * #define BlockedOnRead                9
+ * #define BlockedOnWrite               10
+ * #define BlockedOnDelay               11
+ * #define BlockedOnSTM                 12
+ * #define BlockedOnDoProc              13
+ * #define BlockedOnCCall               -- not used (see ForeignCall)
+ * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)
+ * #define BlockedOnMsgThrowTo          16
  */
 #define THREAD_SUSPENDED_FOREIGN_CALL 6
 

rts/Messages.c

@@ -303,3 +303,46 @@ loop:
     return 0; // not blocked
 }
 
+// A shorter version of messageBlackHole(), that just returns the
+// owner (or NULL if the owner cannot be found, because the blackhole
+// has been updated in the meantime).
+
+StgTSO * blackHoleOwner (StgClosure *bh)
+{
+    const StgInfoTable *info;
+    StgClosure *p;
+
+    info = bh->header.info;
+
+    if (info != &stg_BLACKHOLE_info &&
+        info != &stg_CAF_BLACKHOLE_info && 
+        info != &__stg_EAGER_BLACKHOLE_info &&
+        info != &stg_WHITEHOLE_info) {
+        return NULL;
+    }
+
+    // The blackhole must indirect to a TSO, a BLOCKING_QUEUE, an IND,
+    // or a value.
+loop:
+    // NB. VOLATILE_LOAD(), because otherwise gcc hoists the load
+    // and turns this into an infinite loop.
+    p = UNTAG_CLOSURE((StgClosure*)VOLATILE_LOAD(&((StgInd*)bh)->indirectee));
+    info = p->header.info;
+
+    if (info == &stg_IND_info) goto loop;
+
+    else if (info == &stg_TSO_info)
+    {
+        return (StgTSO*)p;
+    }
+    else if (info == &stg_BLOCKING_QUEUE_CLEAN_info || 
+             info == &stg_BLOCKING_QUEUE_DIRTY_info)
+    {
+        StgBlockingQueue *bq = (StgBlockingQueue *)p;
+        return bq->owner;
+    }
+    
+    return NULL; // not blocked
+}
+
+

rts/Messages.h

@@ -9,6 +9,7 @@
 #include "BeginPrivate.h"
 
 nat messageBlackHole(Capability *cap, MessageBlackHole *msg);
+StgTSO * blackHoleOwner (StgClosure *bh);
 
 #ifdef THREADED_RTS
 void executeMessage (Capability *cap, Message *m);

rts/RtsProbes.d

@@ -36,7 +36,7 @@ provider HaskellEvent {
   // scheduler events
   probe create__thread (EventCapNo, EventThreadID);
   probe run__thread (EventCapNo, EventThreadID);
-  probe stop__thread (EventCapNo, EventThreadID, EventThreadStatus);
+  probe stop__thread (EventCapNo, EventThreadID, EventThreadStatus, EventThreadID);
   probe thread__runnable (EventCapNo, EventThreadID);
   probe migrate__thread (EventCapNo, EventThreadID, EventCapNo);
   probe run__spark (EventCapNo, EventThreadID);

rts/Schedule.c

@@ -484,7 +484,17 @@ run_thread:
     t->saved_winerror = GetLastError();
 #endif
 
-    traceEventStopThread(cap, t, ret);
+    if (ret == ThreadBlocked) {
+        if (t->why_blocked == BlockedOnBlackHole) {
+            StgTSO *owner = blackHoleOwner(t->block_info.bh->bh);
+            traceEventStopThread(cap, t, t->why_blocked + 6,
+                                 owner != NULL ? owner->id : 0);
+        } else {
+            traceEventStopThread(cap, t, t->why_blocked + 6, 0);
+        }
+    } else {
+        traceEventStopThread(cap, t, ret, 0);
+    }
 
     ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task);
     ASSERT(t->cap == cap);
@@ -1724,7 +1734,7 @@ suspendThread (StgRegTable *reg, rtsBool interruptible)
   task = cap->running_task;
   tso = cap->r.rCurrentTSO;
 
-  traceEventStopThread(cap, tso, THREAD_SUSPENDED_FOREIGN_CALL);
+  traceEventStopThread(cap, tso, THREAD_SUSPENDED_FOREIGN_CALL, 0);
 
   // XXX this might not be necessary --SDM
   tso->what_next = ThreadRunGHC;

rts/Trace.c

@@ -137,14 +137,26 @@ static char *thread_stop_reasons[] = {
     [ThreadYielding] = "yielding",
     [ThreadBlocked] = "blocked",
     [ThreadFinished] = "finished",
-    [THREAD_SUSPENDED_FOREIGN_CALL] = "suspended while making a foreign call"
+    [THREAD_SUSPENDED_FOREIGN_CALL] = "suspended while making a foreign call",
+    [6 + BlockedOnMVar]         = "blocked on an MVar",
+    [6 + BlockedOnBlackHole]    = "blocked on a black hole",
+    [6 + BlockedOnRead]         = "blocked on a read operation",
+    [6 + BlockedOnWrite]        = "blocked on a write operation",
+    [6 + BlockedOnDelay]        = "blocked on a delay operation",
+    [6 + BlockedOnSTM]          = "blocked on STM",
+    [6 + BlockedOnDoProc]       = "blocked on asyncDoProc",
+    [6 + BlockedOnCCall]        = "blocked on a foreign call",
+    [6 + BlockedOnCCall_Interruptible] = "blocked on a foreign call (interruptible)",
+    [6 + BlockedOnMsgThrowTo]   =  "blocked on throwTo",
+    [6 + ThreadMigrating]       =  "migrating"
 };
 #endif
 
 #ifdef DEBUG
 static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, 
                                     StgTSO *tso, 
-                                    StgWord64 other STG_UNUSED)
+                                    StgWord info1 STG_UNUSED,
+                                    StgWord info2 STG_UNUSED)
 {
     ACQUIRE_LOCK(&trace_utx);
 
@@ -168,24 +180,29 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag,
         break;
     case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread)
         debugBelch("cap %d: creating spark thread %lu\n", 
-                   cap->no, (long)other);
+                   cap->no, (long)info1);
         break;
     case EVENT_MIGRATE_THREAD:  // (cap, thread, new_cap)
         debugBelch("cap %d: thread %lu migrating to cap %d\n", 
-                   cap->no, (lnat)tso->id, (int)other);
+                   cap->no, (lnat)tso->id, (int)info1);
         break;
     case EVENT_STEAL_SPARK:     // (cap, thread, victim_cap)
         debugBelch("cap %d: thread %lu stealing a spark from cap %d\n", 
-                   cap->no, (lnat)tso->id, (int)other);
+                   cap->no, (lnat)tso->id, (int)info1);
         break;
-    case EVENT_THREAD_WAKEUP:   // (cap, thread, other_cap)
+    case EVENT_THREAD_WAKEUP:   // (cap, thread, info1_cap)
         debugBelch("cap %d: waking up thread %lu on cap %d\n", 
-                   cap->no, (lnat)tso->id, (int)other);
+                   cap->no, (lnat)tso->id, (int)info1);
         break;
         
     case EVENT_STOP_THREAD:     // (cap, thread, status)
-        debugBelch("cap %d: thread %lu stopped (%s)\n", 
-                   cap->no, (lnat)tso->id, thread_stop_reasons[other]);
+        if (info1 == 6 + BlockedOnBlackHole) {
+            debugBelch("cap %d: thread %lu stopped (blocked on black hole owned by thread %lu)\n",
+                       cap->no, (lnat)tso->id, (long)info2);
+        } else {
+            debugBelch("cap %d: thread %lu stopped (%s)\n",
+                       cap->no, (lnat)tso->id, thread_stop_reasons[info1]);
+        }
         break;
     case EVENT_SHUTDOWN:        // (cap)
         debugBelch("cap %d: shutting down\n", cap->no);
@@ -222,15 +239,15 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag,
 #endif
 
 void traceSchedEvent_ (Capability *cap, EventTypeNum tag, 
-                      StgTSO *tso, StgWord64 other)
+                       StgTSO *tso, StgWord info1, StgWord info2)
 {
 #ifdef DEBUG
     if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
-        traceSchedEvent_stderr(cap, tag, tso, other);
+        traceSchedEvent_stderr(cap, tag, tso, info1, info2);
     } else
 #endif
     {
-        postSchedEvent(cap,tag,tso ? tso->id : 0,other);
+        postSchedEvent(cap,tag,tso ? tso->id : 0, info1, info2);
     }
 }
 
@@ -238,7 +255,7 @@ void traceEvent_ (Capability *cap, EventTypeNum tag)
 {
 #ifdef DEBUG
     if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
-        traceSchedEvent_stderr(cap, tag, 0, 0);
+        traceSchedEvent_stderr(cap, tag, 0, 0, 0);
     } else
 #endif
     {

rts/Trace.h

@@ -78,11 +78,16 @@ void traceEnd (void);
  */
 #define traceSchedEvent(cap, tag, tso, other)   \
     if (RTS_UNLIKELY(TRACE_sched)) {            \
-        traceSchedEvent_(cap, tag, tso, other); \
+        traceSchedEvent_(cap, tag, tso, other, 0); \
+    }
+
+#define traceSchedEvent2(cap, tag, tso, info1, info2) \
+    if (RTS_UNLIKELY(TRACE_sched)) {            \
+        traceSchedEvent_(cap, tag, tso, info1, info2); \
     }
 
 void traceSchedEvent_ (Capability *cap, EventTypeNum tag, 
-                       StgTSO *tso, StgWord64 other);
+                       StgTSO *tso, StgWord info1, StgWord info2);
 
 
 /*
@@ -158,6 +163,7 @@ void traceThreadStatus_ (StgTSO *tso);
 #else /* !TRACING */
 
 #define traceSchedEvent(cap, tag, tso, other) /* nothing */
+#define traceSchedEvent2(cap, tag, tso, other, info) /* nothing */
 #define traceEvent(cap, tag) /* nothing */
 #define traceCap(class, cap, msg, ...) /* nothing */
 #define trace(class, msg, ...) /* nothing */
@@ -186,8 +192,8 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
     HASKELLEVENT_CREATE_THREAD(cap, tid)
 #define dtraceRunThread(cap, tid)                       \
     HASKELLEVENT_RUN_THREAD(cap, tid)
-#define dtraceStopThread(cap, tid, status)              \
-    HASKELLEVENT_STOP_THREAD(cap, tid, status)
+#define dtraceStopThread(cap, tid, status, info)        \
+    HASKELLEVENT_STOP_THREAD(cap, tid, status, info)
 #define dtraceThreadRunnable(cap, tid)                  \
     HASKELLEVENT_THREAD_RUNNABLE(cap, tid)
 #define dtraceMigrateThread(cap, tid, new_cap)          \
@@ -225,7 +231,7 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
 
 #define dtraceCreateThread(cap, tid)                    /* nothing */
 #define dtraceRunThread(cap, tid)                       /* nothing */
-#define dtraceStopThread(cap, tid, status)              /* nothing */
+#define dtraceStopThread(cap, tid, status, info)        /* nothing */
 #define dtraceThreadRunnable(cap, tid)                  /* nothing */
 #define dtraceMigrateThread(cap, tid, new_cap)          /* nothing */
 #define dtraceRunSpark(cap, tid)                        /* nothing */
@@ -278,11 +284,12 @@ INLINE_HEADER void traceEventRunThread(Capability *cap STG_UNUSED,
 
 INLINE_HEADER void traceEventStopThread(Capability          *cap    STG_UNUSED, 
                                         StgTSO              *tso    STG_UNUSED, 
-                                        StgThreadReturnCode  status STG_UNUSED)
+                                        StgThreadReturnCode  status STG_UNUSED,
+                                        StgWord32           info    STG_UNUSED)
 {
-    traceSchedEvent(cap, EVENT_STOP_THREAD, tso, status);
+    traceSchedEvent2(cap, EVENT_STOP_THREAD, tso, status, info);
     dtraceStopThread((EventCapNo)cap->no, (EventThreadID)tso->id,
-                     (EventThreadStatus)status);
+                     (EventThreadStatus)status, (EventThreadID)info);
 }
 
 // needs to be EXTERN_INLINE as it is used in another EXTERN_INLINE function

rts/eventlog/EventLog.c

@@ -252,7 +252,7 @@ initEventLogging(void)
 
         case EVENT_STOP_THREAD:     // (cap, thread, status)
             eventTypes[t].size =
-                sizeof(EventThreadID) + sizeof(StgWord16);
+                sizeof(EventThreadID) + sizeof(StgWord16) + sizeof(EventThreadID);
             break;
 
         case EVENT_STARTUP:         // (cap count)
@@ -382,7 +382,8 @@ void
 postSchedEvent (Capability *cap, 
                 EventTypeNum tag, 
                 StgThreadID thread, 
-                StgWord64 other)
+                StgWord info1,
+                StgWord info2)
 {
     EventsBuf *eb;
 
@@ -407,7 +408,7 @@ postSchedEvent (Capability *cap,
 
     case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread)
     {
-        postThreadID(eb,other /* spark_thread */);
+        postThreadID(eb,info1 /* spark_thread */);
         break;
     }
 
@@ -416,14 +417,15 @@ postSchedEvent (Capability *cap,
     case EVENT_THREAD_WAKEUP:   // (cap, thread, other_cap)
     {
         postThreadID(eb,thread);
-        postCapNo(eb,other /* new_cap | victim_cap | other_cap */);
+        postCapNo(eb,info1 /* new_cap | victim_cap | other_cap */);
         break;
    }
 
     case EVENT_STOP_THREAD:     // (cap, thread, status)
     {
         postThreadID(eb,thread);
-        postWord16(eb,other /* status */);
+        postWord16(eb,info1 /* status */);
+        postThreadID(eb,info2 /* blocked on thread */);
         break;
     }
 

rts/eventlog/EventLog.h

@@ -32,7 +32,7 @@ void flushEventLog(void);     // event log inherited from parent
  * that has an associated thread).
  */
 void postSchedEvent(Capability *cap, EventTypeNum tag, 
-                    StgThreadID id, StgWord64 other);
+                    StgThreadID id, StgWord info1, StgWord info2);
 
 /*
  * Post a nullary event.
@@ -50,7 +50,8 @@ void postCapMsg(Capability *cap, char *msg, va_list ap);
 INLINE_HEADER void postSchedEvent (Capability *cap  STG_UNUSED,
                                    EventTypeNum tag STG_UNUSED,
                                    StgThreadID id   STG_UNUSED,
-                                   StgWord64 other  STG_UNUSED)
+                                   StgWord info1    STG_UNUSED,
+                                   StgWord info2    STG_UNUSED)
 { /* nothing */ }
 
 INLINE_HEADER void postEvent (Capability *cap  STG_UNUSED,