%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
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.
\begin{code}
module CodeGen ( codeGen ) where
#include "HsVersions.h"
import CgExpr ( )
import CgProf
import CgMonad
import CgBindery
import CgClosure
import CgCon
import CgUtils
import CgHpc
import CLabel
import Cmm
import CmmUtils
import PprCmm
import StgSyn
import PrelNames
import DynFlags
import StaticFlags
import HscTypes
import CostCentre
import Id
import Name
import TyCon
import Module
import ErrUtils
import Panic
\end{code}
\begin{code}
codeGen :: DynFlags
-> Module
-> [TyCon]
-> [Module]
-> CollectedCCs
-> [(StgBinding,[(Id,[Id])])]
-> HpcInfo
-> IO [Cmm]
codeGen dflags this_mod data_tycons imported_mods
cost_centre_info stg_binds hpc_info
= do
{ showPass dflags "CodeGen"
; 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 cost_centre_info
this_mod imported_mods hpc_info)
; return (cmm_binds ++ concat cmm_tycons ++ [cmm_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
:: DynFlags
-> CollectedCCs
-> Module
-> [Module]
-> HpcInfo
-> Code
mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info
= do {
emitData Data [CmmDataLabel moduleRegdLabel,
CmmStaticLit zeroCLit]
; whenC (opt_Hpc) $
hpcTable this_mod hpc_info
; 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)
}
; emitSimpleProc plain_init_lbl jump_to_init
; whenC (this_mod == main_mod)
(emitSimpleProc plain_main_init_lbl rec_descent_init)
}
where
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
extra_imported_mods
| this_mod == main_mod = [gHC_TOP_HANDLER]
| otherwise = []
mod_init_code = do
{
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)
}
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
= stmtsC [ CmmAssign spReg (cmmRegOffW spReg (1))
, CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
\end{code}
Cost-centre profiling: Besides the usual stuff, we must produce
declarations for the cost-centres defined in this module;
(The local cost-centres involved in this are passed into the
code-generator.)
\begin{code}
initCostCentres :: CollectedCCs -> Code
initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
| not opt_SccProfilingOn = nopC
| otherwise
= do { mapM_ emitCostCentreDecl local_CCs
; mapM_ emitCostCentreStackDecl singleton_CCSs
; mapM_ emitRegisterCC local_CCs
; mapM_ emitRegisterCCS singleton_CCSs
}
\end{code}
%************************************************************************
%* *
\subsection[codegen-top-bindings]{Converting top-level STG bindings}
%* *
%************************************************************************
@cgTopBinding@ is only used for top-level bindings, since they need
to be allocated statically (not in the heap) and need to be labelled.
No unboxed bindings can happen at top level.
In the code below, the static bindings are accumulated in the
@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
This is so that we can write the top level processing in a compositional
style, with the increasing static environment being plumbed as a state
variable.
\begin{code}
cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
cgTopBinding dflags (StgNonRec id rhs, srts)
= do { id' <- maybeExternaliseId dflags id
; mapM_ (mkSRT [id']) srts
; (id,info) <- cgTopRhs id' rhs
; addBindC id info
}
cgTopBinding dflags (StgRec pairs, srts)
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
; mapM_ (mkSRT bndrs') srts
; _new_binds <- fixC (\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; nopC }
mkSRT :: [Id] -> (Id,[Id]) -> Code
mkSRT _ (_,[]) = nopC
mkSRT these (id,ids)
= do { ids <- mapFCs remap ids
; id <- remap id
; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id))
(map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
}
where
remap id = case filter (==id) these of
(id':_) -> returnFC id'
[] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
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)
setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
setSRT srt $
forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
\end{code}
%************************************************************************
%* *
\subsection{Stuff to support splitting}
%* *
%************************************************************************
If we're splitting the object, we need to externalise all the top-level names
(and then make sure we only use the externalised one in any C label we use
which refers to this name).
\begin{code}
maybeExternaliseId :: DynFlags -> Id -> FCode Id
maybeExternaliseId dflags id
| dopt Opt_SplitObjs dflags,
isInternalName name = do { mod <- getModuleName
; returnFC (setIdName id (externalise mod)) }
| otherwise = returnFC id
where
externalise mod = mkExternalName uniq mod new_occ loc
name = idName id
uniq = nameUnique name
new_occ = mkLocalOcc uniq (nameOccName name)
loc = nameSrcSpan name
\end{code}