X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCodeGen.lhs;h=e707cb0e0f7c6d088bc6333100a392a011f7b3c4;hb=6a3f5f6beed9cec42c4b3a1b7cabc1809c838562;hp=a786145a4ac5277091f6d92276d7970440d2f9ad;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index a786145..e707cb0 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CodeGen]{@CodeGen@: main module of the code generator} @@ -15,105 +15,157 @@ functions drive the mangling of top-level bindings. %************************************************************************ \begin{code} -#include "HsVersions.h" - module CodeGen ( codeGen ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import StgSyn import CgMonad import AbsCSyn +import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, + mkModuleInitLabel, labelDynamic ) -import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) -import Bag ( foldBag ) -import CgBindery ( CgIdInfo ) +import PprAbsC ( dumpRealC ) +import AbsCUtils ( mkAbstractCs, flattenAbsC ) +import CgBindery ( CgIdInfo, addBindC, addBindsC ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) import CgConTbls ( genStaticConBits ) import ClosureInfo ( mkClosureLFInfo ) -import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingGhcInternals, - opt_EnsureSplittableC, opt_SccGroup - ) -import CStrings ( modnameToC ) -import FiniteMap ( FiniteMap ) -import Maybes ( maybeToBool ) +import CmdLineOpts ( DynFlags, DynFlag(..), + opt_SccProfilingOn, opt_EnsureSplittableC ) +import CostCentre ( CostCentre, CostCentreStack ) +import Id ( Id, idName ) +import Module ( Module, moduleString, moduleName, + ModuleName ) import PrimRep ( getPrimRepSize, PrimRep(..) ) -import Util ( panic, assertPanic ) +import Type ( Type ) +import TyCon ( TyCon, isDataTyCon ) +import Class ( Class, classTyCon ) +import BasicTypes ( TopLevelFlag(..) ) +import UniqSupply ( mkSplitUniqSupply ) +import ErrUtils ( dumpIfSet_dyn ) +import Util +import Panic ( assertPanic ) \end{code} \begin{code} -codeGen :: FAST_STRING -- module name - -> ([CostCentre], -- local cost-centres needing declaring/registering - [CostCentre]) -- "extern" cost-centres needing declaring - -> [Module] -- import names - -> [TyCon] -- tycons with data constructors to convert - -> FiniteMap TyCon [(Bool, [Maybe Type])] - -- tycon specialisation info - -> [StgBinding] -- bindings to convert - -> AbstractC -- output -codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm - = let - doing_profiling = opt_SccProfilingOn - compiling_prelude = opt_CompilingGhcInternals - maybe_split = if opt_EnsureSplittableC - then CSplitMarker - else AbsCNop - cinfo = MkCompInfo mod_name +codeGen :: DynFlags + -> Module -- Module name + -> [Module] -- Import names + -> ([CostCentre], -- Local cost-centres needing declaring/registering + [CostCentre], -- "extern" cost-centres needing declaring + [CostCentreStack]) -- Pre-defined "singleton" cost centre stacks + -> [Id] -- foreign-exported binders + -> [TyCon] -> [Class] -- Local tycons and classes + -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs + -> IO AbstractC -- Output + +codeGen dflags mod_name imported_modules cost_centre_info fe_binders + tycons classes stg_binds + = mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener + let + datatype_stuff = genStaticConBits cinfo data_tycons + code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds) + init_stuff = mkModuleInit fe_binders mod_name imported_modules + cost_centre_info + + abstractC = mkAbstractCs [ maybe_split, + init_stuff, + code_stuff, + datatype_stuff] + -- 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 + + flat_abstractC = flattenAbsC fl_uniqs abstractC in - if not doing_profiling then - mkAbstractCs [ - genStaticConBits cinfo gen_tycons tycon_specs, - initC cinfo (cgTopBindings maybe_split stg_pgm) ] - - else -- yes, cost-centre profiling: - -- Besides the usual stuff, we must produce: - -- - -- * Declarations for the cost-centres defined in this module; - -- * Code to participate in "registering" all the cost-centres - -- in the program (done at startup time when the pgm is run). - -- - -- (The local cost-centres involved in this are passed - -- into the code-generator, as are the imported-modules' names.) - -- - -- Note: we don't register/etc if compiling Prelude bits. - - mkAbstractCs [ - if compiling_prelude - then AbsCNop - else mkAbstractCs [mkAbstractCs (map (CCostCentreDecl True) local_CCs), - mkAbstractCs (map (CCostCentreDecl False) extern_CCs), - mkCcRegister local_CCs import_names], - - genStaticConBits cinfo gen_tycons tycon_specs, - initC cinfo (cgTopBindings maybe_split stg_pgm) ] + dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >> + return flat_abstractC + where - ----------------- - grp_name = case opt_SccGroup of - Just xx -> _PK_ xx - Nothing -> mod_name -- default: module name + data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes) + -- Generate info tables for the data constrs arising + -- from class decls as well + + maybe_split = if opt_EnsureSplittableC + then CSplitMarker + else AbsCNop + cinfo = MkCompInfo mod_name +\end{code} + +%************************************************************************ +%* * +\subsection[codegen-init]{Module initialisation code} +%* * +%************************************************************************ + +\begin{code} +mkModuleInit + :: [Id] -- foreign exported functions + -> Module -- module name + -> [Module] -- import names + -> ([CostCentre], -- cost centre info + [CostCentre], + [CostCentreStack]) + -> AbstractC +mkModuleInit fe_binders mod imps cost_centre_info + = let + register_fes = + map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels - ----------------- - mkCcRegister ccs import_names + fe_labels = + map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders + + (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info + + mk_import_register imp = + CMacroStmt REGISTER_IMPORT [ + CLbl (mkModuleInitLabel imp) AddrRep + ] + + register_imports = map mk_import_register imps + in + mkAbstractCs [ + cc_decls, + CModuleInitBlock (mkModuleInitLabel mod) + (mkAbstractCs (register_fes ++ + cc_regs : + register_imports)) + ] +\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} +mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs) + | not opt_SccProfilingOn = (AbsCNop, AbsCNop) + | otherwise = + ( mkAbstractCs ( + map (CCostCentreDecl True) local_CCs ++ + map (CCostCentreDecl False) extern_CCs ++ + map CCostCentreStackDecl singleton_CCSs), + mkAbstractCs (mkCcRegister local_CCs singleton_CCSs) + ) + where + mkCcRegister ccs cc_stacks = let - register_ccs = mkAbstractCs (map mk_register ccs) - register_imports - = foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names + register_ccs = mkAbstractCs (map mk_register ccs) + register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks) in - mkAbstractCs [ - CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep], - register_ccs, - register_imports, - CCallProfCCMacro SLIT("END_REGISTER_CCS") [] - ] + [ register_ccs, register_cc_stacks ] where mk_register cc = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc] - mk_import_register import_name - = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep] + mk_register_ccs ccs + = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs] \end{code} %************************************************************************ @@ -133,23 +185,37 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBindings :: AbstractC -> [StgBinding] -> Code +cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code cgTopBindings split bindings = mapCs (cgTopBinding split) bindings -cgTopBinding :: AbstractC -> StgBinding -> Code +cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code -cgTopBinding split (StgNonRec name rhs) - = absC split `thenC` - cgTopRhs name rhs `thenFC` \ (name, info) -> +cgTopBinding split ((StgNonRec name rhs), srt) + = absC split `thenC` + absC (mkSRT srt_label srt) `thenC` + setSRTLabel srt_label ( + cgTopRhs name rhs `thenFC` \ (name, info) -> addBindC name info + ) + where + srt_label = mkSRTLabel (idName name) -cgTopBinding split (StgRec pairs) - = absC split `thenC` +cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt) + = absC split `thenC` + absC (mkSRT srt_label srt) `thenC` + setSRTLabel srt_label ( fixC (\ new_binds -> addBindsC new_binds `thenC` mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs - ) `thenFC` \ new_binds -> + ) `thenFC` \ new_binds -> addBindsC new_binds + ) + where + srt_label = mkSRTLabel (idName name) + +mkSRT :: CLabel -> [Id] -> AbstractC +mkSRT lbl [] = AbsCNop +mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids) -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs -- to enclose the listFCs in cgTopBinding, but that tickled the @@ -158,14 +224,14 @@ cgTopBinding split (StgRec pairs) cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along for setting up a binding... -cgTopRhs name (StgRhsCon cc con args) - = forkStatics (cgTopRhsCon name con args (all zero_size args)) - where - zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 +cgTopRhs bndr (StgRhsCon cc con args) + = forkStatics (cgTopRhsCon bndr con args) -cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body) +cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables - forkStatics (cgTopRhsClosure name cc bi args body lf_info) - where - lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args + getSRTLabel `thenFC` \srt_label -> + let lf_info = + mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt + in + forkStatics (cgTopRhsClosure bndr cc bi args body lf_info) \end{code}