X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgClosure.lhs;h=18879a3756cd7d573e3c7383d92d838f63cd2845;hp=8337f916fe46f6aba7451a10f6b1044d2bb5c438;hb=0d4d93a38a2aff950bcd12ebb46a2582d68f5de4;hpb=5ddee764beb312933256096d03df7c3ec47ac452 diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 8337f91..18879a3 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -31,12 +31,10 @@ import CgCallConv import CgUtils import ClosureInfo import SMRep -import MachOp import Cmm import CmmUtils import CLabel import StgSyn -import StaticFlags import CostCentre import Id import Name @@ -44,9 +42,13 @@ import Module import ListSetOps import Util import BasicTypes +import StaticFlags +import DynFlags import Constants import Outputable import FastString + +import Data.List \end{code} %******************************************************** @@ -62,21 +64,20 @@ They should have no free variables. cgTopRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo - -> SRT -> UpdateFlag -> [Id] -- Args -> StgExpr -> FCode (Id, CgIdInfo) -cgTopRhsClosure id ccs binder_info srt upd_flag args body = do +cgTopRhsClosure id ccs binder_info upd_flag args body = do { -- LAY OUT THE OBJECT let name = idName id ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args - ; srt_info <- getSRTInfo name srt + ; srt_info <- getSRTInfo ; mod_name <- getModuleName ; let descr = closureDescription mod_name name closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr - closure_label = mkLocalClosureLabel name + closure_label = mkLocalClosureLabel name $ idCafInfo id cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info closure_rep = mkStaticClosureFields closure_info ccs True [] @@ -108,7 +109,7 @@ cgStdRhsClosure -> [StgArg] -- payload -> FCode (Id, CgIdInfo) -cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload +cgStdRhsClosure bndr cc _bndr_info _fvs args body lf_info payload = do -- AHA! A STANDARD-FORM THUNK { -- LAY OUT THE OBJECT amodes <- getArgAmodes payload @@ -137,14 +138,13 @@ Here's the general case. cgRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo - -> SRT -> [Id] -- Free vars -> UpdateFlag -> [Id] -- Args -> StgExpr -> FCode (Id, CgIdInfo) -cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do +cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store -- it in the closure. Instead, just bind it to Node on entry. @@ -162,7 +162,7 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args ; fv_infos <- mapFCs getCgIdInfo reduced_fvs - ; srt_info <- getSRTInfo name srt + ; srt_info <- getSRTInfo ; mod_name <- getModuleName ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] (tot_wds, ptr_wds, bind_details) @@ -178,7 +178,14 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do -- BUILD ITS INFO TABLE AND CODE ; forkClosureBody (do { -- Bind the fvs - let bind_fv (info, offset) + let + -- A function closure pointer may be tagged, so we + -- must take it into account when accessing the free variables. + mbtag = tagForArity (length args) + bind_fv (info, offset) + | Just tag <- mbtag + = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag + | otherwise = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info) ; mapCs bind_fv bind_details @@ -234,16 +241,17 @@ So it should set up an update frame (if it is shared). NB: Thunks cannot have a primitive type! \begin{code} -closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do +closureCodeBody _binder_info cl_info cc [{- No args i.e. thunk -}] body = do { body_absC <- getCgStmts $ do { tickyEnterThunk cl_info - ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling + ; ldvEnterClosure cl_info -- NB: Node always points when profiling ; thunkWrapper cl_info $ do -- We only enter cc after setting up update so -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc { enterCostCentre cl_info cc body + ; stmtsC [CmmComment $ mkFastString $ showSDoc $ ppr body] ; cgExpr body } } @@ -258,7 +266,7 @@ argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL \begin{code} -closureCodeBody binder_info cl_info cc args body +closureCodeBody _binder_info cl_info cc args body = ASSERT( length args > 0 ) do { -- Get the current virtual Sp (it might not be zero, -- eg. if we're compiling a let-no-escape). @@ -267,7 +275,7 @@ closureCodeBody binder_info cl_info cc args body (sp_top, stk_args) = mkVirtStkOffsets vSp other_args -- Allocate the global ticky counter - ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) + ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info) ; emitTickyCounter cl_info args sp_top -- ...and establish the ticky-counter @@ -340,7 +348,8 @@ mkSlowEntryCode cl_info reg_args | otherwise = return noStmts where name = closureName cl_info - slow_lbl = mkSlowEntryLabel name + has_caf_refs = clHasCafRefs cl_info + slow_lbl = mkSlowEntryLabel name has_caf_refs load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry] save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts @@ -357,13 +366,13 @@ mkSlowEntryCode cl_info reg_args (argMachRep rep)) save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets - mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg ) + mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg ) CmmStore (cmmRegOffW spReg offset) (CmmReg (CmmGlobal reg)) stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) - jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) [] + jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) [] \end{code} @@ -401,8 +410,19 @@ funWrapper :: ClosureInfo -- Closure whose code body this is funWrapper closure_info arg_regs reg_save_code fun_body = do { let node_points = nodeMustPointToIt (closureLFInfo closure_info) + {- + -- Debugging: check that R1 has the correct tag + ; let tag = funTag closure_info + ; whenC (tag /= 0 && node_points) $ do + l <- newLabelC + stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg), + CmmLit (mkIntCLit tag)]) l) + stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0))) + labelC l + -} + -- Enter for Ldv profiling - ; whenC node_points (ldvEnter (CmmReg nodeReg)) + ; whenC node_points (ldvEnterClosure closure_info) -- GranSim yeild poin ; granYield arg_regs node_points @@ -428,15 +448,9 @@ blackHoleIt :: ClosureInfo -> Code blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) emitBlackHoleCode :: Bool -> Code -emitBlackHoleCode is_single_entry - | eager_blackholing = do - tickyBlackHole (not is_single_entry) - stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl))) - | otherwise = - nopC - where - bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info") - | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info") +emitBlackHoleCode is_single_entry = do + + dflags <- getDynFlags -- If we wanted to do eager blackholing with slop filling, -- we'd need to do it at the *end* of a basic block, otherwise @@ -452,7 +466,16 @@ emitBlackHoleCode is_single_entry -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING -- is unconditionally disabled. -- krc 1/2007 - eager_blackholing = False + let eager_blackholing = not opt_SccProfilingOn + && dopt Opt_EagerBlackHoling dflags + + if eager_blackholing + then do + tickyBlackHole (not is_single_entry) + let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo) + stmtC (CmmStore (CmmReg nodeReg) bh_info) + else + nopC \end{code} \begin{code} @@ -525,7 +548,7 @@ link_caf :: ClosureInfo -- updated with the new value when available. The reason for all of this -- is that we only want to update dynamic heap objects, not static ones, -- so that generational GC is easier. -link_caf cl_info is_upd = do +link_caf cl_info _is_upd = do { -- Alloc black hole specifying CC_HDR(Node) as the cost centre ; let use_cc = costCentreFrom (CmmReg nodeReg) blame_cc = use_cc @@ -536,7 +559,7 @@ link_caf cl_info is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] + ; emitRtsCallWithVols (sLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False -- node is live, so save it. -- Overwrite the closure with a (static) indirection @@ -547,8 +570,7 @@ link_caf cl_info is_upd = do ; returnFC hp_rel } where bh_cl_info :: ClosureInfo - bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info - | otherwise = seCafBlackHoleClosureInfo cl_info + bh_cl_info = cafBlackHoleClosureInfo cl_info ind_static_info :: CmmExpr ind_static_info = mkLblExpr mkIndStaticInfoLabel