X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCodeGen.lhs;h=95926aa602bcbbab56e62ab9710df8fe85820b3b;hb=90c6cd0e5b6ee9a9d34b9404a38cf0cf2433ffe4;hp=a1aa854e7e9d4a1e2d758fd196a0f89d098c0751;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index a1aa854..95926aa 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-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CodeGen]{@CodeGen@: main module of the code generator} @@ -15,98 +15,113 @@ functions drive the mangling of top-level bindings. %************************************************************************ \begin{code} -#include "HsVersions.h" - -module CodeGen ( - codeGen, - - -- and to make the interface self-sufficient... - UniqFM, AbstractC, StgBinding, Id, FiniteMap - ) where +module CodeGen ( codeGen ) where +#include "HsVersions.h" import StgSyn import CgMonad import AbsCSyn +import CLabel ( CLabel, mkSRTLabel, mkClosureLabel ) -import CLabelInfo ( modnameToC ) +import PprAbsC ( dumpRealC ) +import AbsCUtils ( mkAbstractCs, mkAbsCStmts, flattenAbsC ) +import CgBindery ( CgIdInfo, addBindC, addBindsC ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) -import CgConTbls ( genStaticConBits, TCE(..), UniqFM ) -import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo ) -import CmdLineOpts ( GlobalSwitch(..), switchIsOn, stringSwitchSet, SwitchResult ) +import CgConTbls ( genStaticConBits ) +import ClosureInfo ( mkClosureLFInfo ) +import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, + opt_D_dump_absC, opt_SccGroup + ) +import CostCentre ( CostCentre, CostCentreStack ) import FiniteMap ( FiniteMap ) -import Maybes ( Maybe(..) ) -import PrimKind ( getKindSize ) +import Id ( Id, idName ) +import Module ( Module, moduleString, ModuleName, moduleNameString ) +import PrimRep ( getPrimRepSize, PrimRep(..) ) +import Type ( Type ) +import TyCon ( TyCon, isDataTyCon ) +import Class ( Class, classTyCon ) +import BasicTypes ( TopLevelFlag(..) ) +import UniqSupply ( mkSplitUniqSupply ) +import ErrUtils ( dumpIfSet ) 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 - -> [FAST_STRING] -- import names - -> (GlobalSwitch -> SwitchResult) - -- global switch lookup function - -> [TyCon] -- tycons with data constructors to convert - -> FiniteMap TyCon [[Maybe UniType]] - -- tycon specialisation info - -> PlainStgProgram -- bindings to convert - -> AbstractC -- output - -codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons tycon_specs stg_pgm - = let - switch_is_on = switchIsOn sw_lookup_fn - doing_profiling = switch_is_on SccProfilingOn - compiling_prelude = switch_is_on CompilingPrelude - splitting = switch_is_on (EnsureSplittableC (panic "codeGen:esc")) + + +codeGen :: Module -- Module name + -> [ModuleName] -- Import names + -> ([CostCentre], -- Local cost-centres needing declaring/registering + [CostCentre], -- "extern" cost-centres needing declaring + [CostCentreStack]) -- Pre-defined "singleton" cost centre stacks + -> [TyCon] -> [Class] -- Local tycons and classes + -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs + -> IO AbstractC -- Output + +codeGen mod_name imported_modules cost_centre_info + 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) + cost_centre_stuff = mkCostCentreStuff mod_name imported_modules cost_centre_info + + abstractC = mkAbstractCs [ cost_centre_stuff, + datatype_stuff, + code_stuff ] + + flat_abstractC = flattenAbsC fl_uniqs abstractC in - if not doing_profiling then - let - cinfo = MkCompInfo switch_is_on mod_name - in - mkAbstractCs [ - genStaticConBits cinfo gen_tycons tycon_specs, - initC cinfo (cgTopBindings splitting 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. - let - cinfo = MkCompInfo switch_is_on mod_name - in - 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 splitting stg_pgm) ] + dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >> + return flat_abstractC + + where + 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} + +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.) + +\begin{code} +mkCostCentreStuff mod_name import_names (local_CCs, extern_CCs, singleton_CCSs) + | 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 + ) + where - ----------------- - grp_name = case (stringSwitchSet sw_lookup_fn SccGroup) of - Just xx -> _PK_ xx - Nothing -> mod_name -- default: module name - - ----------------- - mkCcRegister ccs import_names - = let + mkCcRegister ccs cc_stacks import_names + = let register_ccs = mkAbstractCs (map mk_register ccs) - register_imports = mkAbstractCs (map mk_import_register import_names) + 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)) AddrKind], + [ + CCallProfCCMacro SLIT("START_REGISTER_CCS") + [ CLitLit (_PK_ ("_reg" ++ moduleString mod_name)) AddrRep], register_ccs, + register_cc_stacks, register_imports, CCallProfCCMacro SLIT("END_REGISTER_CCS") [] ] @@ -114,8 +129,12 @@ codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons ty 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)) AddrKind] + = CCallProfCCMacro SLIT("REGISTER_IMPORT") + [CLitLit (_PK_ ("_reg" ++ moduleNameString import_name)) AddrRep] \end{code} %************************************************************************ @@ -135,43 +154,55 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBindings :: Bool -> PlainStgProgram -> Code +cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code + +cgTopBindings split bindings = mapCs (cgTopBinding split) bindings -cgTopBindings splitting bindings = mapCs (cgTopBinding splitting) bindings - -cgTopBinding :: Bool -> PlainStgBinding -> Code +cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code -cgTopBinding splitting (StgNonRec name rhs) - = absC maybe_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 - maybe_split = if splitting then CSplitMarker else AbsCNop + srt_label = mkSRTLabel (idName name) -cgTopBinding splitting (StgRec pairs) - = absC maybe_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 - maybe_split = if splitting then CSplitMarker else AbsCNop + 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 -- statics "error" call in initC. I DON'T UNDERSTAND WHY! -cgTopRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo) +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 = getKindSize (getAtomKind atom) == 0 + 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) - where - lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args body + 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}