%
+% (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
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}
-> [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
; 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
-> 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) }
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
-- 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
{ -- 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
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
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}
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
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
projects / ghc-hetmet.git / blobdiff