X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCodeGen.lhs;h=e8d83a5a43bf51e1fadb2414a3bb962a28ec012b;hb=554959511db7fd80b6da073abcfceb2392902054;hp=1aa48656f56b7ba8fbccd33f402c6dbd22825652;hpb=644e072887cab9146bf68b99092dd3ec27bc757d;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 1aa4865..e8d83a5 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -29,7 +29,7 @@ import CgBindery ( CgIdInfo, addBindC, addBindsC, getCgIdInfo, cgIdInfoId ) import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon, cgTyCon ) -import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall ) +import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord ) import CLabel import Cmm @@ -39,6 +39,7 @@ import MachOp ( wordRep, MachHint(..) ) import StgSyn import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER ) +import Packages ( HomeModules ) import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_SccProfilingOn ) @@ -59,6 +60,7 @@ import Outputable \begin{code} codeGen :: DynFlags + -> HomeModules -> Module -> [TyCon] -> ForeignStubs @@ -67,21 +69,21 @@ codeGen :: DynFlags -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> IO [Cmm] -- Output -codeGen dflags this_mod data_tycons foreign_stubs imported_mods +codeGen dflags hmods this_mod data_tycons foreign_stubs imported_mods cost_centre_info stg_binds = do { showPass dflags "CodeGen" ; let way = buildTag dflags - mb_main_mod = mainModIs dflags + main_mod = mainModIs dflags -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons - ; code_stuff <- initC dflags this_mod $ do - { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds + ; code_stuff <- initC dflags hmods this_mod $ do + { cmm_binds <- mapM (getCmm . cgTopBinding dflags hmods) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info - this_mod mb_main_mod + ; cmm_init <- getCmm (mkModuleInit dflags hmods way cost_centre_info + this_mod main_mod foreign_stubs imported_mods) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) } @@ -141,14 +143,15 @@ We initialise the module tree by keeping a work-stack, \begin{code} mkModuleInit :: DynFlags + -> HomeModules -> String -- the "way" -> CollectedCCs -- cost centre info -> Module - -> Maybe String -- Just m ==> we have flag: -main-is Foo.baz + -> Module -- name of the Main module -> ForeignStubs -> [Module] -> Code -mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods +mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs imported_mods = do { if opt_SccProfilingOn then do { -- Allocate the static boolean that records if this @@ -181,18 +184,14 @@ mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs impo (emitSimpleProc plain_main_init_lbl jump_to_init) } where - plain_init_lbl = mkPlainModuleInitLabel dflags this_mod - real_init_lbl = mkModuleInitLabel dflags this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel dflags rOOT_MAIN + plain_init_lbl = mkPlainModuleInitLabel hmods this_mod + real_init_lbl = mkModuleInitLabel hmods this_mod way + plain_main_init_lbl = mkPlainModuleInitLabel hmods rOOT_MAIN jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep - main_mod = case mb_main_mod of - Just mod_name -> mkModule mod_name - Nothing -> mAIN - -- Main refers to GHC.TopHandler.runIO, so make sure we call the -- init function for GHC.TopHandler. extra_imported_mods @@ -205,7 +204,7 @@ mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs impo -- Now do local stuff ; initCostCentres cost_centre_info - ; mapCs (registerModuleImport dflags way) + ; mapCs (registerModuleImport hmods way) (imported_mods++extra_imported_mods) } @@ -215,13 +214,13 @@ mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs impo , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ] ----------------------- -registerModuleImport :: DynFlags -> String -> Module -> Code -registerModuleImport dflags way mod +registerModuleImport :: HomeModules -> String -> Module -> Code +registerModuleImport hmods way mod | mod == gHC_PRIM = nopC | otherwise -- Push the init procedure onto the work stack = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1)) - , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel dflags mod way)) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel hmods mod way)) ] \end{code} @@ -262,32 +261,32 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code -cgTopBinding dflags (StgNonRec id rhs, srts) +cgTopBinding :: DynFlags -> HomeModules -> (StgBinding,[(Id,[Id])]) -> Code +cgTopBinding dflags hmods (StgNonRec id rhs, srts) = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT dflags [id']) srts + ; mapM_ (mkSRT hmods [id']) srts ; (id,info) <- cgTopRhs id' rhs ; addBindC id info -- Add the *un-externalised* Id to the envt, -- so we find it when we look up occurrences } -cgTopBinding dflags (StgRec pairs, srts) +cgTopBinding dflags hmods (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT dflags bndrs') srts + ; mapM_ (mkSRT hmods bndrs') srts ; _new_binds <- fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; nopC } -mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code -mkSRT dflags these (id,[]) = nopC -mkSRT dflags these (id,ids) +mkSRT :: HomeModules -> [Id] -> (Id,[Id]) -> Code +mkSRT hmods these (id,[]) = nopC +mkSRT hmods these (id,ids) = do { ids <- mapFCs remap ids ; id <- remap id ; emitRODataLits (mkSRTLabel (idName id)) - (map (CmmLabel . mkClosureLabel dflags . idName) ids) + (map (CmmLabel . mkClosureLabel hmods . idName) ids) } where -- Sigh, better map all the ids against the environment in