From 5f81952e230fef1f65ae473e09d44101c489c483 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Fri, 2 Nov 2018 14:24:12 -0400 Subject: 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 --- docs/users_guide/8.8.1-notes.rst | 2 ++ docs/users_guide/runtime_control.rst | 7 ++++ includes/rts/Flags.h | 1 + rts/RtsFlags.c | 29 ++++++++++++++-- rts/eventlog/EventLogWriter.c | 64 ++++++++++++++++++++--------------- testsuite/tests/rts/EventlogOutput.hs | 1 + testsuite/tests/rts/Makefile | 12 +++++++ testsuite/tests/rts/all.T | 12 +++++++ 8 files changed, 99 insertions(+), 29 deletions(-) create mode 100644 testsuite/tests/rts/EventlogOutput.hs 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 ` 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 `__ package. +.. rts-flag:: -ol ⟨filename⟩ + + :default: :file:`.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 .eventlog", +" -ol Send binary eventlog to (default: .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 .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 -- cgit v1.2.1