[commit: ghc] master: Speed up compilation of profiling stubs (a8da0de)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a8da0de27e600211f04601ac737c329d6603c700/ghc

>---------------------------------------------------------------

commit a8da0de27e600211f04601ac737c329d6603c700
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Wed Aug 16 19:01:05 2017 -0400

    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


>---------------------------------------------------------------

a8da0de27e600211f04601ac737c329d6603c700
 compiler/profiling/ProfInit.hs           | 46 +++++++++++++++++++++-----------
 includes/Rts.h                           |  1 +
 includes/rts/{Parallel.h => Profiling.h} |  7 ++---
 rts/Profiling.c                          | 19 +++++++++++++
 4 files changed, 55 insertions(+), 18 deletions(-)

diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
index 9add61e..0de8069 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 a59a8ca..dd81033 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/Parallel.h b/includes/rts/Profiling.h
similarity index 72%
copy from includes/rts/Parallel.h
copy to includes/rts/Profiling.h
index de1c6e1..f1dafb7 100644
--- a/includes/rts/Parallel.h
+++ b/includes/rts/Profiling.h
@@ -1,8 +1,8 @@
 /* -----------------------------------------------------------------------------
  *
- * (c) The GHC Team, 1998-2009
+ * (c) The GHC Team, 2017-2018
  *
- * Parallelism-related functionality
+ * Cost-centre profiling API
  *
  * Do not #include this file directly: #include "Rts.h" instead.
  *
@@ -13,4 +13,5 @@
 
 #pragma once
 
-StgInt newSpark (StgRegTable *reg, StgClosure *p);
+void registerCcList(CostCentre **cc_list);
+void registerCcsList(CostCentreStack **cc_list);
diff --git a/rts/Profiling.c b/rts/Profiling.c
index 9523572..803f86b 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.