X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCodeGen.lhs;h=106fcc1cf1af08957f46394790d2b1fa8527db1e;hp=2c4ea5cfaed9442a4d668ab9514fe6c4e74e05c0;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=49c98d143c382a1341e1046f5ca00819a25691ba diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 2c4ea5c..106fcc1 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -25,45 +25,44 @@ import CgBindery import CgClosure import CgCon import CgUtils +import CgHpc import CLabel import Cmm import CmmUtils import PprCmm -import MachOp import StgSyn import PrelNames import DynFlags import StaticFlags -import PackageConfig import HscTypes import CostCentre import Id import Name -import OccName import TyCon import Module import ErrUtils - -#ifdef DEBUG import Panic -#endif \end{code} \begin{code} codeGen :: DynFlags -> Module -> [TyCon] - -> ForeignStubs -> [Module] -- directly-imported modules -> 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 foreign_stubs imported_mods - cost_centre_info stg_binds + -- N.B. returning '[Cmm]' and not 'Cmm' here makes it + -- 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 = do { showPass dflags "CodeGen" ; let way = buildTag dflags @@ -75,9 +74,9 @@ codeGen dflags this_mod data_tycons foreign_stubs 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 dflags way cost_centre_info + ; cmm_init <- getCmm (mkModuleInit way cost_centre_info this_mod main_mod - foreign_stubs imported_mods) + imported_mods hpc_info) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) } -- Put datatype_stuff after code_stuff, because the @@ -135,24 +134,29 @@ We initialise the module tree by keeping a work-stack, \begin{code} mkModuleInit - :: DynFlags - -> String -- the "way" + :: String -- the "way" -> CollectedCCs -- cost centre info -> Module -> Module -- name of the Main module - -> ForeignStubs -> [Module] + -> HpcInfo -> Code -mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods - = do { - if opt_SccProfilingOn - then do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] +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] + + ; whenC (opt_Hpc) $ + hpcTable this_mod hpc_info - ; emitSimpleProc real_init_lbl $ do - { ret_blk <- forkLabelledCode ret_code + -- 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) } @@ -161,8 +165,6 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe ret_blk) ; stmtC (CmmBranch init_blk) } - } - else emitSimpleProc real_init_lbl ret_code -- Make the "plain" procedure jump to the "real" init procedure ; emitSimpleProc plain_init_lbl jump_to_init @@ -172,19 +174,21 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe -- 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 jump_to_init) + (emitSimpleProc plain_main_init_lbl rec_descent_init) } where - this_pkg = thisPackage dflags - - plain_init_lbl = mkPlainModuleInitLabel this_pkg this_mod - real_init_lbl = mkModuleInitLabel this_pkg this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel this_pkg rOOT_MAIN + 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) wordRep + mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord -- Main refers to GHC.TopHandler.runIO, so make sure we call the -- init function for GHC.TopHandler. @@ -196,25 +200,35 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe { -- Set mod_reg to 1 to record that we've been here stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))) - -- Now do local stuff - ; initCostCentres cost_centre_info - ; mapCs (registerModuleImport this_pkg way) + ; 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)) wordRep) [] ] + , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ] + + + rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info + then jump_to_init + else ret_code ----------------------- -registerModuleImport :: PackageId -> String -> Module -> Code -registerModuleImport this_pkg way mod +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 this_pkg mod way)) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ] \end{code} @@ -258,7 +272,7 @@ variable. cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code cgTopBinding dflags (StgNonRec id rhs, srts) = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT (thisPackage dflags) [id']) srts + ; mapM_ (mkSRT [id']) srts ; (id,info) <- cgTopRhs id' rhs ; addBindC id info -- Add the *un-externalised* Id to the envt, -- so we find it when we look up occurrences @@ -268,19 +282,19 @@ cgTopBinding dflags (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT (thisPackage dflags) bndrs') srts + ; mapM_ (mkSRT bndrs') srts ; _new_binds <- fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; nopC } -mkSRT :: PackageId -> [Id] -> (Id,[Id]) -> Code -mkSRT this_pkg these (id,[]) = nopC -mkSRT this_pkg these (id,ids) +mkSRT :: [Id] -> (Id,[Id]) -> Code +mkSRT _ (_,[]) = nopC +mkSRT these (id,ids) = do { ids <- mapFCs remap ids ; id <- remap id - ; emitRODataLits (mkSRTLabel (idName id)) - (map (CmmLabel . mkClosureLabel this_pkg . idName) ids) + ; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id)) + (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids) } where -- Sigh, better map all the ids against the environment in @@ -297,13 +311,14 @@ cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary -cgTopRhs bndr (StgRhsCon cc con args) +cgTopRhs bndr (StgRhsCon _cc con args) = forkStatics (cgTopRhsCon bndr con args) cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) = ASSERT(null fvs) -- There should be no free variables - setSRTLabel (mkSRTLabel (idName bndr)) $ - forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body) + setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $ + setSRT srt $ + forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body) \end{code} @@ -329,7 +344,7 @@ maybeExternaliseId dflags id name = idName id uniq = nameUnique name new_occ = mkLocalOcc uniq (nameOccName name) - loc = nameSrcLoc name + loc = nameSrcSpan name -- We want to conjure up a name that can't clash with any -- existing name. So we generate -- Mod_$L243foo