rts: Allow output filename of eventlog to be given by command-line

This introduces the `+RTS -ol` flag, which allows user to specify the
destination file for eventlog output.

Test Plan: Validate with included test

Reviewers: simonmar, erikd

Reviewed By: simonmar

Subscribers: rwbarton, carter

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

8 files changed, 99 insertions, 29 deletions

diff --git a/docs/users_guide/8.8.1-notes.rst b/docs/users_guide/8.8.1-notes.rst
index f1a14c75fe..252db777bc 100644
--- a/docs/users_guide/8.8.1-notes.rst
+++ b/docs/users_guide/8.8.1-notes.rst
@@ -89,6 +89,8 @@ Runtime system
   alignment, lower the amount of wasted memory and lower the amount of in use memory.
   See :ghc-ticket:`13617`. Note that committed memory may be slightly higher.
 
+- The output filename used for :ref:`eventlog output <rts-eventlog>` can now be
+  specified with the :rts-flag:`-ol` flag.
 
 Template Haskell
 ~~~~~~~~~~~~~~~~
diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst
index 0c38ac5919..7526b06355 100644
--- a/docs/users_guide/runtime_control.rst
+++ b/docs/users_guide/runtime_control.rst
@@ -1067,6 +1067,13 @@ When the program is linked with the :ghc-flag:`-eventlog` option
     `ghc-events <http://hackage.haskell.org/package/ghc-events>`__
     package.
 
+.. rts-flag:: -ol ⟨filename⟩
+
+    :default: :file:`<program>.eventlog`
+    :since: 8.8
+
+    Sets the destination for the eventlog produced with the :rts-flag:`-l` flag.
+
 .. 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 6487947749..63450d5ece 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -170,6 +170,7 @@ typedef struct _TRACE_FLAGS {
     bool sparks_sampled; /* trace spark events by a sampled method */
     bool sparks_full;    /* trace spark events 100% accurately */
     bool user;           /* trace user events (emitted from Haskell code) */
+    char *trace_output;  /* output filename for eventlog */
 } TRACE_FLAGS;
 
 /* See Note [Synchronization of flags and base APIs] */
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index 6a72e67859..0aa0b623e7 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -219,6 +219,7 @@ void initRtsFlagsDefaults(void)
     RtsFlags.TraceFlags.sparks_sampled= false;
     RtsFlags.TraceFlags.sparks_full   = false;
     RtsFlags.TraceFlags.user          = false;
+    RtsFlags.TraceFlags.trace_output  = NULL;
 #endif
 
 #if defined(PROFILING)
@@ -349,7 +350,8 @@ usage_text[] = {
 
 #if defined(TRACING)
 "",
-"  -l[flags]  Log events in binary format to the file <program>.eventlog",
+"  -ol<file>  Send binary eventlog to <file> (default: <program>.eventlog)",
+"  -l[flags]  Log events to a file",
 #  if defined(DEBUG)
 "  -v[flags]  Log events to stderr",
 #  endif
@@ -1434,7 +1436,30 @@ error = true;
                 }
                 ) break;
 
-              /* =========== TRACING ---------=================== */
+              /* =========== OUTPUT ============================ */
+
+              case 'o':
+                  switch(rts_argv[arg][2]) {
+                  case 'l':
+                      OPTION_SAFE;
+                      TRACING_BUILD_ONLY(
+                          if (strlen(&rts_argv[arg][3]) == 0) {
+                              errorBelch("-ol expects filename");
+                              error = true;
+                          } else {
+                              RtsFlags.TraceFlags.trace_output =
+                                  strdup(&rts_argv[arg][3]);
+                          }
+                          );
+                      break;
+
+                  default:
+                      errorBelch("Unknown output flag -o%c", rts_argv[arg][2]);
+                      error = true;
+                  }
+                  break;
+
+              /* =========== TRACING ============================ */
 
               case 'l':
                   OPTION_SAFE;
