JSON profiler reports

This introduces a JSON output format for cost-centre profiler reports.
It's not clear whether this is really something we want to introduce
given that we may also move to a more Haskell-driven output pipeline in
the future, but I nevertheless found this helpful, so I thought I would
put it up.

Test Plan: Compile a program with `-prof -fprof-auto`; run with `+RTS
-pj`

Reviewers: austin, erikd, simonmar

Reviewed By: simonmar

Subscribers: duncan, maoe, thomie, simonmar

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

9 files changed, 200 insertions, 27 deletions

diff --git a/docs/users_guide/profiling.rst b/docs/users_guide/profiling.rst
index d3fdd6233e..27b8839e3f 100644
--- a/docs/users_guide/profiling.rst
+++ b/docs/users_guide/profiling.rst
@@ -410,6 +410,11 @@ enclosed between ``+RTS ... -RTS`` as usual):
     The :rts-flag:`-pa` option produces the most detailed report containing all
     cost centres in addition to the actual time and allocation data.
 
+.. rts-flag:: -pj
+
+    The :rts-flag:`-pj` option produces a time/allocation profile report in JSON
+    format written into the file :file:`<program>.prof`.
+
 .. rts-flag:: -V <secs>
 
     Sets the interval that the RTS clock ticks at, which is also the
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
index 0412415aca..ebcf973742 100644
--- a/includes/rts/Flags.h
+++ b/includes/rts/Flags.h
@@ -115,7 +115,7 @@ typedef struct _COST_CENTRE_FLAGS {
 # define COST_CENTRES_SUMMARY	1
 # define COST_CENTRES_VERBOSE	2 /* incl. serial time profile */
 # define COST_CENTRES_ALL	3
-# define COST_CENTRES_XML       4
+# define COST_CENTRES_JSON      4
 
     int	    profilerTicks;   /* derived */
     int	    msecsPerTick;    /* derived */
@@ -136,7 +136,7 @@ typedef struct _PROFILING_FLAGS {
 
     Time        heapProfileInterval; /* time between samples */
     uint32_t    heapProfileIntervalTicks; /* ticks between samples (derived) */
-    bool     includeTSOs;
+    bool        includeTSOs;
 
 
     bool		showCCSOnException;
diff --git a/libraries/base/GHC/RTS/Flags.hsc b/libraries/base/GHC/RTS/Flags.hsc
index 46534fed96..7bb10b60cb 100644
--- a/libraries/base/GHC/RTS/Flags.hsc
+++ b/libraries/base/GHC/RTS/Flags.hsc
@@ -166,7 +166,7 @@ data DoCostCentres
     | CostCentresSummary
     | CostCentresVerbose
     | CostCentresAll
-    | CostCentresXML
+    | CostCentresJSON
     deriving (Show)
 
 -- | @since 4.8.0.0
@@ -175,13 +175,13 @@ instance Enum DoCostCentres where
     fromEnum CostCentresSummary = #{const COST_CENTRES_SUMMARY}
     fromEnum CostCentresVerbose = #{const COST_CENTRES_VERBOSE}
     fromEnum CostCentresAll     = #{const COST_CENTRES_ALL}
-    fromEnum CostCentresXML     = #{const COST_CENTRES_XML}
+    fromEnum CostCentresJSON    = #{const COST_CENTRES_JSON}
 
     toEnum #{const COST_CENTRES_NONE}    = CostCentresNone
     toEnum #{const COST_CENTRES_SUMMARY} = CostCentresSummary
     toEnum #{const COST_CENTRES_VERBOSE} = CostCentresVerbose
     toEnum #{const COST_CENTRES_ALL}     = CostCentresAll
-    toEnum #{const COST_CENTRES_XML}     = CostCentresXML
+    toEnum #{const COST_CENTRES_JSON}    = CostCentresJSON
     toEnum e = errorWithoutStackTrace ("invalid enum for DoCostCentres: " ++ show e)
 
 -- | Parameters pertaining to the cost-center profiler.
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 68650e323d..b8c246a3a7 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -1,6 +1,6 @@
 # Changelog for [`base` package](http://hackage.haskell.org/package/base)
 
-## next *TBA*
+## 4.10.0.0 *April 2017*
   * Bundled with GHC *TBA*
 
   * `Data.Type.Bool.Not` given a type family dependency (#12057).
@@ -65,6 +65,10 @@
   * `Data.Type.Equality` now provides a kind heterogeneous type equality
     evidence type, `(:~~:)`.
 
+  * The `CostCentresXML` constructor of `GHC.RTS.Flags.DoCostCentres` has been
+    replaced by `CostCentresJSON` due to the new JSON export format supported by
+    the cost centre profiler.
+
 ## 4.9.0.0  *May 2016*
 
   * Bundled with GHC 8.0
diff --git a/rts/ProfilerReport.c b/rts/ProfilerReport.c
index 83e2fba1bf..81f7fa046a 100644
--- a/rts/ProfilerReport.c
+++ b/rts/ProfilerReport.c
@@ -90,21 +90,6 @@ fprintHeader( FILE *prof_file, uint32_t max_label_len, uint32_t max_module_len,
 static CostCentre *sorted_cc_list;
 
 static void
-aggregateCCCosts( CostCentreStack *ccs )
-{
-    IndexTable *i;
-
-    ccs->cc->mem_alloc += ccs->mem_alloc;
-    ccs->cc->time_ticks += ccs->time_ticks;
-
-    for (i = ccs->indexTable; i != 0; i = i->next) {
-        if (!i->back_edge) {
-            aggregateCCCosts(i->ccs);
-        }
-    }
-}
-
-static void
 insertCCInSortedList( CostCentre *new_cc )
 {
     CostCentre **prev, *cc;
@@ -130,7 +115,6 @@ reportPerCCCosts( FILE *prof_file, ProfilerTotals totals )
     CostCentre *cc, *next;
     uint32_t max_label_len, max_module_len, max_src_len;
 
-    aggregateCCCosts(CCS_MAIN);
     sorted_cc_list = NULL;
 
     max_label_len  = 11; // no shorter than the "COST CENTRE" header
diff --git a/rts/ProfilerReportJson.c b/rts/ProfilerReportJson.c
new file mode 100644
index 0000000000..b4c77042d7
--- /dev/null
+++ b/rts/ProfilerReportJson.c
@@ -0,0 +1,127 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2017
+ *
+ * Generating cost-centre profiler JSON report
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifdef PROFILING
+
+#include "PosixSource.h"
+#include "Rts.h"
+
+#include "RtsUtils.h"
+#include "ProfilerReportJson.h"
+#include "Profiling.h"
+
+// This only handles characters that you might see in a Haskell cost-centre
+// name.
+static void escapeString(char const* str, char *out, int len)
+{
+    len--; // reserve character in output for terminating NUL
+    for (; str != '\0' && len > 0; str++) {
+        char c = *str;
+        if (c == '\\') {
+            if (len < 2) break;
+            *out = '\\'; out++; len--;
+            *out = '\\'; out++; len--;
+        } else if (c == '\n') {
+            if (len < 2) break;
+            *out = '\\'; out++; len--;
+            *out = 'n';  out++; len--;
+        } else {
+            *out = c; out++; len--;
+        }
+    }
+    *out = '\0';
+}
+
+static void
+logCostCentres(FILE *prof_file)
+{
+    char tmp[256];
+    bool needs_comma = false;
+    fprintf(prof_file, "[\n");
+    for (CostCentre *cc = CC_LIST; cc != NULL; cc = cc->link) {
+        escapeString(cc->label, tmp, sizeof(tmp));
+        fprintf(prof_file,
+                "%s"
+                "{\"id\": %" FMT_Int ", "
+                "\"label\": \"%s\", "
+                "\"module\": \"%s\", "
+                "\"src_loc\": \"%s\", "
+                "\"is_caf\": %s}",
+                needs_comma ? ", " : "",
+                cc->ccID, tmp, cc->module, cc->srcloc,
+                cc->is_caf ? "true" : "false");
+        needs_comma = true;
+    }
+    fprintf(prof_file, "]\n");
+}
+
+static void
+logCostCentreStack(FILE *prof_file, CostCentreStack const *ccs)
+{
+    fprintf(prof_file,
+            "{\"id\": %" FMT_Int ", "
+            "\"entries\": %" FMT_Word64 ", "
+            "\"alloc\": %" FMT_Word ", "
+            "\"ticks\": %" FMT_Word ", ",
+            ccs->cc->ccID,
+            ccs->scc_count,
+            ccs->mem_alloc * sizeof(W_),
+            ccs->time_ticks);
+
+    bool need_comma = false;
+    fprintf(prof_file, "\"children\": [");
+    for (IndexTable *i = ccs->indexTable; i != 0; i = i->next) {
+        if (!i->back_edge) {
+            if (need_comma) {
+                fprintf(prof_file, ",");
+            }
+            logCostCentreStack(prof_file, i->ccs);
+            need_comma = true;
+        }
+    }
+    fprintf(prof_file, "]}\n");
+}
+
+void
+writeCCSReportJson(FILE *prof_file,
+                   CostCentreStack const *stack,
+                   ProfilerTotals totals)
+{
+    fprintf(prof_file, "{\n\"program\": \"%s\",\n", prog_name);
+    fprintf(prof_file, "\"arguments\": [");
+    for (int count = 0; prog_argv[count]; count++)
+        fprintf(prof_file, "%s\"%s\"",
+                count == 0 ? "" : ", ", prog_argv[count]);
+    fprintf(prof_file, "],\n\"rts_arguments\": [");
+    for (int count = 0; rts_argv[count]; count++)
+        fprintf(prof_file, "%s\"%s\"",
+                count == 0 ? "" : ", ", rts_argv[count]);
+    fprintf(prof_file, "],\n");
+
+    fprintf(prof_file, "\"end_time\": \"%s\",\n", time_str());
+    fprintf(prof_file, "\"initial_capabilities\": %d,\n",
+            RtsFlags.ParFlags.nCapabilities);
+    fprintf(prof_file, "\"total_time\": %11.2f,\n",
+            ((double) totals.total_prof_ticks *
+             (double) RtsFlags.MiscFlags.tickInterval) / (TIME_RESOLUTION * n_capabilities));
+    fprintf(prof_file, "\"total_ticks\": %lu,\n",
+            (unsigned long) totals.total_prof_ticks);
+    fprintf(prof_file, "\"tick_interval\": %d,\n",
+            (int) TimeToUS(RtsFlags.MiscFlags.tickInterval));
+    fprintf(prof_file, "\"total_alloc\":%" FMT_Word64 ",\n",
+            totals.total_alloc * sizeof(W_));
+
+    fprintf(prof_file, "\"cost_centres\": ");
+    logCostCentres(prof_file);
+    fprintf(prof_file, ",\n\"profile\": ");
+    logCostCentreStack(prof_file, stack);
+    fprintf(prof_file, "}\n");
+}
+
+
+#endif /* PROFILING */
diff --git a/rts/ProfilerReportJson.h b/rts/ProfilerReportJson.h
new file mode 100644
index 0000000000..1e115d7265
--- /dev/null
+++ b/rts/ProfilerReportJson.h
@@ -0,0 +1,29 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2017
+ *
+ * Generating cost-center profiler report
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef PROFILER_REPORT_JSON_H
+#define PROFILER_REPORT_JSON_H
+
+#include <stdio.h>
+
+#include "Rts.h"
+#include "Profiling.h"
+
+#include "BeginPrivate.h"
+
+#ifdef PROFILING
+
+void writeCCSReportJson(FILE *prof_file,
+                        CostCentreStack const *ccs,
+                        ProfilerTotals totals );
+
+#endif
+
+#include "EndPrivate.h"
+
+#endif /* PROFILER_REPORT_JSON_H */
diff --git a/rts/Profiling.c b/rts/Profiling.c
index b0019a48fc..0dc1e26f80 100644
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -118,6 +118,7 @@ static  CostCentreStack * isInIndexTable  ( IndexTable *, CostCentre * );
 static  IndexTable *      addToIndexTable ( IndexTable *, CostCentreStack *,
                                             CostCentre *, unsigned int );
 static  void              ccsSetSelected  ( CostCentreStack *ccs );
+static  void              aggregateCCCosts( CostCentreStack *ccs );
 
 static  void              initTimeProfiling    ( void );
 static  void              initProfilingLogFile ( void );
@@ -694,10 +695,16 @@ reportCCSProfiling( void )
     if (RtsFlags.CcFlags.doCostCentres == 0) return;
 
     ProfilerTotals totals = countTickss(CCS_MAIN);
+    aggregateCCCosts(CCS_MAIN);
     inheritCosts(CCS_MAIN);
     CostCentreStack *stack = pruneCCSTree(CCS_MAIN);
     sortCCSTree(stack);
-    writeCCSReport(prof_file, stack, totals);
+
+    if (RtsFlags.CcFlags.doCostCentres == COST_CENTRES_JSON) {
+        writeCCSReportJson(prof_file, stack, totals);
+    } else {
+        writeCCSReport(prof_file, stack, totals);
+    }
 }
 
 /* -----------------------------------------------------------------------------
@@ -752,6 +759,21 @@ inheritCosts(CostCentreStack *ccs)
     return;
 }
 
+static void
+aggregateCCCosts( CostCentreStack *ccs )
+{
+    IndexTable *i;
+
+    ccs->cc->mem_alloc += ccs->mem_alloc;
+    ccs->cc->time_ticks += ccs->time_ticks;
+
+    for (i = ccs->indexTable; i != 0; i = i->next) {
+        if (!i->back_edge) {
+            aggregateCCCosts(i->ccs);
+        }
+    }
+}
+
 //
 // Prune CCSs with zero entries, zero ticks or zero allocation from
 // the tree, unless COST_CENTRES_ALL is on.
diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c
index f924432de4..5fd368cb61 100644
--- a/rts/RtsFlags.c
+++ b/rts/RtsFlags.c
@@ -304,6 +304,7 @@ usage_text[] = {
 "  -P       More detailed Time/Allocation profile",
 "  -Pa      Give information about *all* cost centres",
 "",
+"  -Pj      Output cost-center profile in JSON format",
 "  -h<break-down> Heap residency profile (hp2ps) (output file <program>.hp)",
 "     break-down: c = cost centre stack (default)",
 "                 m = module",
@@ -1059,13 +1060,14 @@ error = true;
                       error = true;
                     }
                     break;
+                  case 'j':
+                      RtsFlags.CcFlags.doCostCentres = COST_CENTRES_JSON;
+                      break;
                   case '\0':
                       if (rts_argv[arg][1] == 'P') {
-                          RtsFlags.CcFlags.doCostCentres =
-                              COST_CENTRES_VERBOSE;
+                          RtsFlags.CcFlags.doCostCentres = COST_CENTRES_VERBOSE;
                       } else {
-                          RtsFlags.CcFlags.doCostCentres =
-                              COST_CENTRES_SUMMARY;
+                          RtsFlags.CcFlags.doCostCentres = COST_CENTRES_SUMMARY;
                       }
                       break;
                   default: