X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgClosure.lhs;h=86e13ab38342543fb0c3d49f7ab4de75aa10f1a5;hb=19b0b165a24606dbdb1f4dd7728da7346845a5a0;hp=99290d21424e2d2c4e71a7f35f514ee7e93039ad;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 99290d2..86e13ab 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -36,7 +36,6 @@ import Cmm import CmmUtils import CLabel import StgSyn -import StaticFlags import CostCentre import Id import Name @@ -47,6 +46,8 @@ import BasicTypes import Constants import Outputable import FastString + +import Data.List \end{code} %******************************************************** @@ -62,17 +63,16 @@ 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 @@ -137,14 +137,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 +161,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 +177,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 @@ -237,7 +243,7 @@ NB: Thunks cannot have a primitive type! 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 @@ -401,8 +407,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 @@ -447,12 +464,12 @@ emitBlackHoleCode is_single_entry -- Profiling needs slop filling (to support LDV profiling), so -- currently eager blackholing doesn't work with profiling. -- - -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of - -- single-entry thunks. - eager_blackholing - | opt_DoTickyProfiling = True - | otherwise = False + -- Previously, eager blackholing was enabled when ticky-ticky + -- was on. But it didn't work, and it wasn't strictly necessary + -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING + -- is unconditionally disabled. -- krc 1/2007 + eager_blackholing = False \end{code} \begin{code} @@ -475,17 +492,9 @@ setupUpdate closure_info code ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf closure_info True - ; pushUpdateFrame upd_closure code } + ; pushUpdateFrame upd_closure code } else do - { -- No update reqd, you'd think we don't need to - -- black-hole it. But when ticky-ticky is on, we - -- black-hole it regardless, to catch errors in which - -- an allegedly single-entry closure is entered twice - -- - -- We discard the pointer returned by link_caf, because - -- we don't push an update frame - whenC opt_DoTickyProfiling -- Blackhole even a SE CAF - (link_caf closure_info False >> nopC) + { -- krc: removed some ticky-related code here. ; tickyUpdateFrameOmitted ; code } } @@ -544,7 +553,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") [(CmmReg nodeReg,PtrHint)] [node] False -- node is live, so save it. -- Overwrite the closure with a (static) indirection