X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCodeGen.lhs;h=bf6177df7fac7bcaaed5cad97f9cad2d34dfb78f;hb=2a8d65fe6bc8873af2aae4783a885b3e3ad1c1f4;hp=90bc8f94a1296a74f3e2792cebc57e0cf8a9c2b0;hpb=243dedb8741d13162fe944ebf2adace921e0108d;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 90bc8f9..bf6177d 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -19,6 +19,11 @@ 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 @@ -26,7 +31,7 @@ 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 ) @@ -34,20 +39,24 @@ import ClosureInfo ( mkClosureLFInfo ) import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn, opt_EnsureSplittableC ) import CostCentre ( CostCentre, CostCentreStack ) -import Id ( Id, idName ) +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_dyn ) +import ErrUtils ( dumpIfSet_dyn, showPass ) import Panic ( assertPanic ) + +#ifdef DEBUG +import Id ( idCafInfo ) +import IdInfo ( mayHaveCafRefs ) +import Outputable +#endif \end{code} \begin{code} - - codeGen :: DynFlags -> Module -- Module name -> [Module] -- Import names @@ -55,40 +64,37 @@ codeGen :: DynFlags [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 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] + 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_dyn dflags 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 + data_tycons = filter isDataTyCon tycons - maybe_split = if opt_EnsureSplittableC - then CSplitMarker - else AbsCNop cinfo = MkCompInfo mod_name \end{code} @@ -170,7 +176,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. @@ -181,37 +187,70 @@ 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 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 `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 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 ) pairs' + ) `thenFC` \ new_binds -> nopC ) + +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 - srt_label = mkSRTLabel (idName name) + -- 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 + = moduleName `thenFC` \ mod -> + let + name = idName id + + -- globalise the name for -split-objs, if necessary + real_name | opt_EnsureSplittableC = globaliseName name mod + | otherwise = name -mkSRT :: CLabel -> [Id] -> AbstractC -mkSRT lbl [] = AbsCNop -mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids) + id' = setIdName id real_name + in + 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 @@ -221,13 +260,19 @@ cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) -- the Id is passed along for setting up a binding... cgTopRhs bndr (StgRhsCon cc con args) - = forkStatics (cgTopRhsCon bndr con args) + = 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 + = -- There should be no free variables + ASSERT(null fvs) + -- If the closure is a thunk, then the binder must be recorded as such. + ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr) + 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) + maybeGlobaliseId bndr `thenFC` \ bndr' -> + forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info) \end{code}