X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmm.hs;h=2bfe1876baf85c7e06b6ae9a8021e6978d663263;hb=5cd39aa33f970ff42e22b1c9c73502e4229dc488;hp=56cd1d5555b215b50fc73b1da61c0280b4866e13;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69;p=ghc-hetmet.git diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 56cd1d5..2bfe187 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -23,16 +23,14 @@ import StgCmmClosure import StgCmmHpc import StgCmmTicky -import MkZipCfgCmm -import Cmm -import CmmUtils +import MkGraph +import CmmExpr +import CmmDecl import CLabel import PprCmm import StgSyn -import PrelNames import DynFlags -import StaticFlags import HscTypes import CostCentre @@ -41,7 +39,6 @@ import IdInfo import Type import DataCon import Name -import OccName import TyCon import Module import ErrUtils @@ -50,17 +47,14 @@ import Outputable codeGen :: DynFlags -> Module -> [TyCon] - -> [Module] -- Directly-imported modules - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo - -> IO [CmmZ] -- Output + -> IO [Cmm] -- Output -codeGen dflags this_mod data_tycons imported_mods +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { showPass dflags "New CodeGen" - ; let way = buildTag dflags - main_mod = mainModIs dflags -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons @@ -68,10 +62,9 @@ codeGen dflags this_mod data_tycons imported_mods ; code_stuff <- initC dflags this_mod $ do { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit way cost_centre_info - this_mod main_mod - imported_mods hpc_info) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + ; cmm_init <- getCmm (mkModuleInit cost_centre_info + this_mod hpc_info) + ; return (cmm_init : cmm_binds ++ concat cmm_tycons) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to @@ -82,6 +75,12 @@ codeGen dflags this_mod data_tycons imported_mods -- possible for object splitting to split up the -- pieces later. + -- Note [codegen-split-init] the cmm_init block must + -- come FIRST. This is because when -split-objs is on + -- we need to combine this block with its + -- initialisation routines; see Note + -- [pipeline-split-init]. + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) ; return code_stuff } @@ -104,43 +103,25 @@ variable. -} cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode () cgTopBinding dflags (StgNonRec id rhs, _srts) = do { id' <- maybeExternaliseId dflags id - --; mapM_ (mkSRT [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 + ; info <- cgTopRhs id' rhs + ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs, _srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - --; mapM_ (mkSRT bndrs') srts - ; fixC (\ new_binds -> do + ; fixC_(\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; return () } ---mkSRT :: [Id] -> (Id,[Id]) -> FCode () ---mkSRT these (id,ids) --- | null ids = nopC --- | otherwise --- = do { ids <- mapFCs remap ids --- ; id <- remap id --- ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id)) --- (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids) --- } --- where --- -- Sigh, better map all the ids against the environment in --- -- case they've been externalised (see maybeExternaliseId below). --- remap id = case filter (==id) these of --- (id':_) -> returnFC id' --- [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) } - -- 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 -> FCode CgIdInfo -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary @@ -153,7 +134,6 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body) - --------------------------------------------------------------- -- Module initialisation code --------------------------------------------------------------- @@ -192,91 +172,18 @@ We initialise the module tree by keeping a work-stack, -} mkModuleInit - :: String -- the "way" - -> CollectedCCs -- cost centre info + :: CollectedCCs -- cost centre info -> Module - -> Module -- name of the Main module - -> [Module] - -> HpcInfo + -> HpcInfo -> FCode () -mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info - = do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] - - ; init_hpc <- initHpc this_mod hpc_info - ; init_prof <- initCostCentres cost_centre_info - - -- We emit a recursive descent module search for all modules - -- and *choose* to chase it in :Main, below. - -- In this way, Hpc enabled modules can interact seamlessly with - -- not Hpc enabled moduled, provided Main is compiled with Hpc. - - ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs - [ check_already_done retId - , init_prof - , init_hpc - , catAGraphs $ map (registerImport way) all_imported_mods - , mkBranch retId ] - -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl jump_to_init - - -- When compiling the module in which the 'main' function lives, - -- (that is, this_mod == main_mod) - -- we inject an extra stg_init procedure for stg_init_ZCMain, for the - -- RTS to invoke. We must consult the -main-is flag in case the - -- user specified a different function to Main.main - - -- Notice that the recursive descent is optional, depending on what options - -- are enabled. - - - ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl rec_descent_init) - } - where - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - - jump_to_init = mkJump (mkLblExpr real_init_lbl) [] - - - -- Main refers to GHC.TopHandler.runIO, so make sure we call the - -- init function for GHC.TopHandler. - extra_imported_mods - | this_mod == main_mod = [gHC_TOP_HANDLER] - | otherwise = [] - all_imported_mods = imported_mods ++ extra_imported_mods - - mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - check_already_done retId - = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId Nothing <*> mkReturn []) mkNop - <*> -- Set mod_reg to 1 to record that we've been here - mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)) - - -- The return-code pops the work stack by - -- incrementing Sp, and then jumpd to the popped item - ret_code = mkAssign spReg (cmmRegOffW spReg 1) - <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] - - rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init - else ret_code - ------------------------ -registerImport :: String -> Module -> CmmAGraph -registerImport way mod - | mod == gHC_PRIM - = mkNop - | otherwise -- Push the init procedure onto the work stack - = mkCmmCall init_lbl [] [] NoC_SRT - where - init_lbl = mkLblExpr $ mkModuleInitLabel mod way - +mkModuleInit cost_centre_info this_mod hpc_info + = do { initHpc this_mod hpc_info + ; initCostCentres cost_centre_info + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + } --------------------------------------------------------------- -- Generating static stuff for algebraic data types @@ -309,7 +216,7 @@ For charlike and intlike closures there is a fixed array of static closures predeclared. -} -cgTyCon :: TyCon -> FCode [CmmZ] -- All constructors merged together +cgTyCon :: TyCon -> FCode [Cmm] -- All constructors merged together cgTyCon tycon = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) @@ -326,7 +233,7 @@ cgTyCon tycon ; return (extra ++ constrs) } -cgEnumerationTyCon :: TyCon -> FCode [CmmZ] +cgEnumerationTyCon :: TyCon -> FCode [Cmm] cgEnumerationTyCon tycon | isEnumerationTyCon tycon = do { tbl <- getCmm $ @@ -351,12 +258,12 @@ cgDataCon data_con (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps emit_info cl_info ticky_code - = do { code_blks <- getCode (mk_code ticky_code) - ; emitClosureCodeAndInfoTable cl_info [] code_blks } + = emitClosureAndInfoTable cl_info NativeDirectCall [] + $ mk_code ticky_code mk_code ticky_code = -- NB: We don't set CC when entering data (WDP 94/06) - do { ticky_code + do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) ; emitReturn [cmmOffsetB (CmmReg nodeReg)