rts: Introduce --eventlog-flush-interval flag

This introduces a flag, --eventlog-flush-interval, which can be used to
set an upper bound on the amount of time for which an eventlog event
will remain enqueued. This can be useful in real-time monitoring
settings.

4 files changed, 43 insertions, 0 deletions

diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst
index 50d8e4ce2b..b8da4aee01 100644
--- a/docs/users_guide/runtime_control.rst
+++ b/docs/users_guide/runtime_control.rst
@@ -1256,6 +1256,15 @@ When the program is linked with the :ghc-flag:`-eventlog` option
     Sets the destination for the eventlog produced with the
     :rts-flag:`-l ⟨flags⟩` flag.
 
+.. rts-flag:: --eventlog-flush-interval=⟨seconds⟩
+
+    :default: disabled
+    :since: 9.2
+
+    When enabled, the eventlog will be flushed periodically every
+    ⟨seconds⟩. This can be useful in live-monitoring situations where the
+    eventlog is consumed in real-time by another process.
+
 .. rts-flag:: -v [⟨flags⟩]
 
     Log events as text to standard output, instead of to the
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
index 35b45b0940..b56cf223b7 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -178,6 +178,8 @@ typedef struct _TRACE_FLAGS {
     bool sparks_full;    /* trace spark events 100% accurately */
     bool ticky;          /* trace ticky-ticky samples */
     bool user;           /* trace user events (emitted from Haskell code) */
+    Time eventlogFlushTime;  /* Time between force eventlog flushes (or 0 if disabled) */
+    int eventlogFlushTicks;
     char *trace_output;  /* output filename for eventlog */
 } TRACE_FLAGS;
 
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 380ccc3afc..42a4490e9b 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -238,6 +238,7 @@ void initRtsFlagsDefaults(void)
     RtsFlags.TraceFlags.user          = false;
     RtsFlags.TraceFlags.ticky         = false;
     RtsFlags.TraceFlags.trace_output  = NULL;
+    RtsFlags.TraceFlags.eventlogFlushTime = 0;
 #endif
 
 #if defined(PROFILING)
@@ -978,6 +979,16 @@ error = true;
                       printRtsInfo(rtsConfig);
                       stg_exit(0);
                   }
+                  else if (strequal("eventlog-flush-interval=",
+                               &rts_argv[arg][2])) {
+                      OPTION_SAFE;
+                      double intervalSeconds = parseDouble(rts_argv[arg]+26, &error);
+                      if (error) {
+                          errorBelch("bad value for --eventlog-flush-interval");
+                      }
+                      RtsFlags.TraceFlags.eventlogFlushTime =
+                          fsecondsToTime(intervalSeconds);
+                  }
                   else if (strequal("copying-gc",
                                &rts_argv[arg][2])) {
                       OPTION_SAFE;
@@ -1803,6 +1814,14 @@ static void normaliseRtsOpts (void)
         RtsFlags.ProfFlags.heapProfileIntervalTicks = 0;
     }
 
+    if (RtsFlags.TraceFlags.eventlogFlushTime > 0) {
+        RtsFlags.TraceFlags.eventlogFlushTicks =
+            RtsFlags.TraceFlags.eventlogFlushTime /
+            RtsFlags.MiscFlags.tickInterval;
+    } else {
+        RtsFlags.TraceFlags.eventlogFlushTicks = 0;
+    }
+
     if (RtsFlags.GcFlags.stkChunkBufferSize >
         RtsFlags.GcFlags.stkChunkSize / 2) {
         errorBelch("stack chunk buffer size (-kb) must be less than 50%%\n"
diff --git a/rts/Timer.c b/rts/Timer.c
index 97d87ad989..d60d09e726 100644
--- a/rts/Timer.c
+++ b/rts/Timer.c
@@ -24,6 +24,7 @@
 #include "Ticker.h"
 #include "Capability.h"
 #include "RtsSignals.h"
+#include "rts/EventLogWriter.h"
 
 // This global counter is used to allow multiple threads to stop the
 // timer temporarily with a stopTimer()/startTimer() pair.  If
@@ -37,6 +38,9 @@ static StgWord timer_disabled;
 /* ticks left before next pre-emptive context switch */
 static int ticks_to_ctxt_switch = 0;
 
+/* ticks left before next next forced eventlog flush */
+static int ticks_to_eventlog_flush = 0;
+
 
 /*
  Note [GC During Idle Time]
@@ -111,6 +115,15 @@ handle_tick(int unused STG_UNUSED)
       }
   }
 
+  if (eventLogStatus() == EVENTLOG_RUNNING
+      && RtsFlags.TraceFlags.eventlogFlushTicks > 0) {
+      ticks_to_eventlog_flush--;
+      if (ticks_to_eventlog_flush <= 0) {
+          ticks_to_eventlog_flush = RtsFlags.TraceFlags.eventlogFlushTicks;
+          flushEventLog(NULL);
+      }
+  }
+
   /*
    * If we've been inactive for idleGCDelayTime (set by +RTS
    * -I), tell the scheduler to wake up and do a GC, to check