X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmm.hs;h=26ace0780f56a494482c106c3e0044a4d72ea9a5;hp=56cd1d5555b215b50fc73b1da61c0280b4866e13;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 56cd1d5..26ace07 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -23,8 +23,9 @@ import StgCmmClosure import StgCmmHpc import StgCmmTicky -import MkZipCfgCmm -import Cmm +import MkGraph +import CmmDecl +import CmmExpr import CmmUtils import CLabel import PprCmm @@ -41,7 +42,6 @@ import IdInfo import Type import DataCon import Name -import OccName import TyCon import Module import ErrUtils @@ -54,7 +54,7 @@ codeGen :: DynFlags -> 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 cost_centre_info stg_binds hpc_info @@ -104,43 +104,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 +135,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 --------------------------------------------------------------- @@ -213,14 +194,17 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info -- 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 + ; updfr_sz <- getUpdFrameOff + ; tail <- getCode (pushUpdateFrame imports + (do updfr_sz' <- getUpdFrameOff + emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz'))) + ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs + [ check_already_done retId updfr_sz , init_prof , init_hpc - , catAGraphs $ map (registerImport way) all_imported_mods - , mkBranch retId ] + , tail]) -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl jump_to_init + ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz) -- When compiling the module in which the 'main' function lives, -- (that is, this_mod == main_mod) @@ -233,14 +217,14 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl rec_descent_init) + (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz)) } 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) [] + jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz -- Main refers to GHC.TopHandler.runIO, so make sure we call the @@ -249,34 +233,29 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info | this_mod == main_mod = [gHC_TOP_HANDLER] | otherwise = [] all_imported_mods = imported_mods ++ extra_imported_mods + imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way)) + (filter (gHC_PRIM /=) all_imported_mods) mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - check_already_done retId + check_already_done retId updfr_sz = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId Nothing <*> mkReturn []) mkNop + (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) 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 + -- incrementing Sp, and then jumps to the popped item + ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord + ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz) + -- mkAssign spReg (cmmRegOffW spReg 1) <*> + -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz + pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord) + rec_descent_init updfr_sz = + if opt_SccProfilingOn || isHpcUsed hpc_info + then jump_to_init updfr_sz + else ret_code updfr_sz --------------------------------------------------------------- -- Generating static stuff for algebraic data types @@ -309,7 +288,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 +305,7 @@ cgTyCon tycon ; return (extra ++ constrs) } -cgEnumerationTyCon :: TyCon -> FCode [CmmZ] +cgEnumerationTyCon :: TyCon -> FCode [Cmm] cgEnumerationTyCon tycon | isEnumerationTyCon tycon = do { tbl <- getCmm $ @@ -351,12 +330,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)