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

2 files changed, 51 insertions, 6 deletions

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);
 
 /*