X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCodeGen.lhs;h=94eb0b33d587019d2c185d0da8d18b66f7751afd;hb=25e8bcade5f62dcd25b1f070ab9e680a7240c8c7;hp=0cbb76ff72add201a29bd461600e7f2b208a56d3;hpb=567b2505b2d3d5874f3bf3641fd8d82b3207ea94;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 0cbb76f..94eb0b3 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -19,80 +19,79 @@ module CodeGen ( codeGen ) where #include "HsVersions.h" +-- Kludge (??) so that CgExpr is reached via at least one non-SOURCE +-- import. Before, that wasn't the case, and CM therefore didn't +-- bother to compile it. +import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT + import StgSyn import CgMonad import AbsCSyn -import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, - mkModuleInitLabel, labelDynamic ) +import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel ) import PprAbsC ( dumpRealC ) import AbsCUtils ( mkAbstractCs, flattenAbsC ) -import CgBindery ( CgIdInfo, addBindC, addBindsC ) +import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) import CgConTbls ( genStaticConBits ) import ClosureInfo ( mkClosureLFInfo ) -import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC, - opt_D_dump_absC - ) +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 Type ( Type ) +import Id ( Id, idName, setIdName ) +import Name ( globaliseName ) +import Module ( Module ) +import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, isDataTyCon ) -import Class ( Class, classTyCon ) import BasicTypes ( TopLevelFlag(..) ) import UniqSupply ( mkSplitUniqSupply ) -import ErrUtils ( dumpIfSet ) -import Util +import ErrUtils ( dumpIfSet_dyn, showPass ) import Panic ( assertPanic ) + +#ifdef DEBUG +import Outputable +#endif \end{code} \begin{code} - - -codeGen :: Module -- Module 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 + -> [TyCon] -- Local tycons, including ones from classes -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs -> IO AbstractC -- Output -codeGen 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] +codeGen dflags mod_name imported_modules cost_centre_info fe_binders + tycons stg_binds + = do { showPass dflags "CodeGen" + + ; fl_uniqs <- mkSplitUniqSupply 'f' + ; let + datatype_stuff = genStaticConBits cinfo data_tycons + code_stuff = initC cinfo (mapCs cgTopBinding stg_binds) + init_stuff = mkModuleInit fe_binders mod_name imported_modules + cost_centre_info + + abstractC = mkAbstractCs [ maybeSplitCode, + 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 - dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >> - return flat_abstractC + flat_abstractC = flattenAbsC fl_uniqs abstractC + ; dumpIfSet_dyn dflags 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 + data_tycons = filter isDataTyCon tycons cinfo = MkCompInfo mod_name \end{code} @@ -174,7 +173,7 @@ mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs) %* * %************************************************************************ -@cgTopBindings@ is only used for top-level bindings, since they need +@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. @@ -185,53 +184,82 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code - -cgTopBindings split bindings = mapCs (cgTopBinding split) bindings - -cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code - -cgTopBinding split ((StgNonRec name rhs), srt) - = absC split `thenC` - absC (mkSRT srt_label srt) `thenC` +cgTopBinding :: (StgBinding,[Id]) -> Code +cgTopBinding (StgNonRec srt_info id rhs, srt) + = absC maybeSplitCode `thenC` + maybeGlobaliseId id `thenFC` \ id' -> + let + srt_label = mkSRTLabel (idName id') + in + mkSRT srt_label srt [] `thenC` setSRTLabel srt_label ( - cgTopRhs name rhs `thenFC` \ (name, info) -> - addBindC name info + cgTopRhs id' rhs srt_info `thenFC` \ (id, info) -> + addBindC id info ) - where - srt_label = mkSRTLabel (idName name) -cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt) - = absC split `thenC` - absC (mkSRT srt_label srt) `thenC` +cgTopBinding (StgRec srt_info pairs, srt) + = absC maybeSplitCode `thenC` + let + (bndrs, rhss) = unzip pairs + in + mapFCs maybeGlobaliseId bndrs `thenFC` \ bndrs'@(id:_) -> + let + srt_label = mkSRTLabel (idName id) + pairs' = zip bndrs' rhss + in + mkSRT srt_label srt bndrs' `thenC` setSRTLabel srt_label ( - fixC (\ new_binds -> addBindsC new_binds `thenC` - mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs - ) `thenFC` \ new_binds -> - addBindsC new_binds + fixC (\ new_binds -> + addBindsC new_binds `thenC` + mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs' + ) `thenFC` \ new_binds -> nopC ) - where - srt_label = mkSRTLabel (idName name) -mkSRT :: CLabel -> [Id] -> AbstractC -mkSRT lbl [] = AbsCNop -mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids) +mkSRT :: CLabel -> [Id] -> [Id] -> Code +mkSRT lbl [] these = nopC +mkSRT lbl ids these + = mapFCs remap ids `thenFC` \ ids -> + absC (CSRT lbl (map (mkClosureLabel . idName) ids)) + where + -- sigh, better map all the ids against the environment in case they've + -- been globalised (see maybeGlobaliseId below). + remap id = case filter (==id) these of + [] -> getCAddrModeAndInfo id + `thenFC` \ (id, _, _) -> returnFC id + (id':_) -> returnFC id' + +-- If we're splitting the object, we need to globalise all the top-level names +-- (and then make sure we only use the globalised one in any C label we use +-- which refers to this name). +maybeGlobaliseId :: Id -> FCode Id +maybeGlobaliseId id + | opt_EnsureSplittableC + = moduleName `thenFC` \ mod -> + returnFC (setIdName id (globaliseName (idName id) mod)) + | otherwise -- Globalise the name for -split-objs + = returnFC id + +maybeSplitCode + | opt_EnsureSplittableC = CSplitMarker + | otherwise = AbsCNop -- 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 -> StgRhs -> FCode (Id, CgIdInfo) +cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo) -- the Id is passed along for setting up a binding... -cgTopRhs bndr (StgRhsCon cc con args) - = forkStatics (cgTopRhsCon bndr con args) +cgTopRhs bndr (StgRhsCon cc con args) srt + = maybeGlobaliseId bndr `thenFC` \ bndr' -> + forkStatics (cgTopRhsCon bndr con args) -cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body) - = ASSERT(null fvs) -- There should be no free variables - getSRTLabel `thenFC` \srt_label -> - let lf_info = - mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt +cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt + = -- There should be no free variables + ASSERT(null fvs) + let + lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args in - forkStatics (cgTopRhsClosure bndr cc bi args body lf_info) + maybeGlobaliseId bndr `thenFC` \ bndr' -> + forkStatics (cgTopRhsClosure bndr' cc bi srt args body lf_info) \end{code}