diff options
33 files changed, 454 insertions, 804 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index 23e6bc08bf..e09bda8440 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -484,6 +484,31 @@ AC_SUBST([LdXFlag]) ])# FP_PROG_LD_X +# FP_PROG_LD_BUILD_ID +# ------------ + +# Sets the output variable LdHasBuildId to YES if ld supports +# --build-id, or NO otherwise. +AC_DEFUN([FP_PROG_LD_BUILD_ID], +[ +AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id], +[echo 'foo() {}' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_build_id=yes +else + fp_cv_ld_build_id=no +fi +rm -rf conftest*]) +if test "$fp_cv_ld_build_id" = yes; then + LdHasBuildId=YES +else + LdHasBuildId=NO +fi +AC_SUBST([LdHasBuildId]) +])# FP_PROG_LD_BUILD_ID + + # FP_PROG_LD_IS_GNU # ----------------- # Sets the output variable LdIsGNULd to YES or NO, depending on whether it is 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) diff --git a/configure.ac b/configure.ac index 21e965b71c..7baa3ddb5c 100644 --- a/configure.ac +++ b/configure.ac @@ -816,6 +816,7 @@ FP_LEADING_UNDERSCORE dnl ** check for ld, whether it has an -x option, and if it is GNU ld FP_PROG_LD_X FP_PROG_LD_IS_GNU +FP_PROG_LD_BUILD_ID dnl ** check for Apple-style dead-stripping support dnl (.subsections-via-symbols assembler directive) diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 47c0f01ba9..97a237876f 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -245,18 +245,11 @@ extern HsInt foo(HsInt a0);</programlisting> #include "foo_stub.h" #endif -#ifdef __GLASGOW_HASKELL__ -extern void __stginit_Foo ( void ); -#endif - int main(int argc, char *argv[]) { int i; hs_init(&argc, &argv); -#ifdef __GLASGOW_HASKELL__ - hs_add_root(__stginit_Foo); -#endif for (i = 0; i < 5; i++) { printf("%d\n", foo(2500)); @@ -283,26 +276,6 @@ int main(int argc, char *argv[]) (i.e. those arguments between <literal>+RTS...-RTS</literal>).</para> - <para>Next, we call - <function>hs_add_root</function><indexterm><primary><function>hs_add_root</function></primary> - </indexterm>, a GHC-specific interface which is required to - initialise the Haskell modules in the program. The argument - to <function>hs_add_root</function> should be the name of the - initialization function for the "root" module in your program - - in other words, the module which directly or indirectly - imports all the other Haskell modules in the program. In a - standalone Haskell program the root module is normally - <literal>Main</literal>, but when you are using Haskell code - from a library it may not be. If your program has multiple - root modules, then you can call - <function>hs_add_root</function> multiple times, one for each - root. The name of the initialization function for module - <replaceable>M</replaceable> is - <literal>__stginit_<replaceable>M</replaceable></literal>, and - it may be declared as an external function symbol as in the - code above. Note that the symbol name should be transformed - according to the Z-encoding:</para> - <informaltable> <tgroup cols="2" align="left" colsep="1" rowsep="1"> <thead> @@ -380,9 +353,6 @@ int main(int argc, char *argv[]) // Initialize Haskell runtime hs_init(&argc, &argv); - // Tell Haskell about all root modules - hs_add_root(__stginit_Foo); - // do any other initialization here and // return false if there was a problem return HS_BOOL_TRUE; @@ -394,7 +364,7 @@ int main(int argc, char *argv[]) </programlisting> <para>The initialisation routine, <literal>mylib_init</literal>, calls - <literal>hs_init()</literal> and <literal>hs_add_root()</literal> as + <literal>hs_init()</literal> as normal to initialise the Haskell runtime, and the corresponding deinitialisation function <literal>mylib_end()</literal> calls <literal>hs_exit()</literal> to shut down the runtime.</para> @@ -599,8 +569,7 @@ int main(int argc, char *argv[]) invoke <literal>foreign export</literal>ed functions from multiple OS threads concurrently. The runtime system must be initialised as usual by - calling <literal>hs_init()</literal> - and <literal>hs_add_root</literal>, and these calls must + calling <literal>hs_init()</literal>, and this call must complete before invoking any <literal>foreign export</literal>ed functions.</para> </sect3> diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index 5915046c3e..86df5944b2 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -279,7 +279,6 @@ exposed-modules: Network.BSD, <programlisting> /usr/bin/ld: Undefined symbols: _ZCMain_main_closure -___stginit_ZCMain </programlisting> </para> diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml index bf243a2cd1..f00e1e2c38 100644 --- a/docs/users_guide/win32-dlls.xml +++ b/docs/users_guide/win32-dlls.xml @@ -429,8 +429,6 @@ foreign export stdcall adder :: Int -> Int -> IO Int // StartEnd.c #include <Rts.h> -extern void __stginit_Adder(void); - void HsStart() { int argc = 1; @@ -439,9 +437,6 @@ void HsStart() // Initialize Haskell runtime char** args = argv; hs_init(&argc, &args); - - // Tell Haskell about all root modules - hs_add_root(__stginit_Adder); } void HsEnd() diff --git a/includes/rts/Hpc.h b/includes/rts/Hpc.h index 26da35d4cd..bceb81c961 100644 --- a/includes/rts/Hpc.h +++ b/includes/rts/Hpc.h @@ -18,16 +18,16 @@ typedef struct _HpcModuleInfo { char *modName; // name of module StgWord32 tickCount; // number of ticks - StgWord32 tickOffset; // offset into a single large .tix Array - StgWord32 hashNo; // Hash number for this module's mix info + StgWord32 hashNo; // Hash number for this module's mix info StgWord64 *tixArr; // tix Array; local for this module + rtsBool from_file; // data was read from the .tix file struct _HpcModuleInfo *next; } HpcModuleInfo; -int hs_hpc_module (char *modName, - StgWord32 modCount, - StgWord32 modHashNo, - StgWord64 *tixArr); +void hs_hpc_module (char *modName, + StgWord32 modCount, + StgWord32 modHashNo, + StgWord64 *tixArr); HpcModuleInfo * hs_hpc_rootModule (void); diff --git a/mk/config.mk.in b/mk/config.mk.in index 10911e6934..be8b57bcb7 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -659,6 +659,10 @@ LD_X = @LdXFlag@ # overflowing command-line length limits. LdIsGNULd = @LdIsGNULd@ +# Set to YES if ld has the --build-id flag. Sometimes we need to +# disable it with --build-id=none. +LdHasBuildId = @LdHasBuildId@ + # On MSYS, building with SplitObjs=YES fails with # ar: Bad file number # see #3201. We need to specify a smaller max command-line size @@ -6,6 +6,8 @@ #include "Rts.h" #include "Trace.h" +#include "Hash.h" +#include "RtsUtils.h" #include <stdio.h> #include <ctype.h> @@ -36,11 +38,11 @@ static pid_t hpc_pid = 0; // pid of this process at hpc-boot time. static FILE *tixFile; // file being read/written static int tix_ch; // current char +static HashTable * moduleHash = NULL; // module name -> HpcModuleInfo + HpcModuleInfo *modules = 0; -HpcModuleInfo *nextModule = 0; -int totalTixes = 0; // total number of tix boxes. -static char *tixFilename; +static char *tixFilename = NULL; static void GNU_ATTRIBUTE(__noreturn__) failure(char *msg) { @@ -78,7 +80,7 @@ static void ws(void) { } static char *expectString(void) { - char tmp[256], *res; + char tmp[256], *res; // XXX int tmp_ix = 0; expect('"'); while (tix_ch != '"') { @@ -87,7 +89,7 @@ static char *expectString(void) { } tmp[tmp_ix++] = 0; expect('"'); - res = malloc(tmp_ix); + res = stgMallocBytes(tmp_ix,"Hpc.expectString"); strcpy(res,tmp); return res; } @@ -104,10 +106,8 @@ static StgWord64 expectWord64(void) { static void readTix(void) { unsigned int i; - HpcModuleInfo *tmpModule; + HpcModuleInfo *tmpModule, *lookup; - totalTixes = 0; - ws(); expect('T'); expect('i'); @@ -117,7 +117,9 @@ readTix(void) { ws(); while(tix_ch != ']') { - tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo)); + tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo), + "Hpc.readTix"); + tmpModule->from_file = rtsTrue; expect('T'); expect('i'); expect('x'); @@ -134,8 +136,6 @@ readTix(void) { ws(); tmpModule -> tickCount = (int)expectWord64(); tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64)); - tmpModule -> tickOffset = totalTixes; - totalTixes += tmpModule -> tickCount; ws(); expect('['); ws(); @@ -150,13 +150,32 @@ readTix(void) { expect(']'); ws(); - if (!modules) { - modules = tmpModule; + lookup = lookupHashTable(moduleHash, (StgWord)tmpModule->modName); + if (tmpModule == NULL) { + debugTrace(DEBUG_hpc,"readTix: new HpcModuleInfo for %s", + tmpModule->modName); + insertHashTable(moduleHash, (StgWord)tmpModule->modName, tmpModule); } else { - nextModule->next=tmpModule; + ASSERT(lookup->tixArr != 0); + ASSERT(!strcmp(tmpModule->modName, lookup->modName)); + debugTrace(DEBUG_hpc,"readTix: existing HpcModuleInfo for %s", + tmpModule->modName); + if (tmpModule->hashNo != lookup->hashNo) { + fprintf(stderr,"in module '%s'\n",tmpModule->modName); + failure("module mismatch with .tix/.mix file hash number"); + if (tixFilename != NULL) { + fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); + } + stg_exit(EXIT_FAILURE); + } + for (i=0; i < tmpModule->tickCount; i++) { + lookup->tixArr[i] = tmpModule->tixArr[i]; + } + stgFree(tmpModule->tixArr); + stgFree(tmpModule->modName); + stgFree(tmpModule); } - nextModule=tmpModule; - + if (tix_ch == ',') { expect(','); ws(); @@ -166,9 +185,18 @@ readTix(void) { fclose(tixFile); } -static void hpc_init(void) { +void +startupHpc(void) +{ char *hpc_tixdir; char *hpc_tixfile; + + if (moduleHash == NULL) { + // no modules were registered with hs_hpc_module, so don't bother + // creating the .tix file. + return; + } + if (hpc_inited != 0) { return; } @@ -177,6 +205,8 @@ static void hpc_init(void) { hpc_tixdir = getenv("HPCTIXDIR"); hpc_tixfile = getenv("HPCTIXFILE"); + debugTrace(DEBUG_hpc,"startupHpc"); + /* XXX Check results of mallocs/strdups, and check we are requesting enough bytes */ if (hpc_tixfile != NULL) { @@ -192,10 +222,13 @@ static void hpc_init(void) { #endif /* Then, try open the file */ - tixFilename = (char *) malloc(strlen(hpc_tixdir) + strlen(prog_name) + 12); + tixFilename = (char *) stgMallocBytes(strlen(hpc_tixdir) + + strlen(prog_name) + 12, + "Hpc.startupHpc"); sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,(int)hpc_pid); } else { - tixFilename = (char *) malloc(strlen(prog_name) + 6); + tixFilename = (char *) stgMallocBytes(strlen(prog_name) + 6, + "Hpc.startupHpc"); sprintf(tixFilename, "%s.tix", prog_name); } @@ -204,90 +237,80 @@ static void hpc_init(void) { } } -/* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory. - * This memory can be uninitized, because we will initialize it with either the contents - * of the tix file, or all zeros. +/* + * Called on a per-module basis, by a constructor function compiled + * with each module (see Coverage.hpcInitCode), declaring where the + * tix boxes are stored in memory. This memory can be uninitized, + * because we will initialize it with either the contents of the tix + * file, or all zeros. + * + * Note that we might call this before reading the .tix file, or after + * in the case where we loaded some Haskell code from a .so with + * dlopen(). So we must handle the case where we already have an + * HpcModuleInfo for the module which was read from the .tix file. */ -int +void hs_hpc_module(char *modName, StgWord32 modCount, StgWord32 modHashNo, - StgWord64 *tixArr) { - HpcModuleInfo *tmpModule, *lastModule; - unsigned int i; - int offset = 0; - - debugTrace(DEBUG_hpc,"hs_hpc_module(%s,%d)",modName,(nat)modCount); + StgWord64 *tixArr) +{ + HpcModuleInfo *tmpModule; + nat i; - hpc_init(); + if (moduleHash == NULL) { + moduleHash = allocStrHashTable(); + } - tmpModule = modules; - lastModule = 0; - - for(;tmpModule != 0;tmpModule = tmpModule->next) { - if (!strcmp(tmpModule->modName,modName)) { + tmpModule = lookupHashTable(moduleHash, (StgWord)modName); + if (tmpModule == NULL) + { + // Did not find entry so add one on. + tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo), + "Hpc.hs_hpc_module"); + tmpModule->modName = modName; + tmpModule->tickCount = modCount; + tmpModule->hashNo = modHashNo; + + tmpModule->tixArr = tixArr; + for(i=0;i < modCount;i++) { + tixArr[i] = 0; + } + tmpModule->next = modules; + tmpModule->from_file = rtsFalse; + modules = tmpModule; + insertHashTable(moduleHash, (StgWord)modName, tmpModule); + } + else + { if (tmpModule->tickCount != modCount) { - failure("inconsistent number of tick boxes"); + failure("inconsistent number of tick boxes"); } - assert(tmpModule->tixArr != 0); + ASSERT(tmpModule->tixArr != 0); if (tmpModule->hashNo != modHashNo) { - fprintf(stderr,"in module '%s'\n",tmpModule->modName); - failure("module mismatch with .tix/.mix file hash number"); - fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); - stg_exit(1); - + fprintf(stderr,"in module '%s'\n",tmpModule->modName); + failure("module mismatch with .tix/.mix file hash number"); + if (tixFilename != NULL) { + fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); + } + stg_exit(EXIT_FAILURE); } + // The existing tixArr was made up when we read the .tix file, + // whereas this is the real tixArr, so copy the data from the + // .tix into the real tixArr. for(i=0;i < modCount;i++) { - tixArr[i] = tmpModule->tixArr[i]; + tixArr[i] = tmpModule->tixArr[i]; } - tmpModule->tixArr = tixArr; - return tmpModule->tickOffset; - } - lastModule = tmpModule; - } - // Did not find entry so add one on. - tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo)); - tmpModule->modName = modName; - tmpModule->tickCount = modCount; - tmpModule->hashNo = modHashNo; - if (lastModule) { - tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount; - } else { - tmpModule->tickOffset = 0; - } - tmpModule->tixArr = tixArr; - for(i=0;i < modCount;i++) { - tixArr[i] = 0; - } - tmpModule->next = 0; - - if (!modules) { - modules = tmpModule; - } else { - lastModule->next=tmpModule; - } - - debugTrace(DEBUG_hpc,"end: hs_hpc_module"); - - return offset; -} - -/* This is called after all the modules have registered their local tixboxes, - * and does a sanity check: are we good to go? - */ - -void -startupHpc(void) { - debugTrace(DEBUG_hpc,"startupHpc"); - - if (hpc_inited == 0) { - return; + if (tmpModule->from_file) { + stgFree(tmpModule->modName); + stgFree(tmpModule->tixArr); + } + tmpModule->from_file = rtsFalse; } } - static void writeTix(FILE *f) { HpcModuleInfo *tmpModule; @@ -311,11 +334,10 @@ writeTix(FILE *f) { tmpModule->modName, (nat)tmpModule->hashNo, (nat)tmpModule->tickCount); - debugTrace(DEBUG_hpc,"%s: %u (offset=%u) (hash=%u)\n", + debugTrace(DEBUG_hpc,"%s: %u (hash=%u)\n", tmpModule->modName, (nat)tmpModule->tickCount, - (nat)tmpModule->hashNo, - (nat)tmpModule->tickOffset); + (nat)tmpModule->hashNo); inner_comma = 0; for(i = 0;i < tmpModule->tickCount;i++) { @@ -338,7 +360,17 @@ writeTix(FILE *f) { fclose(f); } -/* Called at the end of execution, to write out the Hpc *.tix file +static void +freeHpcModuleInfo (HpcModuleInfo *mod) +{ + if (mod->from_file) { + stgFree(mod->modName); + stgFree(mod->tixArr); + } + stgFree(mod); +} + +/* Called at the end of execution, to write out the Hpc *.tix file * for this exection. Safe to call, even if coverage is not used. */ void @@ -357,6 +389,12 @@ exitHpc(void) { FILE *f = fopen(tixFilename,"w"); writeTix(f); } + + freeHashTable(moduleHash, (void (*)(void *))freeHpcModuleInfo); + moduleHash = NULL; + + stgFree(tixFilename); + tixFilename = NULL; } ////////////////////////////////////////////////////////////////////////////// diff --git a/rts/Main.c b/rts/Main.c index c1b028ff1b..c7a559fc14 100644 --- a/rts/Main.c +++ b/rts/Main.c @@ -15,16 +15,10 @@ #include "Rts.h" #include "RtsMain.h" -/* The symbol for the Haskell Main module's init function. It is safe to refer - * to it here because this Main.o object file will only be linked in if we are - * linking a Haskell program that uses a Haskell Main.main function. - */ -extern void __stginit_ZCMain(void); - /* Similarly, we can refer to the ZCMain_main_closure here */ extern StgClosure ZCMain_main_closure; int main(int argc, char *argv[]) { - return hs_main(argc, argv, &__stginit_ZCMain, &ZCMain_main_closure); + return hs_main(argc, argv, &ZCMain_main_closure); } diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 39b64d4c51..f7fbd321be 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -309,7 +309,7 @@ void initProfiling1 (void) { } -void freeProfiling1 (void) +void freeProfiling (void) { } diff --git a/rts/Profiling.c b/rts/Profiling.c index 1d8627c5b1..5648f31e00 100644 --- a/rts/Profiling.c +++ b/rts/Profiling.c @@ -34,9 +34,9 @@ Arena *prof_arena; * closure_cats */ -unsigned int CC_ID; -unsigned int CCS_ID; -unsigned int HP_ID; +unsigned int CC_ID = 1; +unsigned int CCS_ID = 1; +unsigned int HP_ID = 1; /* figures for the profiling report. */ @@ -58,8 +58,8 @@ CostCentreStack *CCCS; /* Linked lists to keep track of cc's and ccs's that haven't * been declared in the log file yet */ -CostCentre *CC_LIST; -CostCentreStack *CCS_LIST; +CostCentre *CC_LIST = NULL; +CostCentreStack *CCS_LIST = NULL; /* * Built-in cost centres and cost-centre stacks: @@ -152,41 +152,10 @@ initProfiling1 (void) /* for the benefit of allocate()... */ CCCS = CCS_SYSTEM; - - /* Initialize counters for IDs */ - CC_ID = 1; - CCS_ID = 1; - HP_ID = 1; - - /* Initialize Declaration lists to NULL */ - CC_LIST = NULL; - CCS_LIST = NULL; - - /* Register all the cost centres / stacks in the program - * CC_MAIN gets link = 0, all others have non-zero link. - */ - REGISTER_CC(CC_MAIN); - REGISTER_CC(CC_SYSTEM); - REGISTER_CC(CC_GC); - REGISTER_CC(CC_OVERHEAD); - REGISTER_CC(CC_SUBSUMED); - REGISTER_CC(CC_DONT_CARE); - REGISTER_CCS(CCS_MAIN); - REGISTER_CCS(CCS_SYSTEM); - REGISTER_CCS(CCS_GC); - REGISTER_CCS(CCS_OVERHEAD); - REGISTER_CCS(CCS_SUBSUMED); - REGISTER_CCS(CCS_DONT_CARE); - - CCCS = CCS_OVERHEAD; - - /* cost centres are registered by the per-module - * initialisation code now... - */ } void -freeProfiling1 (void) +freeProfiling (void) { arenaFree(prof_arena); } @@ -202,17 +171,36 @@ initProfiling2 (void) * information into it. */ initProfilingLogFile(); + /* Register all the cost centres / stacks in the program + * CC_MAIN gets link = 0, all others have non-zero link. + */ + REGISTER_CC(CC_MAIN); + REGISTER_CC(CC_SYSTEM); + REGISTER_CC(CC_GC); + REGISTER_CC(CC_OVERHEAD); + REGISTER_CC(CC_SUBSUMED); + REGISTER_CC(CC_DONT_CARE); + + REGISTER_CCS(CCS_SYSTEM); + REGISTER_CCS(CCS_GC); + REGISTER_CCS(CCS_OVERHEAD); + REGISTER_CCS(CCS_SUBSUMED); + REGISTER_CCS(CCS_DONT_CARE); + REGISTER_CCS(CCS_MAIN); + /* find all the "special" cost centre stacks, and make them children * of CCS_MAIN. */ - ASSERT(CCS_MAIN->prevStack == 0); + ASSERT(CCS_LIST == CCS_MAIN); + CCS_LIST = CCS_LIST->prevStack; + CCS_MAIN->prevStack = NULL; CCS_MAIN->root = CC_MAIN; ccsSetSelected(CCS_MAIN); DecCCS(CCS_MAIN); - for (ccs = CCS_LIST; ccs != CCS_MAIN; ) { + for (ccs = CCS_LIST; ccs != NULL; ) { next = ccs->prevStack; - ccs->prevStack = 0; + ccs->prevStack = NULL; ActualPush_(CCS_MAIN,ccs->cc,ccs); ccs->root = ccs->cc; ccs = next; diff --git a/rts/Profiling.h b/rts/Profiling.h index 3a4184fba6..e27ad4c5ed 100644 --- a/rts/Profiling.h +++ b/rts/Profiling.h @@ -14,9 +14,9 @@ #include "BeginPrivate.h" void initProfiling1 (void); -void freeProfiling1 (void); void initProfiling2 (void); void endProfiling (void); +void freeProfiling (void); extern FILE *prof_file; extern FILE *hp_file; diff --git a/rts/RtsMain.c b/rts/RtsMain.c index b6cf546aea..0ed6df494c 100644 --- a/rts/RtsMain.c +++ b/rts/RtsMain.c @@ -28,13 +28,10 @@ # include <windows.h> #endif -extern void __stginit_ZCMain(void); - /* Annoying global vars for passing parameters to real_main() below * This is to get around problem with Windows SEH, see hs_main(). */ static int progargc; static char **progargv; -static void (*progmain_init)(void); /* This will be __stginit_ZCMain */ static StgClosure *progmain_closure; /* This will be ZCMain_main_closure */ /* Hack: we assume that we're building a batch-mode system unless @@ -47,7 +44,7 @@ static void real_main(void) SchedulerStatus status; /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */ - startupHaskell(progargc,progargv,progmain_init); + startupHaskell(progargc,progargv,NULL); /* kick off the computation by creating the main thread with a pointer to mainIO_closure representing the computation of the overall program; @@ -95,18 +92,17 @@ static void real_main(void) * This gets called from a tiny main function which gets linked into each * compiled Haskell program that uses a Haskell main function. * - * We expect the caller to pass __stginit_ZCMain for main_init and - * ZCMain_main_closure for main_closure. The reason we cannot refer to - * these symbols directly is because we're inside the rts and we do not know - * for sure that we'll be using a Haskell main function. + * We expect the caller to pass ZCMain_main_closure for + * main_closure. The reason we cannot refer to this symbol directly + * is because we're inside the rts and we do not know for sure that + * we'll be using a Haskell main function. */ -int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure) +int hs_main(int argc, char *argv[], StgClosure *main_closure) { /* We do this dance with argc and argv as otherwise the SEH exception stuff (the BEGIN/END CATCH below) on Windows gets confused */ progargc = argc; progargv = argv; - progmain_init = main_init; progmain_closure = main_closure; #if defined(mingw32_HOST_OS) diff --git a/rts/RtsMain.h b/rts/RtsMain.h index 4aabc56517..24e58199bb 100644 --- a/rts/RtsMain.h +++ b/rts/RtsMain.h @@ -13,6 +13,6 @@ * The entry point for Haskell programs that use a Haskell main function * -------------------------------------------------------------------------- */ -int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure); +int hs_main(int argc, char *argv[], StgClosure *main_closure); #endif /* RTSMAIN_H */ diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index b860667fe4..236d07a9e0 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -224,90 +224,37 @@ hs_init(int *argc, char **argv[]) x86_init_fpu(); #endif + startupHpc(); + + // This must be done after module initialisation. + // ToDo: make this work in the presence of multiple hs_add_root()s. + initProfiling2(); + + // ditto. +#if defined(THREADED_RTS) + ioManagerStart(); +#endif + /* Record initialization times */ stat_endInit(); } // Compatibility interface void -startupHaskell(int argc, char *argv[], void (*init_root)(void)) +startupHaskell(int argc, char *argv[], void (*init_root)(void) STG_UNUSED) { hs_init(&argc, &argv); - if(init_root) - hs_add_root(init_root); } /* ----------------------------------------------------------------------------- - Per-module initialisation - - This process traverses all the compiled modules in the program - starting with "Main", and performing per-module initialisation for - each one. - - So far, two things happen at initialisation time: - - - we register stable names for each foreign-exported function - in that module. This prevents foreign-exported entities, and - things they depend on, from being garbage collected. - - - we supply a unique integer to each statically declared cost - centre and cost centre stack in the program. - - The code generator inserts a small function "__stginit_<module>" in each - module and calls the registration functions in each of the modules it - imports. - - The init* functions are compiled in the same way as STG code, - i.e. without normal C call/return conventions. Hence we must use - StgRun to call this stuff. + hs_add_root: backwards compatibility. (see #3252) -------------------------------------------------------------------------- */ -/* The init functions use an explicit stack... - */ -#define INIT_STACK_BLOCKS 4 -static StgFunPtr *init_stack = NULL; - void -hs_add_root(void (*init_root)(void)) +hs_add_root(void (*init_root)(void) STG_UNUSED) { - bdescr *bd; - nat init_sp; - Capability *cap; - - cap = rts_lock(); - - if (hs_init_count <= 0) { - barf("hs_add_root() must be called after hs_init()"); - } - - /* The initialisation stack grows downward, with sp pointing - to the last occupied word */ - init_sp = INIT_STACK_BLOCKS*BLOCK_SIZE_W; - bd = allocGroup_lock(INIT_STACK_BLOCKS); - init_stack = (StgFunPtr *)bd->start; - init_stack[--init_sp] = (StgFunPtr)stg_init_finish; - if (init_root != NULL) { - init_stack[--init_sp] = (StgFunPtr)init_root; - } - - cap->r.rSp = (P_)(init_stack + init_sp); - StgRun((StgFunPtr)stg_init, &cap->r); - - freeGroup_lock(bd); - - startupHpc(); - - // This must be done after module initialisation. - // ToDo: make this work in the presence of multiple hs_add_root()s. - initProfiling2(); - - rts_unlock(cap); - - // ditto. -#if defined(THREADED_RTS) - ioManagerStart(); -#endif + /* nothing */ } /* ---------------------------------------------------------------------------- @@ -424,7 +371,7 @@ hs_exit_(rtsBool wait_foreign) #endif endProfiling(); - freeProfiling1(); + freeProfiling(); #ifdef PROFILING // Originally, this was in report_ccs_profiling(). Now, retainer |