X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCodeGen.lhs;h=863d29e2e2b3dc9a8b471a59c81826af063dbd15;hp=4c08242612e03f4255e04ebde29a177d7c0d6f7f;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30 diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 4c08242..863d29e 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -1,19 +1,15 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[CodeGen]{@CodeGen@: main module of the code generator} + +The Code Generator This module says how things get going at the top level. @codeGen@ is the interface to the outside world. The \tr{cgTop*} functions drive the mangling of top-level bindings. -%************************************************************************ -%* * -\subsection[codeGen-outside-interface]{The code generator's offering to the world} -%* * -%************************************************************************ - \begin{code} module CodeGen ( codeGen ) where @@ -25,35 +21,35 @@ module CodeGen ( codeGen ) where import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT import CgProf import CgMonad -import CgBindery ( CgIdInfo, addBindC, addBindsC, getCgIdInfo, - cgIdInfoId ) -import CgClosure ( cgTopRhsClosure ) -import CgCon ( cgTopRhsCon, cgTyCon ) -import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord ) +import CgBindery +import CgClosure +import CgCon +import CgUtils +import CgHpc import CLabel import Cmm -import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr ) -import PprCmm ( pprCmms ) -import MachOp ( wordRep ) +import CmmUtils +import PprCmm +import MachOp import StgSyn -import PrelNames ( gHC_PRIM, rOOT_MAIN, gHC_TOP_HANDLER ) -import DynFlags ( DynFlags(..), DynFlag(..), dopt ) -import StaticFlags ( opt_SccProfilingOn ) - -import PackageConfig ( PackageId ) -import HscTypes ( ForeignStubs(..) ) -import CostCentre ( CollectedCCs ) -import Id ( Id, idName, setIdName ) -import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName ) -import OccName ( mkLocalOcc ) -import TyCon ( TyCon ) -import Module ( Module ) -import ErrUtils ( dumpIfSet_dyn, showPass ) +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 ( assertPanic ) +import Panic #endif \end{code} @@ -65,10 +61,11 @@ codeGen :: DynFlags -> [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 + cost_centre_info stg_binds hpc_info = do { showPass dflags "CodeGen" ; let way = buildTag dflags @@ -82,7 +79,7 @@ codeGen dflags this_mod data_tycons foreign_stubs imported_mods ; cmm_tycons <- mapM cgTyCon data_tycons ; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info this_mod main_mod - foreign_stubs imported_mods) + foreign_stubs imported_mods hpc_info) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) } -- Put datatype_stuff after code_stuff, because the @@ -147,17 +144,24 @@ mkModuleInit -> 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 dflags way cost_centre_info this_mod main_mod foreign_stubs 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) } @@ -166,8 +170,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 @@ -177,8 +179,12 @@ 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 @@ -201,10 +207,15 @@ 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 + ; whenC (opt_SccProfilingOn) $ do + initCostCentres cost_centre_info + + ; whenC (opt_Hpc) $ + initHpc this_mod hpc_info + ; mapCs (registerModuleImport this_pkg way) (imported_mods++extra_imported_mods) + } -- The return-code pops the work stack by @@ -212,6 +223,11 @@ mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs importe ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1) , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ] + + 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 @@ -307,8 +323,9 @@ cgTopRhs bndr (StgRhsCon cc 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)) $ + setSRT srt $ + forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body) \end{code} @@ -326,7 +343,7 @@ which refers to this name). maybeExternaliseId :: DynFlags -> Id -> FCode Id maybeExternaliseId dflags id | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs - isInternalName name = do { mod <- moduleName + isInternalName name = do { mod <- getModuleName ; returnFC (setIdName id (externalise mod)) } | otherwise = returnFC id where @@ -334,7 +351,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