summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSimon Marlow <marlowsd@gmail.com>2011-04-12 13:49:09 +0100
committerSimon Marlow <marlowsd@gmail.com>2011-04-12 15:48:28 +0100
commita52ff7619e8b7d74a9d933d922eeea49f580bca8 (patch)
treee748ba2054b76fe41c600c7cac2b015de3c57248 /compiler
parent5463b55b7dadc1e9918edb2d8666bf3ed195bc61 (diff)
downloadhaskell-a52ff7619e8b7d74a9d933d922eeea49f580bca8.tar.gz
Change the way module initialisation is done (#3252, #4417)
Previously the code generator generated small code fragments labelled with __stginit_M for each module M, and these performed whatever initialisation was necessary for that module and recursively invoked the initialisation functions for imported modules. This appraoch had drawbacks: - FFI users had to call hs_add_root() to ensure the correct initialisation routines were called. This is a non-standard, and ugly, API. - unless we were using -split-objs, the __stginit dependencies would entail linking the whole transitive closure of modules imported, whether they were actually used or not. In an extreme case (#4387, #4417), a module from GHC might be imported for use in Template Haskell or an annotation, and that would force the whole of GHC to be needlessly linked into the final executable. So now instead we do our initialisation with C functions marked with __attribute__((constructor)), which are automatically invoked at program startup time (or DSO load-time). The C initialisers are emitted into the stub.c file. This means that every time we compile with -prof or -hpc, we now get a stub file, but thanks to #3687 that is now invisible to the user. There are some refactorings in the RTS (particularly for HPC) to handle the fact that initialisers now get run earlier than they did before. The __stginit symbols are still generated, and the hs_add_root() function still exists (but does nothing), for backwards compatibility.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/CLabel.hs73
-rw-r--r--compiler/cmm/PprC.hs13
-rw-r--r--compiler/codeGen/CgHpc.hs49
-rw-r--r--compiler/codeGen/CgProf.hs53
-rw-r--r--compiler/codeGen/CodeGen.lhs170
-rw-r--r--compiler/codeGen/StgCmm.hs115
-rw-r--r--compiler/codeGen/StgCmmHpc.hs41
-rw-r--r--compiler/codeGen/StgCmmProf.hs58
-rw-r--r--compiler/deSugar/Coverage.lhs57
-rw-r--r--compiler/deSugar/Desugar.lhs6
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghc.mk2
-rw-r--r--compiler/main/DriverPipeline.hs38
-rw-r--r--compiler/main/GHC.hs8
-rw-r--r--compiler/main/HscMain.lhs19
-rw-r--r--compiler/main/HscTypes.lhs12
-rw-r--r--compiler/main/TidyPgm.lhs14
-rw-r--r--compiler/profiling/ProfInit.hs45
18 files changed, 234 insertions, 540 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 4d9596197e..c151a26391 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -51,9 +51,7 @@ module CLabel (
mkAsmTempLabel,
- mkModuleInitLabel,
- mkPlainModuleInitLabel,
- mkModuleInitTableLabel,
+ mkPlainModuleInitLabel,
mkSplitMarkerLabel,
mkDirty_MUT_VAR_Label,
@@ -70,10 +68,7 @@ module CLabel (
mkRtsPrimOpLabel,
mkRtsSlowTickyCtrLabel,
- moduleRegdLabel,
- moduleRegTableLabel,
-
- mkSelectorInfoLabel,
+ mkSelectorInfoLabel,
mkSelectorEntryLabel,
mkCmmInfoLabel,
@@ -102,7 +97,6 @@ module CLabel (
mkDeadStripPreventer,
mkHpcTicksLabel,
- mkHpcModuleNameLabel,
hasCAF,
infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
@@ -202,23 +196,9 @@ data CLabel
| StringLitLabel
{-# UNPACK #-} !Unique
- | ModuleInitLabel
- Module -- the module name
- String -- its "way"
- -- at some point we might want some kind of version number in
- -- the module init label, to guard against compiling modules in
- -- the wrong order. We can't use the interface file version however,
- -- because we don't always recompile modules which depend on a module
- -- whose version has changed.
-
- | PlainModuleInitLabel -- without the version & way info
+ | PlainModuleInitLabel -- without the version & way info
Module
- | ModuleInitTableLabel -- table of imported modules to init
- Module
-
- | ModuleRegdLabel
-
| CC_Label CostCentre
| CCS_Label CostCentreStack
@@ -242,9 +222,6 @@ data CLabel
-- | Per-module table of tick locations
| HpcTicksLabel Module
- -- | Per-module name of the module for Hpc
- | HpcModuleNameLabel
-
-- | Label of an StgLargeSRT
| LargeSRTLabel
{-# UNPACK #-} !Unique
@@ -490,7 +467,6 @@ mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
-- Constructing Code Coverage Labels
mkHpcTicksLabel = HpcTicksLabel
-mkHpcModuleNameLabel = HpcModuleNameLabel
-- Constructing labels used for dynamic linking
@@ -515,19 +491,9 @@ mkStringLitLabel = StringLitLabel
mkAsmTempLabel :: Uniquable a => a -> CLabel
mkAsmTempLabel a = AsmTempLabel (getUnique a)
-mkModuleInitLabel :: Module -> String -> CLabel
-mkModuleInitLabel mod way = ModuleInitLabel mod way
-
mkPlainModuleInitLabel :: Module -> CLabel
mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
-mkModuleInitTableLabel :: Module -> CLabel
-mkModuleInitTableLabel mod = ModuleInitTableLabel mod
-
-moduleRegdLabel = ModuleRegdLabel
-moduleRegTableLabel = ModuleInitTableLabel
-
-
-- -----------------------------------------------------------------------------
-- Converting between info labels and entry/ret labels.
@@ -591,10 +557,7 @@ needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True
needsCDecl (CaseLabel _ _) = True
-needsCDecl (ModuleInitLabel _ _) = True
-needsCDecl (PlainModuleInitLabel _) = True
-needsCDecl (ModuleInitTableLabel _) = True
-needsCDecl ModuleRegdLabel = False
+needsCDecl (PlainModuleInitLabel _) = True
needsCDecl (StringLitLabel _) = False
needsCDecl (AsmTempLabel _) = False
@@ -612,7 +575,6 @@ needsCDecl l@(ForeignLabel{}) = not (isMathFun l)
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
needsCDecl (HpcTicksLabel _) = True
-needsCDecl HpcModuleNameLabel = False
-- | Check whether a label is a local temporary for native code generation
@@ -725,11 +687,8 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (StringLitLabel _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
-externallyVisibleCLabel (ModuleInitLabel _ _) = True
externallyVisibleCLabel (PlainModuleInitLabel _)= True
-externallyVisibleCLabel (ModuleInitTableLabel _)= False
-externallyVisibleCLabel ModuleRegdLabel = False
-externallyVisibleCLabel (RtsLabel _) = True
+externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (CmmLabel _ _ _) = True
externallyVisibleCLabel (ForeignLabel{}) = True
externallyVisibleCLabel (IdLabel name _ _) = isExternalName name
@@ -737,8 +696,7 @@ externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
-externallyVisibleCLabel HpcModuleNameLabel = False
-externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
-- -----------------------------------------------------------------------------
@@ -777,9 +735,7 @@ labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
-labelType (ModuleInitLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel
-labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
@@ -837,10 +793,8 @@ labelDynamic this_pkg lbl =
CmmLabel pkg _ _ -> True
#endif
- ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m)
PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
- ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
-
+
-- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
@@ -1008,9 +962,6 @@ pprCLbl (RtsLabel (RtsPrimOp primop))
pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
= ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr")
-pprCLbl ModuleRegdLabel
- = ptext (sLit "_module_registered")
-
pprCLbl (ForeignLabel str _ _ _)
= ftext str
@@ -1019,22 +970,12 @@ pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
pprCLbl (CC_Label cc) = ppr cc
pprCLbl (CCS_Label ccs) = ppr ccs
-pprCLbl (ModuleInitLabel mod way)
- = ptext (sLit "__stginit_") <> ppr mod
- <> char '_' <> text way
-
pprCLbl (PlainModuleInitLabel mod)
= ptext (sLit "__stginit_") <> ppr mod
-pprCLbl (ModuleInitTableLabel mod)
- = ptext (sLit "__stginittable_") <> ppr mod
-
pprCLbl (HpcTicksLabel mod)
= ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc")
-pprCLbl HpcModuleNameLabel
- = ptext (sLit "_hpc_module_name_str")
-
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <>
(case x of
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index ca6fa74ffa..10f4e8bacf 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -105,18 +105,19 @@ pprTop (CmmProc info clbl (ListGraph blocks)) =
then pprDataExterns info $$
pprWordArray (entryLblToInfoLbl clbl) info
else empty) $$
- (case blocks of
- [] -> empty
- -- the first block doesn't get a label:
- (BasicBlock _ stmts : rest) -> vcat [
+ (vcat [
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
nest 8 temp_decls,
nest 8 mkFB_,
- nest 8 (vcat (map pprStmt stmts)) $$
- vcat (map pprBBlock rest),
+ case blocks of
+ [] -> empty
+ -- the first block doesn't get a label:
+ (BasicBlock _ stmts : rest) ->
+ nest 8 (vcat (map pprStmt stmts)) $$
+ vcat (map pprBBlock rest),
nest 8 mkFE_,
rbrace ]
)
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
index 8da2715ac2..48756505c3 100644
--- a/compiler/codeGen/CgHpc.hs
+++ b/compiler/codeGen/CgHpc.hs
@@ -6,24 +6,14 @@
--
-----------------------------------------------------------------------------
-module CgHpc (cgTickBox, initHpc, hpcTable) where
+module CgHpc (cgTickBox, hpcTable) where
import OldCmm
import CLabel
import Module
import OldCmmUtils
-import CgUtils
import CgMonad
-import CgForeignCall
-import ForeignCall
-import ClosureInfo
-import FastString
import HscTypes
-import Panic
-import BasicTypes
-
-import Data.Char
-import Data.Word
cgTickBox :: Module -> Int -> Code
cgTickBox mod n = do
@@ -40,47 +30,10 @@ cgTickBox mod n = do
hpcTable :: Module -> HpcInfo -> Code
hpcTable this_mod (HpcInfo hpc_tickCount _) = do
- emitData ReadOnlyData
- [ CmmDataLabel mkHpcModuleNameLabel
- , CmmString $ map (fromIntegral . ord)
- (full_name_str)
- ++ [0]
- ]
emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
] ++
[ CmmStaticLit (CmmInt 0 W64)
| _ <- take hpc_tickCount [0::Int ..]
]
- where
- module_name_str = moduleNameString (Module.moduleName this_mod)
- full_name_str = if modulePackageId this_mod == mainPackageId
- then module_name_str
- else packageIdString (modulePackageId this_mod) ++ "/" ++
- module_name_str
hpcTable _ (NoHpcInfo {}) = error "TODO: impossible"
-
-initHpc :: Module -> HpcInfo -> Code
-initHpc this_mod (HpcInfo tickCount hashNo)
- = do { id <- newTemp bWord
- ; emitForeignCall'
- PlayRisky
- [CmmHinted id NoHint]
- (CmmCallee
- (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction)
- CCallConv
- )
- [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint
- , CmmHinted (word32 tickCount) NoHint
- , CmmHinted (word32 hashNo) NoHint
- , CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) AddrHint
- ]
- (Just [])
- NoC_SRT -- No SRT b/c we PlayRisky
- CmmMayReturn
- }
- where
- word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) W32)
- mod_alloc = mkFastString "hs_hpc_module"
-initHpc _ (NoHpcInfo {}) = panic "initHpc: NoHpcInfo"
-
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 0cf209e89c..243aa1d89a 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -16,8 +16,7 @@ module CgProf (
costCentreFrom,
curCCS, curCCSAddr,
emitCostCentreDecl, emitCostCentreStackDecl,
- emitRegisterCC, emitRegisterCCS,
- emitSetCCC, emitCCS,
+ emitSetCCC, emitCCS,
-- Lag/drag/void stuff
ldvEnter, ldvEnterClosure, ldvRecordCreate
@@ -348,56 +347,6 @@ sizeof_ccs_words
(ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
-- ---------------------------------------------------------------------------
--- Registering CCs and CCSs
-
--- (cc)->link = CC_LIST;
--- CC_LIST = (cc);
--- (cc)->ccID = CC_ID++;
-
-emitRegisterCC :: CostCentre -> Code
-emitRegisterCC cc = do
- { tmp <- newTemp cInt
- ; stmtsC [
- CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
- (CmmLoad cC_LIST bWord),
- CmmStore cC_LIST cc_lit,
- CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
- CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
- CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
- ]
- }
- where
- cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
-
--- (ccs)->prevStack = CCS_LIST;
--- CCS_LIST = (ccs);
--- (ccs)->ccsID = CCS_ID++;
-
-emitRegisterCCS :: CostCentreStack -> Code
-emitRegisterCCS ccs = do
- { tmp <- newTemp cInt
- ; stmtsC [
- CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
- (CmmLoad cCS_LIST bWord),
- CmmStore cCS_LIST ccs_lit,
- CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
- CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
- CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
- ]
- }
- where
- ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
-
-
-cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
-cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
-
-cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
-cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
-
--- ---------------------------------------------------------------------------
-- Set the current cost centre stack
emitSetCCC :: CostCentre -> Code
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 6ce8fca55b..81a65f7325 100644
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -29,7 +29,6 @@ import CgHpc
import CLabel
import OldCmm
-import OldCmmUtils
import OldPprCmm
import StgSyn
@@ -51,8 +50,7 @@ import Panic
codeGen :: DynFlags
-> Module
-> [TyCon]
- -> [Module] -- directly-imported modules
- -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
+ -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> HpcInfo
-> IO [Cmm] -- Output
@@ -61,8 +59,7 @@ codeGen :: DynFlags
-- possible for object splitting to split up the
-- pieces later.
-codeGen dflags this_mod data_tycons imported_mods
- cost_centre_info stg_binds hpc_info
+codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info
= do
{ showPass dflags "CodeGen"
@@ -73,167 +70,46 @@ codeGen dflags this_mod data_tycons imported_mods
{ cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
; cmm_tycons <- mapM cgTyCon data_tycons
; cmm_init <- getCmm (mkModuleInit dflags cost_centre_info
- this_mod imported_mods hpc_info)
- ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+ this_mod hpc_info)
+ ; return (cmm_init : cmm_binds ++ concat cmm_tycons)
}
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
-- code_stuff
+ -- Note [codegen-split-init] the cmm_init block must
+ -- come FIRST. This is because when -split-objs is on
+ -- we need to combine this block with its
+ -- initialisation routines; see Note
+ -- [pipeline-split-init].
+
; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
; return code_stuff }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[codegen-init]{Module initialisation code}
-%* *
-%************************************************************************
-
-/* -----------------------------------------------------------------------------
- Module initialisation
-
- The module initialisation code looks like this, roughly:
-
- FN(__stginit_Foo) {
- JMP_(__stginit_Foo_1_p)
- }
-
- FN(__stginit_Foo_1_p) {
- ...
- }
-
- We have one version of the init code with a module version and the
- 'way' attached to it. The version number helps to catch cases
- where modules are not compiled in dependency order before being
- linked: if a module has been compiled since any modules which depend on
- it, then the latter modules will refer to a different version in their
- init blocks and a link error will ensue.
-
- The 'way' suffix helps to catch cases where modules compiled in different
- ways are linked together (eg. profiled and non-profiled).
-
- We provide a plain, unadorned, version of the module init code
- which just jumps to the version with the label and way attached. The
- reason for this is that when using foreign exports, the caller of
- startupHaskell() must supply the name of the init function for the "top"
- module in the program, and we don't want to require that this name
- has the version and way info appended to it.
- -------------------------------------------------------------------------- */
-
-We initialise the module tree by keeping a work-stack,
- * pointed to by Sp
- * that grows downward
- * Sp points to the last occupied slot
-
-\begin{code}
-mkModuleInit
+mkModuleInit
:: DynFlags
-> CollectedCCs -- cost centre info
-> Module
- -> [Module]
- -> HpcInfo
+ -> HpcInfo
-> Code
-mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info
- = do { -- Allocate the static boolean that records if this
- -- module has been registered already
- emitData Data [CmmDataLabel moduleRegdLabel,
- CmmStaticLit zeroCLit]
+mkModuleInit dflags cost_centre_info this_mod hpc_info
+ = do { -- Allocate the static boolean that records if this
; whenC (opt_Hpc) $
hpcTable this_mod hpc_info
- -- we emit a recursive descent module search for all modules
- -- and *choose* to chase it in :Main, below.
- -- In this way, Hpc enabled modules can interact seamlessly with
- -- not Hpc enabled moduled, provided Main is compiled with Hpc.
-
- ; emitSimpleProc real_init_lbl $ do
- { ret_blk <- forkLabelledCode ret_code
-
- ; init_blk <- forkLabelledCode $ do
- { mod_init_code; stmtC (CmmBranch ret_blk) }
-
- ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
- ret_blk)
- ; stmtC (CmmBranch init_blk)
- }
-
- -- Make the "plain" procedure jump to the "real" init procedure
- ; emitSimpleProc plain_init_lbl jump_to_init
-
- -- When compiling the module in which the 'main' function lives,
- -- (that is, this_mod == main_mod)
- -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
- -- RTS to invoke. We must consult the -main-is flag in case the
- -- user specified a different function to Main.main
-
- -- Notice that the recursive descent is optional, depending on what options
- -- are enabled.
-
- ; whenC (this_mod == main_mod)
- (emitSimpleProc plain_main_init_lbl rec_descent_init)
- }
- where
- -- The way string we attach to the __stginit label to catch
- -- accidental linking of modules compiled in different ways. We
- -- omit "dyn" from this way, because we want to be able to load
- -- both dynamic and non-dynamic modules into a dynamic GHC.
- way = mkBuildTag (filter want_way (ways dflags))
- want_way w = not (wayRTSOnly w) && wayName w /= WayDyn
-
- main_mod = mainModIs dflags
-
- plain_init_lbl = mkPlainModuleInitLabel this_mod
- real_init_lbl = mkModuleInitLabel this_mod way
- plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
-
- jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
-
- mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
-
- -- Main refers to GHC.TopHandler.runIO, so make sure we call the
- -- init function for GHC.TopHandler.
- extra_imported_mods
- | this_mod == main_mod = [gHC_TOP_HANDLER]
- | otherwise = []
-
- mod_init_code = do
- { -- Set mod_reg to 1 to record that we've been here
- stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
-
; whenC (opt_SccProfilingOn) $ do
initCostCentres cost_centre_info
- ; whenC (opt_Hpc) $
- initHpc this_mod hpc_info
-
- ; mapCs (registerModuleImport way)
- (imported_mods++extra_imported_mods)
-
- }
-
- -- The return-code pops the work stack by
- -- incrementing Sp, and then jumpd to the popped item
- ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
- , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ]
-
-
- rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
- then jump_to_init
- else ret_code
-
------------------------
-registerModuleImport :: String -> Module -> Code
-registerModuleImport way mod
- | mod == gHC_PRIM
- = nopC
- | otherwise -- Push the init procedure onto the work stack
- = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
- , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
+ -- For backwards compatibility: user code may refer to this
+ -- label for calling hs_add_root().
+ ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ return ()
+
+ ; whenC (this_mod == mainModIs dflags) $
+ emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
+ }
\end{code}
@@ -252,9 +128,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
| otherwise
= do { mapM_ emitCostCentreDecl local_CCs
; mapM_ emitCostCentreStackDecl singleton_CCSs
- ; mapM_ emitRegisterCC local_CCs
- ; mapM_ emitRegisterCCS singleton_CCSs
- }
+ }
\end{code}
%************************************************************************
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 26ace0780f..fa3dcfed83 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -24,16 +24,12 @@ import StgCmmHpc
import StgCmmTicky
import MkGraph
-import CmmDecl
import CmmExpr
-import CmmUtils
import CLabel
import PprCmm
import StgSyn
-import PrelNames
import DynFlags
-import StaticFlags
import HscTypes
import CostCentre
@@ -50,17 +46,14 @@ import Outputable
codeGen :: DynFlags
-> Module
-> [TyCon]
- -> [Module] -- Directly-imported modules
- -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
+ -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> HpcInfo
-> IO [Cmm] -- Output
-codeGen dflags this_mod data_tycons imported_mods
+codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
= do { showPass dflags "New CodeGen"
- ; let way = buildTag dflags
- main_mod = mainModIs dflags
-- Why?
-- ; mapM_ (\x -> seq x (return ())) data_tycons
@@ -68,10 +61,9 @@ codeGen dflags this_mod data_tycons imported_mods
; code_stuff <- initC dflags this_mod $ do
{ cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
; cmm_tycons <- mapM cgTyCon data_tycons
- ; cmm_init <- getCmm (mkModuleInit way cost_centre_info
- this_mod main_mod
- imported_mods hpc_info)
- ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+ ; cmm_init <- getCmm (mkModuleInit cost_centre_info
+ this_mod hpc_info)
+ ; return (cmm_init : cmm_binds ++ concat cmm_tycons)
}
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
@@ -82,6 +74,12 @@ codeGen dflags this_mod data_tycons imported_mods
-- possible for object splitting to split up the
-- pieces later.
+ -- Note [codegen-split-init] the cmm_init block must
+ -- come FIRST. This is because when -split-objs is on
+ -- we need to combine this block with its
+ -- initialisation routines; see Note
+ -- [pipeline-split-init].
+
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
; return code_stuff }
@@ -173,89 +171,18 @@ We initialise the module tree by keeping a work-stack,
-}
mkModuleInit
- :: String -- the "way"
- -> CollectedCCs -- cost centre info
+ :: CollectedCCs -- cost centre info
-> Module
- -> Module -- name of the Main module
- -> [Module]
- -> HpcInfo
+ -> HpcInfo
-> FCode ()
-mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
- = do { -- Allocate the static boolean that records if this
- -- module has been registered already
- emitData Data [CmmDataLabel moduleRegdLabel,
- CmmStaticLit zeroCLit]
-
- ; init_hpc <- initHpc this_mod hpc_info
- ; init_prof <- initCostCentres cost_centre_info
-
- -- We emit a recursive descent module search for all modules
- -- and *choose* to chase it in :Main, below.
- -- In this way, Hpc enabled modules can interact seamlessly with
- -- not Hpc enabled moduled, provided Main is compiled with Hpc.
-
- ; updfr_sz <- getUpdFrameOff
- ; tail <- getCode (pushUpdateFrame imports
- (do updfr_sz' <- getUpdFrameOff
- emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
- ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
- [ check_already_done retId updfr_sz
- , init_prof
- , init_hpc
- , tail])
- -- Make the "plain" procedure jump to the "real" init procedure
- ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
-
- -- When compiling the module in which the 'main' function lives,
- -- (that is, this_mod == main_mod)
- -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
- -- RTS to invoke. We must consult the -main-is flag in case the
- -- user specified a different function to Main.main
-
- -- Notice that the recursive descent is optional, depending on what options
- -- are enabled.
-
-
- ; whenC (this_mod == main_mod)
- (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
- }
- where
- plain_init_lbl = mkPlainModuleInitLabel this_mod
- real_init_lbl = mkModuleInitLabel this_mod way
- plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
-
- jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
-
-
- -- Main refers to GHC.TopHandler.runIO, so make sure we call the
- -- init function for GHC.TopHandler.
- extra_imported_mods
- | this_mod == main_mod = [gHC_TOP_HANDLER]
- | otherwise = []
- all_imported_mods = imported_mods ++ extra_imported_mods
- imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
- (filter (gHC_PRIM /=) all_imported_mods)
-
- mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
- check_already_done retId updfr_sz
- = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
- (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
- <*> -- Set mod_reg to 1 to record that we've been here
- mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
-
- -- The return-code pops the work stack by
- -- incrementing Sp, and then jumps to the popped item
- ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
- ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
- -- mkAssign spReg (cmmRegOffW spReg 1) <*>
- -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
-
- pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
-
- rec_descent_init updfr_sz =
- if opt_SccProfilingOn || isHpcUsed hpc_info
- then jump_to_init updfr_sz
- else ret_code updfr_sz
+
+mkModuleInit cost_centre_info this_mod hpc_info
+ = do { initHpc this_mod hpc_info
+ ; initCostCentres cost_centre_info
+ -- For backwards compatibility: user code may refer to this
+ -- label for calling hs_add_root().
+ ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ emptyAGraph
+ }
---------------------------------------------------------------
-- Generating static stuff for algebraic data types
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
index a93af34961..fae3bef016 100644
--- a/compiler/codeGen/StgCmmHpc.hs
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -8,9 +8,7 @@
module StgCmmHpc ( initHpc, mkTickBox ) where
-import StgCmmUtils
import StgCmmMonad
-import StgCmmForeign
import MkGraph
import CmmDecl
@@ -18,11 +16,8 @@ import CmmExpr
import CLabel
import Module
import CmmUtils
-import FastString
import HscTypes
-import Data.Char
import StaticFlags
-import BasicTypes
mkTickBox :: Module -> Int -> CmmAGraph
mkTickBox mod n
@@ -35,41 +30,15 @@ mkTickBox mod n
(CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
n
-initHpc :: Module -> HpcInfo -> FCode CmmAGraph
+initHpc :: Module -> HpcInfo -> FCode ()
-- Emit top-level tables for HPC and return code to initialise
initHpc _ (NoHpcInfo {})
- = return mkNop
-initHpc this_mod (HpcInfo tickCount hashNo)
- = getCode $ whenC opt_Hpc $
- do { emitData ReadOnlyData
- [ CmmDataLabel mkHpcModuleNameLabel
- , CmmString $ map (fromIntegral . ord)
- (full_name_str)
- ++ [0]
- ]
- ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
+ = return ()
+initHpc this_mod (HpcInfo tickCount _hashNo)
+ = whenC opt_Hpc $
+ do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
] ++
[ CmmStaticLit (CmmInt 0 W64)
| _ <- take tickCount [0::Int ..]
]
-
- ; id <- newTemp bWord -- TODO FIXME NOW
- ; emitCCall
- [(id,NoHint)]
- (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction)
- [ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
- , (CmmLit $ mkIntCLit tickCount,NoHint)
- , (CmmLit $ mkIntCLit hashNo,NoHint)
- , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint)
- ]
}
- where
- mod_alloc = mkFastString "hs_hpc_module"
- module_name_str = moduleNameString (Module.moduleName this_mod)
- full_name_str = if modulePackageId this_mod == mainPackageId
- then module_name_str
- else packageIdString (modulePackageId this_mod) ++ "/" ++
- module_name_str
-
-
-
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index 36d05acf90..08bf52952c 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -348,14 +348,12 @@ ifProfilingL xs
-- Initialising Cost Centres & CCSs
---------------------------------------------------------------
-initCostCentres :: CollectedCCs -> FCode CmmAGraph
--- Emit the declarations, and return code to register them
+initCostCentres :: CollectedCCs -> FCode ()
+-- Emit the declarations
initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
- = getCode $ whenC opt_SccProfilingOn $
+ = whenC opt_SccProfilingOn $
do { mapM_ emitCostCentreDecl local_CCs
- ; mapM_ emitCostCentreStackDecl singleton_CCSs
- ; emit $ catAGraphs $ map mkRegisterCC local_CCs
- ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs }
+ ; mapM_ emitCostCentreStackDecl singleton_CCSs }
emitCostCentreDecl :: CostCentre -> FCode ()
@@ -409,54 +407,6 @@ sizeof_ccs_words
(ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
-- ---------------------------------------------------------------------------
--- Registering CCs and CCSs
-
--- (cc)->link = CC_LIST;
--- CC_LIST = (cc);
--- (cc)->ccID = CC_ID++;
-
-mkRegisterCC :: CostCentre -> CmmAGraph
-mkRegisterCC cc
- = withTemp cInt $ \tmp ->
- catAGraphs [
- mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
- (CmmLoad cC_LIST bWord),
- mkStore cC_LIST cc_lit,
- mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
- mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
- mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
- ]
- where
- cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
-
--- (ccs)->prevStack = CCS_LIST;
--- CCS_LIST = (ccs);
--- (ccs)->ccsID = CCS_ID++;
-
-mkRegisterCCS :: CostCentreStack -> CmmAGraph
-mkRegisterCCS ccs
- = withTemp cInt $ \ tmp ->
- catAGraphs [
- mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
- (CmmLoad cCS_LIST bWord),
- mkStore cCS_LIST ccs_lit,
- mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
- mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
- mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
- ]
- where
- ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
-
-
-cC_LIST, cC_ID :: CmmExpr
-cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
-cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
-
-cCS_LIST, cCS_ID :: CmmExpr
-cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
-cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
-
--- ---------------------------------------------------------------------------
-- Set the current cost centre stack
emitSetCCC :: CostCentre -> FCode ()
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 95b70f091a..b28f3eba3f 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -5,7 +5,7 @@
\section[Coverage]{@coverage@: the main function}
\begin{code}
-module Coverage (addCoverageTicksToBinds) where
+module Coverage (addCoverageTicksToBinds, hpcInitCode) where
import HsSyn
import Module
@@ -25,6 +25,8 @@ import StaticFlags
import TyCon
import MonadUtils
import Maybes
+import CLabel
+import Util
import Data.Array
import System.Directory ( createDirectoryIfMissing )
@@ -871,3 +873,56 @@ mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
mixHash file tm tabstop entries = fromIntegral $ hashString
(show $ Mix file tm 0 tabstop entries)
\end{code}
+
+%************************************************************************
+%* *
+%* initialisation
+%* *
+%************************************************************************
+
+Each module compiled with -fhpc declares an initialisation function of
+the form `hpc_init_<module>()`, which is emitted into the _stub.c file
+and annotated with __attribute__((constructor)) so that it gets
+executed at startup time.
+
+The function's purpose is to call hs_hpc_module to register this
+module with the RTS, and it looks something like this:
+
+static void hpc_init_Main(void) __attribute__((constructor));
+static void hpc_init_Main(void)
+{extern StgWord64 _hpc_tickboxes_Main_hpc[];
+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
+
+\begin{code}
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = vcat
+ [ text "static void hpc_init_" <> ppr this_mod
+ <> text "(void) __attribute__((constructor));"
+ , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
+ , braces (vcat [
+ ptext (sLit "extern StgWord64 ") <> tickboxes <>
+ ptext (sLit "[]") <> semi,
+ ptext (sLit "hs_hpc_module") <>
+ parens (hcat (punctuate comma [
+ doubleQuotes full_name_str,
+ int tickCount, -- really StgWord32
+ int hashNo, -- really StgWord32
+ tickboxes
+ ])) <> semi
+ ])
+ ]
+ where
+ tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod)
+
+ module_name = hcat (map (text.charToC) $
+ bytesFS (moduleNameFS (Module.moduleName this_mod)))
+ package_name = hcat (map (text.charToC) $
+ bytesFS (packageIdFS (modulePackageId this_mod)))
+ full_name_str
+ | modulePackageId this_mod == mainPackageId
+ = module_name
+ | otherwise
+ = package_name <> char '/' <> module_name
+\end{code}
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 142f695cb5..37a3cf9236 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -105,10 +105,14 @@ deSugar hsc_env
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects
+ ; let hpc_init
+ | opt_Hpc = hpcInitCode mod ds_hpc_info
+ | otherwise = empty
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
- , ds_fords, ds_hpc_info, modBreaks) }
+ , ds_fords `appendStubC` hpc_init
+ , ds_hpc_info, modBreaks) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 32d13f839b..c509eb6255 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -350,6 +350,7 @@ Library
TysPrim
TysWiredIn
CostCentre
+ ProfInit
SCCfinal
RnBinds
RnEnv
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 48a802af49..a7a353d66e 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -140,6 +140,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo 'cMKDLL = "$(BLD_DLL)"' >> $@
@echo 'cLdIsGNULd :: String' >> $@
@echo 'cLdIsGNULd = "$(LdIsGNULd)"' >> $@
+ @echo 'cLdHasBuildId :: String' >> $@
+ @echo 'cLdHasBuildId = "$(LdHasBuildId)"' >> $@
@echo 'cLD_X :: String' >> $@
@echo 'cLD_X = "$(LD_X)"' >> $@
@echo 'cGHC_DRIVER_DIR :: String' >> $@
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index d7d6ae331d..61486fc3b6 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1227,6 +1227,8 @@ runPhase SplitAs _input_fn dflags
Just x -> x
let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
+
+ split_obj :: Int -> FilePath
split_obj n = split_odir </>
takeFileName base_o ++ "__" ++ show n <.> osuf
@@ -1253,15 +1255,31 @@ runPhase SplitAs _input_fn dflags
io $ mapM_ assemble_file [1..n]
- -- If there's a stub_o file, then we make it the n+1th split object.
+ -- Note [pipeline-split-init]
+ -- If we have a stub file, it may contain constructor
+ -- functions for initialisation of this module. We can't
+ -- simply leave the stub as a separate object file, because it
+ -- will never be linked in: nothing refers to it. We need to
+ -- ensure that if we ever refer to the data in this module
+ -- that needs initialisation, then we also pull in the
+ -- initialisation routine.
+ --
+ -- To that end, we make a DANGEROUS ASSUMPTION here: the data
+ -- that needs to be initialised is all in the FIRST split
+ -- object. See Note [codegen-split-init].
+
PipeState{maybe_stub_o} <- getPipeState
- n' <- case maybe_stub_o of
- Nothing -> return n
- Just stub_o -> do io $ copyFile stub_o (split_obj (n+1))
- return (n+1)
+ case maybe_stub_o of
+ Nothing -> return ()
+ Just stub_o -> io $ do
+ tmp_split_1 <- newTempName dflags osuf
+ let split_1 = split_obj 1
+ copyFile split_1 tmp_split_1
+ removeFile split_1
+ joinObjectFiles dflags [tmp_split_1, stub_o] split_1
-- join them into a single .o file
- io $ joinObjectFiles dflags (map split_obj [1..n']) output_fn
+ io $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
return (next_phase, output_fn)
@@ -1979,14 +1997,22 @@ joinObjectFiles dflags o_files output_fn = do
SysTools.Option "-nostdlib",
SysTools.Option "-nodefaultlibs",
SysTools.Option "-Wl,-r",
+ SysTools.Option ld_build_id,
SysTools.Option ld_x_flag,
SysTools.Option "-o",
SysTools.FileOption "" output_fn ]
++ map SysTools.Option md_c_flags
++ args)
+
ld_x_flag | null cLD_X = ""
| otherwise = "-Wl,-x"
+ -- suppress the generation of the .note.gnu.build-id section,
+ -- which we don't need and sometimes causes ld to emit a
+ -- warning:
+ ld_build_id | cLdHasBuildId == "YES" = "-Wl,--build-id=none"
+ | otherwise = ""
+
md_c_flags = machdepCCOpts dflags
if cLdIsGNULd == "YES"
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 0d94ade469..ca2e14cee2 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -756,9 +756,7 @@ data CoreModule
-- | Type environment for types declared in this module
cm_types :: !TypeEnv,
-- | Declarations
- cm_binds :: [CoreBind],
- -- | Imports
- cm_imports :: ![Module]
+ cm_binds :: [CoreBind]
}
instance Outputable CoreModule where
@@ -857,11 +855,11 @@ compileCore simplify fn = do
gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
gutsToCoreModule (Left (cg, md)) = CoreModule {
cm_module = cg_module cg, cm_types = md_types md,
- cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg
+ cm_binds = cg_binds cg
}
gutsToCoreModule (Right mg) = CoreModule {
cm_module = mg_module mg, cm_types = mg_types mg,
- cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg
+ cm_binds = mg_binds mg
}
-- %************************************************************************
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 841125a0c5..70ddd6adb8 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -109,7 +109,8 @@ import CoreToStg ( coreToStg )
import qualified StgCmm ( codeGen )
import StgSyn
import CostCentre
-import TyCon ( TyCon, isDataTyCon )
+import ProfInit
+import TyCon ( TyCon, isDataTyCon )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
@@ -863,8 +864,7 @@ hscGenHardCode cgguts mod_summary
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
- cg_dir_imps = dir_imps,
- cg_foreign = foreign_stubs,
+ cg_foreign = foreign_stubs0,
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
@@ -883,16 +883,19 @@ hscGenHardCode cgguts mod_summary
<- {-# SCC "CoreToStg" #-}
myCoreToStg dflags this_mod prepd_binds
+ let prof_init = profilingInitCode this_mod cost_centre_info
+ foreign_stubs = foreign_stubs0 `appendStubC` prof_init
+
------------------ Code generation ------------------
cmms <- if dopt Opt_TryNewCodeGen dflags
then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons
- dir_imps cost_centre_info
+ cost_centre_info
stg_binds hpc_info
return cmms
else {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
- dir_imps cost_centre_info
+ cost_centre_info
stg_binds hpc_info
--- Optionally run experimental Cmm transformations ---
@@ -963,15 +966,15 @@ hscCompileCmmFile hsc_env filename
-------------------- Stuff for new code gen ---------------------
-tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> [Module]
+tryNewCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [(StgBinding,[(Id,[Id])])]
-> HpcInfo
-> IO [Cmm]
-tryNewCodeGen hsc_env this_mod data_tycons imported_mods
+tryNewCodeGen hsc_env this_mod data_tycons
cost_centre_info stg_binds hpc_info =
do { let dflags = hsc_dflags hsc_env
- ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods
+ ; prog <- StgCmm.codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
(pprCmms prog)
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 3d441cce57..e59c2239a7 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -14,7 +14,7 @@ module HscTypes (
-- * Information about modules
ModDetails(..), emptyModDetails,
- ModGuts(..), CgGuts(..), ForeignStubs(..),
+ ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods,
ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
@@ -799,11 +799,7 @@ data CgGuts
-- data constructor workers; reason: we we regard them
-- as part of the code-gen of tycons
- cg_dir_imps :: ![Module],
- -- ^ Directly-imported modules; used to generate
- -- initialisation code
-
- cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
+ cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to
-- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
@@ -823,6 +819,10 @@ data ForeignStubs = NoStubs -- ^ We don't have any stubs
--
-- 2) C stubs to use when calling
-- "foreign exported" functions
+
+appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
+appendStubC NoStubs c_code = ForeignStubs empty c_code
+appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
\end{code}
\begin{code}
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index b78c0dbef2..f23280bc19 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -292,8 +292,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
mg_binds = binds,
mg_rules = imp_rules,
mg_vect_info = vect_info,
- mg_dir_imps = dir_imps,
- mg_anns = anns,
+ mg_anns = anns,
mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info,
@@ -363,13 +362,10 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
<+> int (cs_ty cs)
<+> int (cs_co cs) ))
- ; let dir_imp_mods = moduleEnvKeys dir_imps
-
- ; return (CgGuts { cg_module = mod,
- cg_tycons = alg_tycons,
- cg_binds = all_tidy_binds,
- cg_dir_imps = dir_imp_mods,
- cg_foreign = foreign_stubs,
+ ; return (CgGuts { cg_module = mod,
+ cg_tycons = alg_tycons,
+ cg_binds = all_tidy_binds,
+ cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps,
cg_hpc_info = hpc_info,
cg_modBreaks = modBreaks },
diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
new file mode 100644
index 0000000000..7e223f80e9
--- /dev/null
+++ b/compiler/profiling/ProfInit.hs
@@ -0,0 +1,45 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- Generate code to initialise cost centres
+--
+-- -----------------------------------------------------------------------------
+
+module ProfInit (profilingInitCode) where
+
+import CLabel
+import CostCentre
+import Outputable
+import StaticFlags
+import FastString
+import 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, ___extern_CCs, singleton_CCSs)
+ | not opt_SccProfilingOn = empty
+ | otherwise
+ = 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
+ ))
+ ]
+ where
+ emitRegisterCC cc =
+ ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$
+ ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi
+ where cc_lbl = ppr (mkCCLabel cc)
+ emitRegisterCCS ccs =
+ ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$
+ ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi
+ where ccs_lbl = ppr (mkCCSLabel ccs)