Commit 21f0f561 authored by Mitsutoshi Aoe's avatar Mitsutoshi Aoe Committed by Ben Gamari

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
parent 8546afc5
......@@ -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
......
......@@ -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
......@@ -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);
......
......@@ -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 )
......
......@@ -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) \
......
......@@ -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
......
......@@ -205,6 +205,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
......
......@@ -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;
}
}
......
......@@ -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);
/*
......
......@@ -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
......
{-# 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', () #)
traceBinaryEvent: Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out
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)
traceEvent: Event size exceeds EVENT_PAYLOAD_SIZE_MAX, bail out
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment