Add traceBinaryEvent# primop

This adds a new primop called traceBinaryEvent# that takes the length
of binary data and a pointer to the data, then emits it to the eventlog.

There is some example code that uses this primop and the new event:

* [traceBinaryEventIO][1] that calls `traceBinaryEvent#`

* [A patch to ghc-events][2] that parses the new `EVENT_USER_BINARY_MSG`

There's no corresponding issue on Trac but it was discussed at
ghc-devs [3].

[1] https://github.com/maoe/ghc-trace-events/blob
    /fb226011ef1f85a97b4da7cc9d5f98f9fe6316ae/src/Debug/Trace/Binary.hs#L29)
[2] https://github.com/maoe/ghc-events/commit
    /239ca77c24d18cdd10d6d85a0aef98e4a7c56ae6)
[3] https://mail.haskell.org/pipermail/ghc-devs/2018-May/015791.html

Reviewers: bgamari, erikd, simonmar

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D5007

6 files changed, 76 insertions, 6 deletions

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 4e4c6a6947..a5d8553e94 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2405,6 +2405,14 @@ stg_traceEventzh ( W_ msg )
     return ();
 }
 
+stg_traceBinaryEventzh ( W_ msg, W_ len )
+{
+#if defined(TRACING) || defined(DEBUG)
+    ccall traceUserBinaryMsg(MyCapability() "ptr", msg "ptr", len);
+#endif
+    return ();
+}
+
 // Same code as stg_traceEventzh above but a different kind of event
 // Before changing this code, read the comments in the impl above
 stg_traceMarkerzh ( W_ msg )
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 1543a9df5f..79ab3f1d12 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -910,6 +910,7 @@
       SymI_HasProto(stg_traceCcszh)                                     \
       SymI_HasProto(stg_traceEventzh)                                   \
       SymI_HasProto(stg_traceMarkerzh)                                  \
+      SymI_HasProto(stg_traceBinaryEventzh)                             \
       SymI_HasProto(stg_getThreadAllocationCounterzh)                   \
       SymI_HasProto(stg_setThreadAllocationCounterzh)                   \
       SymI_HasProto(getMonotonicNSec)                                   \
diff --git a/rts/Trace.c b/rts/Trace.c
index 02c177fcd8..5b485c4d0f 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -746,6 +746,17 @@ void traceUserMsg(Capability *cap, char *msg)
     dtraceUserMsg(cap->no, msg);
 }
 
+void traceUserBinaryMsg(Capability *cap, uint8_t *msg, size_t size)
+{
+    /* Note: normally we don't check the TRACE_* flags here as they're checked
+       by the wrappers in Trace.h. But traceUserMsg is special since it has no
+       wrapper (it's called from cmm code), so we check TRACE_user here
+     */
+    if (eventlog_enabled && TRACE_user) {
+        postUserBinaryEvent(cap, EVENT_USER_BINARY_MSG, msg, size);
+    }
+}
+
 void traceUserMarker(Capability *cap, char *markername)
 {
     /* Note: traceUserMarker is special since it has no wrapper (it's called
diff --git a/rts/Trace.h b/rts/Trace.h
index d53e92c617..74b960ce31 100644
--- a/rts/Trace.h
+++ b/rts/Trace.h
@@ -206,6 +206,11 @@ void traceUserMsg(Capability *cap, char *msg);
 void traceUserMarker(Capability *cap, char *msg);
 
 /*
+ * A binary message or event emitted by the program
+ */
+void traceUserBinaryMsg(Capability *cap, uint8_t *msg, size_t size);
+
+/*
  * An event to record a Haskell thread's label/name
  * Used by GHC.Conc.labelThread
  */
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index 619d576b93..ee4504e13a 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -105,6 +105,7 @@ char *EventDesc[] = {
   [EVENT_HEAP_PROF_SAMPLE_BEGIN]  = "Start of heap profile sample",
   [EVENT_HEAP_PROF_SAMPLE_STRING] = "Heap profile string sample",
   [EVENT_HEAP_PROF_SAMPLE_COST_CENTRE] = "Heap profile cost-centre sample",
+  [EVENT_USER_BINARY_MSG]     = "User binary message"
 };
 
 // Event type.
@@ -466,6 +467,10 @@ initEventLogging(const EventLogWriter *ev_writer)
             eventTypes[t].size = EVENT_SIZE_DYNAMIC;
             break;
 
+        case EVENT_USER_BINARY_MSG:
+            eventTypes[t].size = EVENT_SIZE_DYNAMIC;
+            break;
+
         default:
             continue; /* ignore deprecated events */
         }
