From a8da0de27e600211f04601ac737c329d6603c700 Mon Sep 17 00:00:00 2001
From: Ben Gamari <bgamari.foss@gmail.com>
Date: Wed, 16 Aug 2017 19:01:05 -0400
Subject: Speed up compilation of profiling stubs

Here we encode the cost centre list as static data. This means that the
initialization stubs are small functions which should be easy for GCC to
compile, even with optimization.

Fixes #7960.

Test Plan: Test profiling

Reviewers: austin, erikd, simonmar

Reviewed By: simonmar

Subscribers: rwbarton, thomie

GHC Trac Issues: #7960

Differential Revision: https://phabricator.haskell.org/D3853
---
 compiler/profiling/ProfInit.hs | 46 ++++++++++++++++++++++++++++--------------
 includes/Rts.h                 |  1 +
 includes/rts/Profiling.h       | 17 ++++++++++++++++
 rts/Profiling.c                | 19 +++++++++++++++++
 4 files changed, 68 insertions(+), 15 deletions(-)
 create mode 100644 includes/rts/Profiling.h

diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
index 9add61e561..0de8069eb5 100644
--- a/compiler/profiling/ProfInit.hs
+++ b/compiler/profiling/ProfInit.hs
@@ -12,7 +12,6 @@ import CLabel
 import CostCentre
 import DynFlags
 import Outputable
-import FastString
 import Module
 
 -- -----------------------------------------------------------------------------
@@ -27,20 +26,37 @@ profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
    if not (gopt Opt_SccProfilingOn dflags)
    then empty
    else vcat
-    [ text "static void prof_init_" <> ppr this_mod
-         <> text "(void) __attribute__((constructor));"
-    , text "static void prof_init_" <> ppr this_mod <> text "(void)"
-    , braces (vcat (
-         map emitRegisterCC           local_CCs ++
-         map emitRegisterCCS          singleton_CCSs
-       ))
-    ]
+    $  map emit_cc_decl local_CCs
+    ++ map emit_ccs_decl singleton_CCSs
+    ++ [emit_cc_list local_CCs]
+    ++ [emit_ccs_list singleton_CCSs]
+    ++ [ text "static void prof_init_" <> ppr this_mod
+            <> text "(void) __attribute__((constructor));"
+       , text "static void prof_init_" <> ppr this_mod <> text "(void)"
+       , braces (vcat
+                 [ text "registerCcList" <> parens local_cc_list_label <> semi
+                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi
+                 ])
+       ]
  where
-   emitRegisterCC cc   =
-      text "extern CostCentre " <> cc_lbl <> ptext (sLit "[];") $$
-      text "REGISTER_CC(" <> cc_lbl <> char ')' <> semi
+   emit_cc_decl cc =
+       text "extern CostCentre" <+> cc_lbl <> text "[];"
      where cc_lbl = ppr (mkCCLabel cc)
-   emitRegisterCCS ccs =
-      text "extern CostCentreStack " <> ccs_lbl <> ptext (sLit "[];") $$
-      text "REGISTER_CCS(" <> ccs_lbl <> char ')' <> semi
+   local_cc_list_label = text "local_cc_" <> ppr this_mod
+   emit_cc_list ccs =
+      text "static CostCentre *" <> local_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
+
+   emit_ccs_decl ccs =
+       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
      where ccs_lbl = ppr (mkCCSLabel ccs)
+   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
+   emit_ccs_list ccs =
+      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
diff --git a/includes/Rts.h b/includes/Rts.h
index a59a8ca432..dd81033603 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -202,6 +202,7 @@ void _assertFail(const char *filename, unsigned int linenum)
 #include "rts/Utils.h"
 #include "rts/PrimFloat.h"
 #include "rts/Main.h"
+#include "rts/Profiling.h"
 #include "rts/StaticPtrTable.h"
 #include "rts/Libdw.h"
 #include "rts/LibdwPool.h"
diff --git a/includes/rts/Profiling.h b/includes/rts/Profiling.h
new file mode 100644
index 0000000000..f1dafb78f5
--- /dev/null
+++ b/includes/rts/Profiling.h
@@ -0,0 +1,17 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2017-2018
+ *
+ * Cost-centre profiling API
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+void registerCcList(CostCentre **cc_list);
+void registerCcsList(CostCentreStack **cc_list);
diff --git a/rts/Profiling.c b/rts/Profiling.c
index 9523572887..803f86befc 100644
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -307,6 +307,25 @@ endProfiling ( void )
     }
 }
 
+
+/*
+  These are used in the C stubs produced by the code generator
+  to register code.
+ */
+void registerCcList(CostCentre **cc_list)
+{
+    for (CostCentre **i = cc_list; *i != NULL; i++) {
+        REGISTER_CC(*i);
+    }
+}
+
+void registerCcsList(CostCentreStack **cc_list)
+{
+    for (CostCentreStack **i = cc_list; *i != NULL; i++) {
+        REGISTER_CCS(*i);
+    }
+}
+
 /* -----------------------------------------------------------------------------
    Set CCCS when entering a function.
 
-- 
cgit v1.2.1