X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCodeGen.lhs;h=e8d83a5a43bf51e1fadb2414a3bb962a28ec012b;hb=db18148d1a62abc745da955530d7f46a6f1e9f36;hp=abe78f4fe659be7ee7d647514d568e7849de71bf;hpb=91944423d83620441d6d3b120654a10fb41cfb3c;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index abe78f4..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,29 +69,23 @@ 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 - ++ if opt_SccProfilingOn -#if defined(mingw32_HOST_OS) - || True -#endif - then [cmm_init] - else []) + ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to @@ -147,36 +143,34 @@ 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 { - - -- Allocate the static boolean that records if this - -- module has been registered already - ; emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] - - ; emitSimpleProc real_init_lbl $ do - { -- The return-code pops the work stack by - -- incrementing Sp, and then jumpd to the popped item - ret_blk <- forkLabelledCode $ stmtsC - [ CmmAssign spReg (cmmRegOffW spReg 1) - , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ] - - ; init_blk <- forkLabelledCode $ do - { mod_init_code; stmtC (CmmBranch ret_blk) } - - ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - ret_blk) - ; stmtC (CmmBranch init_blk) - } - + if opt_SccProfilingOn + then do { -- Allocate the static boolean that records if this + -- module has been registered already + emitData Data [CmmDataLabel moduleRegdLabel, + CmmStaticLit zeroCLit] + + ; emitSimpleProc real_init_lbl $ do + { ret_blk <- forkLabelledCode ret_code + + ; init_blk <- forkLabelledCode $ do + { mod_init_code; stmtC (CmmBranch ret_blk) } + + ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val) + ret_blk) + ; stmtC (CmmBranch init_blk) + } + } + else emitSimpleProc real_init_lbl ret_code -- Make the "plain" procedure jump to the "real" init procedure ; emitSimpleProc plain_init_lbl jump_to_init @@ -190,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 @@ -213,35 +203,24 @@ mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs impo stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))) -- Now do local stuff -#if defined(mingw32_HOST_OS) - ; registerForeignExports foreign_stubs -#endif ; initCostCentres cost_centre_info - ; mapCs (registerModuleImport dflags way) + ; mapCs (registerModuleImport hmods way) (imported_mods++extra_imported_mods) } + -- The return-code pops the work stack by + -- incrementing Sp, and then jumpd to the popped item + ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1) + , 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)) ] - ------------------------ -registerForeignExports :: ForeignStubs -> Code -registerForeignExports NoStubs - = nopC -registerForeignExports (ForeignStubs _ _ _ fe_bndrs) - = mapM_ mk_export_register fe_bndrs - where - mk_export_register bndr - = emitRtsCall SLIT("getStablePtr") - [ (CmmLit (CmmLabel (mkLocalClosureLabel (idName bndr))), - PtrHint) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel hmods mod way)) ] \end{code} @@ -282,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