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

14 files changed, 130 insertions, 9 deletions

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index d4a9d7bd45..2f8ced7de8 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -3154,17 +3154,27 @@ primop  TraceEventOp "traceEvent#" GenPrimOp
    Addr# -> State# s -> State# s
    { Emits an event via the RTS tracing framework.  The contents
      of the event is the zero-terminated byte string passed as the first
-     argument.  The event will be emitted either to the .eventlog file,
+     argument.  The event will be emitted either to the {\tt .eventlog} file,
      or to stderr, depending on the runtime RTS flags. }
    with
    has_side_effects = True
    out_of_line      = True
 
+primop  TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp
+   Addr# -> Int# -> State# s -> State# s
+   { Emits an event via the RTS tracing framework.  The contents
+     of the event is the binary object passed as the first argument with
+     the the given length passed as the second argument. The event will be
+     emitted to the {\tt .eventlog} file. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
 primop  TraceMarkerOp "traceMarker#" GenPrimOp
    Addr# -> State# s -> State# s
    { Emits a marker event via the RTS tracing framework.  The contents
      of the event is the zero-terminated byte string passed as the first
-     argument.  The event will be emitted either to the .eventlog file,
+     argument.  The event will be emitted either to the {\tt .eventlog} file,
      or to stderr, depending on the runtime RTS flags. }
    with
    has_side_effects = True
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
index ccfe03b5a5..63303c93b7 100644
--- a/includes/rts/EventLogFormat.h
+++ b/includes/rts/EventLogFormat.h
@@ -178,12 +178,15 @@
 #define EVENT_HEAP_PROF_SAMPLE_BEGIN       162
 #define EVENT_HEAP_PROF_SAMPLE_COST_CENTRE 163
 #define EVENT_HEAP_PROF_SAMPLE_STRING      164
+
+#define EVENT_USER_BINARY_MSG              181
+
 /*
  * The highest event code +1 that ghc itself emits. Note that some event
  * ranges higher than this are reserved but not currently emitted by ghc.
  * This must match the size of the EventDesc[] array in EventLog.c
  */
-#define NUM_GHC_EVENT_TAGS        165
+#define NUM_GHC_EVENT_TAGS        182
 
 #if 0  /* DEPRECATED EVENTS: */
 /* we don't actually need to record the thread, it's implicit */
@@ -257,4 +260,5 @@ typedef StgWord16 EventCapsetType;   /* types for EVENT_CAPSET_CREATE */
 typedef StgWord64 EventTaskId;         /* for EVENT_TASK_* */
 typedef StgWord64 EventKernelThreadId; /* for EVENT_TASK_CREATE */
 
+#define EVENT_PAYLOAD_SIZE_MAX STG_WORD16_MAX
 #endif
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 6ae3df1390..5328ed3f4a 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -479,6 +479,7 @@ RTS_FUN_DECL(stg_noDuplicatezh);
 RTS_FUN_DECL(stg_traceCcszh);
 RTS_FUN_DECL(stg_clearCCSzh);
 RTS_FUN_DECL(stg_traceEventzh);
+RTS_FUN_DECL(stg_traceBinaryEventzh);
 RTS_FUN_DECL(stg_traceMarkerzh);
 RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
 RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
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);
 
 /*
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 128aea2a15..d68722d46b 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -139,6 +139,10 @@ test('traceEvent', [ omit_ways(['dyn'] + prof_ways),
                      extra_run_opts('+RTS -ls -RTS') ],
                    compile_and_run, ['-eventlog'])
 
+test('traceBinaryEvent', [ omit_ways(['dyn'] + prof_ways),
+                           extra_run_opts('+RTS -ls -RTS') ],
+                         compile_and_run, ['-eventlog'])
+
 test('T4059', [], run_command, ['$MAKE -s --no-print-directory T4059'])
 
 # Test for #4274
diff --git a/testsuite/tests/rts/traceBinaryEvent.hs b/testsuite/tests/rts/traceBinaryEvent.hs
new file mode 100644
index 0000000000..c174d44bc2
--- /dev/null
+++ b/testsuite/tests/rts/traceBinaryEvent.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+import Data.Word
+import GHC.Base
+import GHC.Ptr
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as BU
+
+main :: IO ()
+main = do
+  traceBinaryEventIO "0123456789"
+  traceBinaryEventIO $ B.replicate 10 0
+  traceBinaryEventIO $ B.replicate (maxSize + 1) 0
+
+maxSize :: Int
+maxSize = fromIntegral (maxBound :: Word16)
+
+traceBinaryEventIO :: B.ByteString -> IO ()
+traceBinaryEventIO bytes =
+  BU.unsafeUseAsCStringLen bytes $ \(Ptr p, I# n) -> IO $ \s -> do
+    case traceBinaryEvent# p n s of
+      s' -> (# s', () #)
diff --git a/testsuite/tests/rts/traceBinaryEvent.stderr b/testsuite/tests/rts/traceBinaryEvent.stderr
new file mode 100644
index 0000000000..354e919e2a
--- /dev/null
+++ b/testsuite/tests/rts/traceBinaryEvent.stderr
@@ -0,0 +1 @@
+traceBinaryEvent: Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out
diff --git a/testsuite/tests/rts/traceEvent.hs b/testsuite/tests/rts/traceEvent.hs
index a5e19a995c..06a2b19584 100644
--- a/testsuite/tests/rts/traceEvent.hs
+++ b/testsuite/tests/rts/traceEvent.hs
@@ -1,5 +1,10 @@
+import Data.Word
 import Debug.Trace
 
 main = do
   traceEventIO "testing"
   traceEventIO "%s" -- see #3874
+  traceEventIO $ replicate (maxSize + 1) 'A'
+
+maxSize :: Int
+maxSize = fromIntegral (maxBound :: Word16)
diff --git a/testsuite/tests/rts/traceEvent.stderr b/testsuite/tests/rts/traceEvent.stderr
new file mode 100644
index 0000000000..6a62dc79e2
--- /dev/null
+++ b/testsuite/tests/rts/traceEvent.stderr
@@ -0,0 +1 @@
+traceEvent: Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out