diff options
| -rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 57 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Types/CostCentre/Init.hs | 64 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 |
4 files changed, 56 insertions, 67 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 diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 1b35e34aff..0c6ad34baf 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -130,7 +130,6 @@ import GHC.Stg.FVs ( annTopBindingsFreeVars ) import GHC.Stg.Pipeline ( stg2stg ) import qualified GHC.StgToCmm as StgToCmm ( codeGen ) import GHC.Types.CostCentre -import GHC.Types.CostCentre.Init import GHC.Core.TyCon import GHC.Types.Name import GHC.Types.Name.Set diff --git a/compiler/GHC/Types/CostCentre/Init.hs b/compiler/GHC/Types/CostCentre/Init.hs deleted file mode 100644 index ad6a95e7ab..0000000000 --- a/compiler/GHC/Types/CostCentre/Init.hs +++ /dev/null @@ -1,64 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2011 --- --- Generate code to initialise cost centres --- --- ----------------------------------------------------------------------------- - -module GHC.Types.CostCentre.Init (profilingInitCode) where - -import GhcPrelude - -import GHC.Cmm.CLabel -import GHC.Types.CostCentre -import GHC.Driver.Session -import Outputable -import GHC.Types.Module - --- ----------------------------------------------------------------------------- --- Initialising cost centres - --- We must produce declarations for the cost-centres defined in this --- module; - -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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 91bc80236a..c3a1aa5424 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -415,7 +415,6 @@ Library TysWiredIn GHC.Types.CostCentre GHC.Types.CostCentre.State - GHC.Types.CostCentre.Init GHC.Rename.Binds GHC.Rename.Env GHC.Rename.Expr |