X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcodeGen%2FCgClosure.lhs;h=7bf9f078041b6cd2f1b2bd9f83386a9e545af5a6;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hp=99290d21424e2d2c4e71a7f35f514ee7e93039ad;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 99290d2..7bf9f07 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -9,6 +9,13 @@ with {\em closures} on the RHSs of let(rec)s. See also @CgCon@, which deals with constructors. \begin{code} +{-# OPTIONS_GHC -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- for details + module CgClosure ( cgTopRhsClosure, cgStdRhsClosure, cgRhsClosure, @@ -36,7 +43,6 @@ import Cmm import CmmUtils import CLabel import StgSyn -import StaticFlags import CostCentre import Id import Name @@ -47,6 +53,8 @@ import BasicTypes import Constants import Outputable import FastString + +import Data.List \end{code} %******************************************************** @@ -62,17 +70,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 +144,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 +168,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 +184,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 +250,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 +414,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 +471,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 +499,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 +560,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