X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCodeGen.lhs;h=142ee9c1fc860c236180c1254ee371ba5bd0442c;hb=e5efd651e7e80cd3549304578a1e1685e91d3d0a;hp=4f2e58556c268eba0813a03bde02927f814ad221;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 4f2e585..142ee9c 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,57 +15,62 @@ 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 ) import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) -import Bag ( foldBag ) import CgBindery ( CgIdInfo ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) import CgConTbls ( genStaticConBits ) import ClosureInfo ( mkClosureLFInfo ) -import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingGhcInternals, - opt_EnsureSplittableC, opt_SccGroup +import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, + opt_SccGroup ) -import CStrings ( modnameToC ) +import CostCentre ( CostCentre, CostCentreStack ) import FiniteMap ( FiniteMap ) -import Maybes ( maybeToBool ) +import Id ( Id, idName ) +import Name ( Module, moduleCString, moduleString ) import PrimRep ( getPrimRepSize, PrimRep(..) ) -import Util ( panic, assertPanic ) +import Type ( Type ) +import TyCon ( TyCon ) +import BasicTypes ( TopLevelFlag(..) ) +import Util +import Panic ( assertPanic ) \end{code} \begin{code} -codeGen :: FAST_STRING -- module name +codeGen :: Module -- module name -> ([CostCentre], -- local cost-centres needing declaring/registering - [CostCentre]) -- "extern" cost-centres needing declaring + [CostCentre], -- "extern" cost-centres needing declaring + [CostCentreStack]) -- pre-defined "singleton" cost centre stacks -> [Module] -- import names -> [TyCon] -- tycons with data constructors to convert -> FiniteMap TyCon [(Bool, [Maybe Type])] -- tycon specialisation info - -> [StgBinding] -- bindings to convert + -> [(StgBinding,[Id])] -- bindings to convert, with SRTs -> AbstractC -- output -codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm +codeGen mod_name (local_CCs, extern_CCs, singleton_CCSs) + 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 + maybe_split = if opt_EnsureSplittableC + then CSplitMarker + else AbsCNop cinfo = MkCompInfo mod_name in - if not doing_profiling then - mkAbstractCs [ + let + module_code = mkAbstractCs [ genStaticConBits cinfo gen_tycons tycon_specs, initC cinfo (cgTopBindings maybe_split stg_pgm) ] - else -- yes, cost-centre profiling: + -- Cost-centre profiling: -- Besides the usual stuff, we must produce: -- -- * Declarations for the cost-centres defined in this module; @@ -75,33 +80,37 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg -- (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], + -- + cost_centre_stuff + | not opt_SccProfilingOn = AbsCNop + | otherwise = mkAbstractCs ( + map (CCostCentreDecl True) local_CCs ++ + map (CCostCentreDecl False) extern_CCs ++ + map CCostCentreStackDecl singleton_CCSs ++ + mkCcRegister local_CCs singleton_CCSs import_names + ) + in + mkAbstractCs [ cost_centre_stuff, module_code ] - genStaticConBits cinfo gen_tycons tycon_specs, - initC cinfo (cgTopBindings maybe_split stg_pgm) ] where ----------------- grp_name = case opt_SccGroup of Just xx -> _PK_ xx - Nothing -> mod_name -- default: module name + Nothing -> _PK_ (moduleString mod_name) -- default: module name ----------------- - mkCcRegister ccs import_names + mkCcRegister ccs cc_stacks import_names = let register_ccs = mkAbstractCs (map mk_register ccs) register_imports = foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names + 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], + [ + CCallProfCCMacro SLIT("START_REGISTER_CCS") + [ CLitLit (_PK_ ("_reg" ++ moduleCString mod_name)) AddrRep], register_ccs, + register_cc_stacks, register_imports, CCallProfCCMacro SLIT("END_REGISTER_CCS") [] ] @@ -109,8 +118,12 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg mk_register cc = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc] + mk_register_ccs ccs + = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs] + mk_import_register import_name - = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep] + = CCallProfCCMacro SLIT("REGISTER_IMPORT") + [CLitLit (_PK_ ("_reg" ++ moduleCString import_name)) AddrRep] \end{code} %************************************************************************ @@ -130,23 +143,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 @@ -155,14 +182,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)) +cgTopRhs bndr (StgRhsCon cc con args) + = forkStatics (cgTopRhsCon bndr con args (all zero_size args)) where zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0 -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) + forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info) where - lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args + lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args \end{code}