diff --git a/rts/eventlog/EventLogWriter.c b/rts/eventlog/EventLogWriter.c
index e6f560fc24..9f6f487d8e 100644
--- a/rts/eventlog/EventLogWriter.c
+++ b/rts/eventlog/EventLogWriter.c
@@ -33,43 +33,53 @@ static bool writeEventLogFile(void *eventlog, size_t eventlog_size);
 static void flushEventLogFile(void);
 static void stopEventLogFileWriter(void);
 
-static void
-initEventLogFileWriter(void)
+static char *outputFileName(void)
 {
-    char *prog, *event_log_filename;
 
-    prog = stgMallocBytes(strlen(prog_name) + 1, "initEventLogFileWriter");
-    strcpy(prog, prog_name);
+    if (RtsFlags.TraceFlags.trace_output) {
+        return strdup(RtsFlags.TraceFlags.trace_output);
+    } else {
+        char *prog = stgMallocBytes(strlen(prog_name) + 1,
+                                    "initEventLogFileWriter");
+        strcpy(prog, prog_name);
 #if defined(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';
+        // 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)
+        char *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);
+        if (event_log_pid == -1) { // #4512
+            // Single process
+            sprintf(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(filename, "%s.%" FMT_Word64 ".eventlog",
+                    prog, (StgWord64)event_log_pid);
+        }
+        stgFree(prog);
+        return filename;
     }
-    stgFree(prog);
+}
+
+static void
+initEventLogFileWriter(void)
+{
+    char *event_log_filename = outputFileName();
 
     /* Open event log file for writing. */
     if ((event_log_file = __rts_fopen(event_log_filename, "wb")) == NULL) {
diff --git a/testsuite/tests/rts/EventlogOutput.hs b/testsuite/tests/rts/EventlogOutput.hs
new file mode 100644
index 0000000000..b3549c2fe3
--- /dev/null
+++ b/testsuite/tests/rts/EventlogOutput.hs
@@ -0,0 +1 @@
+main = return ()
diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile
index 496e04e825..08d2051891 100644
--- a/testsuite/tests/rts/Makefile
+++ b/testsuite/tests/rts/Makefile
@@ -200,3 +200,15 @@ KeepCafsFail:
 .PHONY: KeepCafs
 KeepCafs:
 	"${MAKE}" KeepCafsFail KEEPCAFS=-fkeep-cafs
+
+.PHONY: EventlogOutput1
+EventlogOutput1:
+	"$(TEST_HC)" -eventlog -v0 EventlogOutput.hs
+	./EventlogOutput +RTS -l -olhello.eventlog
+	ls hello.eventlog >/dev/null
+
+.PHONY: EventlogOutput2
+EventlogOutput2:
+	"$(TEST_HC)" -eventlog -v0 EventlogOutput.hs
+	./EventlogOutput +RTS -l
+	ls EventlogOutput.eventlog >/dev/null
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 138e6f0ba2..8d2f37baa7 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -143,6 +143,18 @@ test('traceBinaryEvent', [ omit_ways(['dyn', 'ghci'] + prof_ways),
                            extra_run_opts('+RTS -ls -RTS') ],
                          compile_and_run, ['-eventlog'])
 
+# Test that -ol flag works as expected
+test('EventlogOutput1',
+     [ extra_files(["EventlogOutput.hs"]),
+       omit_ways(['dyn', 'ghci'] + prof_ways) ],
+     run_command, ['$MAKE -s --no-print-directory EventlogOutput1'])
+
+# Test that -ol flag defaults to <program>.eventlog
+test('EventlogOutput2',
+     [ extra_files(["EventlogOutput.hs"]),
+       omit_ways(['dyn', 'ghci'] + prof_ways) ],
+     run_command, ['$MAKE -s --no-print-directory EventlogOutput2'])
+
 test('T4059', [], run_command, ['$MAKE -s --no-print-directory T4059'])
 
 # Test for #4274