@@ -745,6 +750,10 @@ void postCapsetStrEvent (EventTypeNum tag,
 {
     int strsize = strlen(msg);
     int size = strsize + sizeof(EventCapsetID);
+    if (size > EVENT_PAYLOAD_SIZE_MAX) {
+        errorBelch("Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out");
+        return;
+    }
 
     ACQUIRE_LOCK(&eventBufMutex);
 
@@ -752,7 +761,7 @@ void postCapsetStrEvent (EventTypeNum tag,
         printAndClearEventBuf(&eventBuf);
 
         if (!hasRoomForVariableEvent(&eventBuf, size)){
-            // Event size exceeds buffer size, bail out:
+            errorBelch("Event size exceeds buffer size, bail out");
             RELEASE_LOCK(&eventBufMutex);
             return;
         }
@@ -785,7 +794,7 @@ void postCapsetVecEvent (EventTypeNum tag,
         printAndClearEventBuf(&eventBuf);
 
         if(!hasRoomForVariableEvent(&eventBuf, size)){
-            // Event size exceeds buffer size, bail out:
+            errorBelch("Event size exceeds buffer size, bail out");
             RELEASE_LOCK(&eventBufMutex);
             return;
         }
@@ -1024,14 +1033,43 @@ void postCapMsg(Capability *cap, char *msg, va_list ap)
 
 void postUserEvent(Capability *cap, EventTypeNum type, char *msg)
 {
-    const int size = strlen(msg);
+    const size_t size = strlen(msg);
+    if (size > EVENT_PAYLOAD_SIZE_MAX) {
+        errorBelch("Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out");
+        return;
+    }
+
     EventsBuf *eb = &capEventBuf[cap->no];
+    if (!hasRoomForVariableEvent(eb, size)){
+        printAndClearEventBuf(eb);
+
+        if (!hasRoomForVariableEvent(eb, size)){
+            errorBelch("Event size exceeds buffer size, bail out");
+            return;
+        }
+    }
 
+    postEventHeader(eb, type);
+    postPayloadSize(eb, size);
+    postBuf(eb, (StgWord8*) msg, size);
+}
+
+void postUserBinaryEvent(Capability   *cap,
+                         EventTypeNum  type,
+                         uint8_t      *msg,
+                         size_t        size)
+{
+    if (size > EVENT_PAYLOAD_SIZE_MAX) {
+        errorBelch("Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out");
+        return;
+    }
+
+    EventsBuf *eb = &capEventBuf[cap->no];
     if (!hasRoomForVariableEvent(eb, size)){
         printAndClearEventBuf(eb);
 
         if (!hasRoomForVariableEvent(eb, size)){
-            // Event size exceeds buffer size, bail out:
+            errorBelch("Event size exceeds buffer size, bail out");
             return;
         }
     }
@@ -1047,13 +1085,17 @@ void postThreadLabel(Capability    *cap,
 {
     const int strsize = strlen(label);
     const int size = strsize + sizeof(EventThreadID);
-    EventsBuf *eb = &capEventBuf[cap->no];
+    if (size > EVENT_PAYLOAD_SIZE_MAX) {
+        errorBelch("Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out");
+        return;
+    }
 
+    EventsBuf *eb = &capEventBuf[cap->no];
     if (!hasRoomForVariableEvent(eb, size)){
         printAndClearEventBuf(eb);
 
         if (!hasRoomForVariableEvent(eb, size)){
-            // Event size exceeds buffer size, bail out:
+            errorBelch("Event size exceeds buffer size, bail out");
             return;
         }
     }
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index eae11ede45..1fb7c4a071 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -47,6 +47,9 @@ void postMsg(char *msg, va_list ap);
 
 void postUserEvent(Capability *cap, EventTypeNum type, char *msg);
 
+void postUserBinaryEvent(Capability *cap, EventTypeNum type,
+                         uint8_t *msg, size_t size);
+
 void postCapMsg(Capability *cap, char *msg, va_list ap);
 
 /*