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

5 files changed, 36 insertions, 0 deletions

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