Abstract over the way eventlogs are flushed

Currently eventlog data is always written to a file `progname.eventlog`.
This patch introduces the `flushEventLog` field in `RtsConfig` which
allows to customize the writing of eventlog data.

One possible scenario is the ongoing live-profile-monitor effort by
@NCrashed which slurps all eventlog data through `fluchEventLog`.

`flushEventLog` takes a buffer with eventlog data and its size and
returns `false` (0) in case eventlog data could not be procesed.

Reviewers: simonmar, austin, erikd, bgamari

Reviewed By: simonmar, bgamari

Subscribers: qnikst, thomie, NCrashed

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

9 files changed, 281 insertions, 85 deletions

diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index d934418588..3b04975d87 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -240,6 +240,10 @@ Runtime system
   threads to all cores in systems which have multiple processor groups.
   (e.g. > 64 cores, see :ghc-ticket:`11054`)
 
+- Output of :ref:`Event log <rts-eventlog>` data can now be configured.
+  Enabling external tools to collect and analyze the event log data while the
+  application is still running.
+
 Build system
 ~~~~~~~~~~~~
 
diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst
index 4bde81a9d8..3c606c92bf 100644
--- a/docs/users_guide/runtime_control.rst
+++ b/docs/users_guide/runtime_control.rst
@@ -177,6 +177,35 @@ e.g., on stack overflow. The hooks for these are as follows:
 
     The message printed if ``malloc`` fails.
 
+Furthermore GHC lets you specify the way event log data (:rts-flag:`-l`)
+is written through a custom `EventLogWriter`:
+
+``void initEventLogWriter(void)``
+    .. index::
+       single: initEventLogWriter
+
+    Initializes your `EventLogWriter`. This is optional.
+
+``bool writeEventLog(void *eventlog, size_t eventlog_size)``
+    .. index::
+       single: writeEventLog
+
+    Hands buffered event log data to your event log writer.
+    Required for a custom `EventLogWriter`.
+
+ ``void flushEventLog(void)``
+    .. index::
+       single: flushEventLog
+
+    Flush buffers (if any) of your custom `EventLogWriter`. This is
+    optional.
+
+ ``void stopEventLogWriter(void)``
+    .. index::
+       single: stopEventLogWriter
+
+    Called when event logging is about to stop. This is optional.
+
 .. _rts-options-misc:
 
 Miscellaneous RTS options
@@ -938,7 +967,7 @@ Tracing
    single: eventlog files
 
 When the program is linked with the :ghc-flag:`-eventlog` option
-(:ref:`options-linker`), runtime events can be logged in two ways:
+(:ref:`options-linker`), runtime events can be logged in several ways:
 
 -  In binary format to a file for later analysis by a variety of tools.
    One such tool is
@@ -946,13 +975,19 @@ When the program is linked with the :ghc-flag:`-eventlog` option
    which interprets the event log to produce a visual parallel execution
    profile of the program.
 
+-  In binary format to customized event log writer. This enables live
+   analysis of the events while the program is running.
+
 -  As text to standard output, for debugging purposes.
 
 .. rts-flag:: -l <flags>
 
