Merge GHC.Types.CostCentre.Init into GHC.Driver.CodeOutput

1 files changed, 56 insertions, 1 deletions

diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 45c40d2c30..d9078e9ca1 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -6,7 +6,12 @@
 
 {-# LANGUAGE CPP #-}
 
-module GHC.Driver.CodeOutput ( codeOutput, outputForeignStubs ) where
+module GHC.Driver.CodeOutput
+   ( codeOutput
+   , outputForeignStubs
+   , profilingInitCode
+   )
+where
 
 #include "HsVersions.h"
 
@@ -22,6 +27,7 @@ import GHC.CmmToC           ( writeC )
 import GHC.Cmm.Lint         ( cmmLint )
 import GHC.Driver.Packages
 import GHC.Cmm              ( RawCmmGroup )
+import GHC.Cmm.CLabel
 import GHC.Driver.Types
 import GHC.Driver.Session
 import Stream           ( Stream )
@@ -32,6 +38,7 @@ import ErrUtils
 import Outputable
 import GHC.Types.Module
 import GHC.Types.SrcLoc
+import GHC.Types.CostCentre
 
 import Control.Exception
 import System.Directory
@@ -262,3 +269,51 @@ outputForeignStubs_help _fname ""      _header _footer = return False
 outputForeignStubs_help fname doc_str header footer
    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
         return True
+
+-- -----------------------------------------------------------------------------
+-- Initialising cost centres
+
+-- We must produce declarations for the cost-centres defined in this
+-- module;
+
+-- | Generate code to initialise cost centres
+profilingInitCode :: Module -> CollectedCCs -> SDoc
+profilingInitCode this_mod (local_CCs, singleton_CCSs)
+ = sdocWithDynFlags $ \dflags ->
+   if not (gopt Opt_SccProfilingOn dflags)
+   then empty
+   else vcat
+    $  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
+   emit_cc_decl cc =
+       text "extern CostCentre" <+> cc_lbl <> text "[];"
+     where cc_lbl = ppr (mkCCLabel cc)
+   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