-    Log events in binary format to the file :file:`{program}.eventlog`.
-    Without any ⟨flags⟩ specified, this logs a default set of events,
-    suitable for use with tools like ThreadScope.
+    Log events in binary format. Without any ⟨flags⟩ specified, this
+    logs a default set of events, suitable for use with tools like ThreadScope.
+
+    Per default the events are written to :file:`{program}.eventlog` though
+    the mechanism for writing event log data can be overriden with a custom
+    `EventLogWriter`.
 
     For some special use cases you may want more control over which
     events are included. The ⟨flags⟩ is a sequence of zero or more
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index bf25c011fc..e5326f759b 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -18,6 +18,7 @@ extern "C" {
 
 #include "HsFFI.h"
 #include "rts/Time.h"
+#include "rts/EventLogWriter.h"
 
 /*
  * Running the scheduler
@@ -79,6 +80,9 @@ typedef struct {
     // Whether to retain CAFs (default: false)
     HsBool keep_cafs;
 
+    // Writer a for eventlog.
+    const EventLogWriter *eventlog_writer;
+
     // Called before processing command-line flags, so that default
     // settings for RtsFlags can be provided.
     void (* defaultsHook) (void);
diff --git a/includes/rts/EventLogWriter.h b/includes/rts/EventLogWriter.h
new file mode 100644
index 0000000000..f9cb25fe62
--- /dev/null
+++ b/includes/rts/EventLogWriter.h
@@ -0,0 +1,40 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2017
+ *
+ * Support for fast binary event logging.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef EVENTLOG_WRITER_H
+#define EVENTLOG_WRITER_H
+
+#include <stddef.h>
+#include <stdbool.h>
+
+#include "Rts.h"
+
+/*
+ *  Abstraction for writing eventlog data.
+ */
+typedef struct {
+    // Initialize an EventLogWriter (may be NULL)
+    void (* initEventLogWriter) (void);
+
+    // Write a series of events
+    bool (* writeEventLog) (void *eventlog, size_t eventlog_size);
+
+    // Flush possibly existing buffers (may be NULL)
+    void (* flushEventLog) (void);
+
+    // Close an initialized EventLogOutput (may be NULL)
+    void (* stopEventLogWriter) (void);
+} EventLogWriter;
+
+/*
+ * An EventLogWriter which writes eventlogs to
+ * a file `program.eventlog`.
+ */
+extern const EventLogWriter FileEventLogWriter;
+
+#endif /* EVENTLOG_WRITER_H */
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index c9da13bafc..f924432de4 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -64,6 +64,7 @@ const RtsConfig defaultRtsConfig  = {
     .rts_opts = NULL,
     .rts_hs_main = false,
     .keep_cafs = false,
+    .eventlog_writer = &FileEventLogWriter,
     .defaultsHook = FlagDefaultsHook,
     .onExitHook = OnExitHook,
     .stackOverflowHook = StackOverflowHook,
diff --git a/rts/Trace.c b/rts/Trace.c
index 91680b7b8a..07717f3ac3 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -18,8 +18,10 @@
 #include "GetEnv.h"
 #include "Stats.h"
 #include "eventlog/EventLog.h"
+#include "rts/EventLogWriter.h"
 #include "Threads.h"
 #include "Printer.h"
+#include "RtsFlags.h"
 
 #ifdef HAVE_UNISTD_H
 #include <unistd.h>
@@ -43,8 +45,15 @@ static bool eventlog_enabled;
    Starting up / shuttting down the tracing facilities
  --------------------------------------------------------------------------- */
 
+static const EventLogWriter *getEventLogWriter(void)
+{
+    return rtsConfig.eventlog_writer;
+}
+
 void initTracing (void)
 {
+    const EventLogWriter *eventlog_writer = getEventLogWriter();
+
 #ifdef THREADED_RTS
     initMutex(&trace_utx);
 #endif
@@ -82,14 +91,15 @@ void initTracing (void)
         TRACE_spark_full ||
         TRACE_user;
 
-    eventlog_enabled = RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG;
+    eventlog_enabled = RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG &&
+                        eventlog_writer != NULL;
 
     /* Note: we can have any of the TRACE_* flags turned on even when
        eventlog_enabled is off. In the DEBUG way we may be tracing to stderr.
      */
 
     if (eventlog_enabled) {
-        initEventLogging();
+        initEventLogging(eventlog_writer);
     }
 }
 
@@ -109,9 +119,14 @@ void freeTracing (void)
 
 void resetTracing (void)
 {
+    const EventLogWriter *eventlog_writer;
+    eventlog_writer = getEventLogWriter();
+
     if (eventlog_enabled) {
         abortEventLogging(); // abort eventlog inherited from parent
-        initEventLogging(); // child starts its own eventlog
+        if (eventlog_writer != NULL) {
+            initEventLogging(eventlog_writer); // child starts its own eventlog
+        }
     }
 }
 
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index 4e4bdb5191..ce4cb3847a 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -26,13 +26,7 @@
 #include <unistd.h>
 #endif
 
-// PID of the process that writes to event_log_filename (#4512)
-static pid_t event_log_pid = -1;
-
-static char *event_log_filename = NULL;
-
-// File for logging events
-FILE *event_log_file = NULL;
+static const EventLogWriter *event_log_writer;
 
 #define EVENT_LOG_SIZE 2 * (1024 * 1024) // 2MB
 
@@ -232,55 +226,55 @@ static inline void postInt32(EventsBuf *eb, StgInt32 i)
 
 #define EVENT_SIZE_DYNAMIC (-1)
 
-void
-initEventLogging(void)
+static void
+initEventLogWriter(void)
 {
-    StgWord8 t, c;
-    uint32_t n_caps;
-    char *prog;
-
-    prog = stgMallocBytes(strlen(prog_name) + 1, "initEventLogging");
-    strcpy(prog, prog_name);
-#ifdef mingw32_HOST_OS
-    // on Windows, drop the .exe suffix if there is one
-    {
-        char *suff;
-        suff = strrchr(prog,'.');
-        if (suff != NULL && !strcmp(suff,".exe")) {
-            *suff = '\0';
-        }
+    if (event_log_writer != NULL &&
+            event_log_writer->initEventLogWriter != NULL) {
+        event_log_writer->initEventLogWriter();
     }
-#endif
+}
 
-    event_log_filename = stgMallocBytes(strlen(prog)
-                                        + 10 /* .%d */
-                                        + 10 /* .eventlog */,
-                                        "initEventLogging");
+static bool
+writeEventLog(void *eventlog, size_t eventlog_size)
+{
+    if (event_log_writer != NULL &&
+            event_log_writer->writeEventLog != NULL) {
+        return event_log_writer->writeEventLog(eventlog, eventlog_size);
+    } else {
+        return false;
+    }
+}
 
-    if (sizeof(EventDesc) / sizeof(char*) != NUM_GHC_EVENT_TAGS) {
-        barf("EventDesc array has the wrong number of elements");
+static void
+stopEventLogWriter(void)
+{
+    if (event_log_writer != NULL &&
+            event_log_writer->stopEventLogWriter != NULL) {
+        event_log_writer->stopEventLogWriter();
     }
+}
 
-    if (event_log_pid == -1) { // #4512
-        // Single process
-        sprintf(event_log_filename, "%s.eventlog", prog);
-        event_log_pid = getpid();
-    } else {
-        // Forked process, eventlog already started by the parent
-        // before fork
-        event_log_pid = getpid();
-        // We don't have a FMT* symbol for pid_t, so we go via Word64
-        // to be sure of not losing range. It would be nicer to have a
-        // FMT* symbol or similar, though.
-        sprintf(event_log_filename, "%s.%" FMT_Word64 ".eventlog",
-                prog, (StgWord64)event_log_pid);
+void
+flushEventLog(void)
+{
+    if (event_log_writer != NULL &&
+            event_log_writer->flushEventLog != NULL) {
+        event_log_writer->flushEventLog();
     }
-    stgFree(prog);
+}
+
+void
+initEventLogging(const EventLogWriter *ev_writer)
+{
+    StgWord8 t, c;
+    uint32_t n_caps;
+
+    event_log_writer = ev_writer;
+    initEventLogWriter();
 
-    /* Open event log file for writing. */
-    if ((event_log_file = fopen(event_log_filename, "wb")) == NULL) {
-        sysErrorBelch("initEventLogging: can't open %s", event_log_filename);
-        stg_exit(EXIT_FAILURE);
+    if (sizeof(EventDesc) / sizeof(char*) != NUM_GHC_EVENT_TAGS) {
+        barf("EventDesc array has the wrong number of elements");
     }
 
     /*
@@ -522,9 +516,7 @@ endEventLogging(void)
     // Flush the end of data marker.
     printAndClearEventBuf(&eventBuf);
 
-    if (event_log_file != NULL) {
-        fclose(event_log_file);
-    }
+    stopEventLogWriter();
 }
 
 void
@@ -568,26 +560,13 @@ freeEventLogging(void)
     if (capEventBuf != NULL)  {
         stgFree(capEventBuf);
     }
-    if (event_log_filename != NULL) {
-        stgFree(event_log_filename);
-    }
-}
-
-void
-flushEventLog(void)
-{
-    if (event_log_file != NULL) {
-        fflush(event_log_file);
-    }
 }
 
 void
 abortEventLogging(void)
 {
     freeEventLogging();
-    if (event_log_file != NULL) {
-        fclose(event_log_file);
-    }
+    stopEventLogWriter();
 }
 
 /*
@@ -1287,18 +1266,13 @@ void printAndClearEventBuf (EventsBuf *ebuf)
 
     if (ebuf->begin != NULL && ebuf->pos != ebuf->begin)
     {
-        StgInt8 *begin = ebuf->begin;
-        while (begin < ebuf->pos) {
-            StgWord64 remain = ebuf->pos - begin;
-            StgWord64 written = fwrite(begin, 1, remain, event_log_file);
-            if (written == 0) {
-                debugBelch(
-                    "printAndClearEventLog: fwrite() failed to write anything;"
-                    " tried to write numBytes=%" FMT_Word64, remain);
-                resetEventsBuf(ebuf);
-                return;
-            }
-            begin += written;
+        size_t elog_size = ebuf->pos - ebuf->begin;
+        if (!writeEventLog(ebuf->begin, elog_size)) {
+            debugBelch(
+                    "printAndClearEventLog: could not flush event log"
+                );
+            resetEventsBuf(ebuf);
+            return;
         }
 
         resetEventsBuf(ebuf);
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index 462f5f594e..e36c97353e 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -10,6 +10,7 @@
 #define EVENTLOG_H
 
 #include "rts/EventLogFormat.h"
+#include "rts/EventLogWriter.h"
 #include "Capability.h"
 
 #include "BeginPrivate.h"
@@ -21,7 +22,7 @@
  */
 extern char *EventTagDesc[];
 
-void initEventLogging(void);
+void initEventLogging(const EventLogWriter *writer);
 void endEventLogging(void);
 void freeEventLogging(void);
 void abortEventLogging(void); // #4512 - after fork child needs to abort
diff --git a/rts/eventlog/EventLogWriter.c b/rts/eventlog/EventLogWriter.c
new file mode 100644
index 0000000000..d6db743119
--- /dev/null
+++ b/rts/eventlog/EventLogWriter.c
@@ -0,0 +1,122 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Support for fast binary event logging.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "PosixSource.h"
+#include "Rts.h"
+
+#include "RtsUtils.h"
+#include "rts/EventLogWriter.h"
+
+#include <string.h>
+#include <stdio.h>
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+// PID of the process that writes to event_log_filename (#4512)
+static pid_t event_log_pid = -1;
+
+// File for logging events
+static FILE *event_log_file = NULL;
+
+static void initEventLogFileWriter(void);
+static bool writeEventLogFile(void *eventlog, size_t eventlog_size);
+static void flushEventLogFile(void);
+static void stopEventLogFileWriter(void);
+
+static void
+initEventLogFileWriter(void)
+{
+    char *prog, *event_log_filename;
+
+    prog = stgMallocBytes(strlen(prog_name) + 1, "initEventLogFileWriter");
+    strcpy(prog, prog_name);
+#ifdef mingw32_HOST_OS
+    // on Windows, drop the .exe suffix if there is one
+    {
+        char *suff;
+        suff = strrchr(prog,'.');
+        if (suff != NULL && !strcmp(suff,".exe")) {
+            *suff = '\0';
+        }
+    }
+#endif
+    event_log_filename = stgMallocBytes(strlen(prog)
+                                        + 10 /* .%d */
+                                        + 10 /* .eventlog */,
+                                        "initEventLogFileWriter");
+
+    if (event_log_pid == -1) { // #4512
+        // Single process
+        sprintf(event_log_filename, "%s.eventlog", prog);
+        event_log_pid = getpid();
+    } else {
+        // Forked process, eventlog already started by the parent
+        // before fork
+        event_log_pid = getpid();
+        // We don't have a FMT* symbol for pid_t, so we go via Word64
+        // to be sure of not losing range. It would be nicer to have a
+        // FMT* symbol or similar, though.
+        sprintf(event_log_filename, "%s.%" FMT_Word64 ".eventlog",
+                prog, (StgWord64)event_log_pid);
+    }
+    stgFree(prog);
+
+    /* Open event log file for writing. */
+    if ((event_log_file = fopen(event_log_filename, "wb")) == NULL) {
+        sysErrorBelch(
+            "initEventLogFileWriter: can't open %s", event_log_filename);
+        stg_exit(EXIT_FAILURE);
+    }
+
+    stgFree(event_log_filename);
+}
+
+static bool
+writeEventLogFile(void *eventlog, size_t eventlog_size)
+{
+    unsigned char *begin = eventlog;
+    size_t remain = eventlog_size;
+
+    while (remain > 0) {
+        size_t written = fwrite(begin, 1, remain, event_log_file);
+        if (written == 0) {
+            return false;
+        }
+        remain -= written;
+        begin += written;
+    }
+
+    return true;
+}
+
+static void
+flushEventLogFile(void)
+{
+    if (event_log_file != NULL) {
+        fflush(event_log_file);
+    }
+}
+
+static void
+stopEventLogFileWriter(void)
+{
+    if (event_log_file != NULL) {
+        fclose(event_log_file);
+    }
+}
+
+const EventLogWriter FileEventLogWriter = {
+    .initEventLogWriter = initEventLogFileWriter,
+    .writeEventLog = writeEventLogFile,
+    .flushEventLog = flushEventLogFile,
+    .stopEventLogWriter = stopEventLogFileWriter
+};