X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmBind.hs;h=64d3ef1794fa62abe1a59bb4599409c34d37c3c1;hp=04676787fec6d365a766868a296da69899d66491;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0467678..64d3ef1 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -17,7 +17,6 @@ module StgCmmBind ( import StgCmmExpr import StgCmmMonad -import StgCmmExpr import StgCmmEnv import StgCmmCon import StgCmmHeap @@ -48,8 +47,6 @@ import Outputable import FastString import Maybes -import Data.List - ------------------------------------------------------------------------ -- Top-level bindings ------------------------------------------------------------------------ @@ -84,11 +81,10 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) (addIdReps []) -- Don't drop the non-void args until the closure info has been made - ; forkClosureBody (closureCodeBody True id closure_info ccs srt_info + ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) - ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $ - returnFC cg_id_info } + ; returnFC cg_id_info } ------------------------------------------------------------------------ -- Non-top-level bindings @@ -154,8 +150,7 @@ cgRhs name (StgRhsCon maybe_cc con args) = buildDynCon name maybe_cc con args cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = pprTrace "cgRhs closure" (ppr name <+> ppr args) $ - mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body + = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body ------------------------------------------------------------------------ -- Non-constructor right hand sides @@ -293,7 +288,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere -- (b) ignore Sequel from context; use empty Sequel -- And compile the body - closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args) + closureCodeBody False bndr closure_info cc (nonVoidIds args) (length args) body fv_details -- BUILD THE OBJECT @@ -361,7 +356,6 @@ closureCodeBody :: Bool -- whether this is a top-level binding -> Id -- the closure's name -> ClosureInfo -- Lots of information about this closure -> CostCentreStack -- Optional cost centre attached to closure - -> C_SRT -> [NonVoid Id] -- incoming args to the closure -> Int -- arity, including void args -> StgExpr @@ -381,12 +375,12 @@ closureCodeBody :: Bool -- whether this is a top-level binding argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL -} -closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details +closureCodeBody top_lvl bndr cl_info cc args arity body fv_details | length args == 0 -- No args i.e. thunk = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $ - (\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body) + (\ (node, _) -> thunkCode cl_info fv_details cc node arity body) -closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details +closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = ASSERT( length args > 0 ) do { -- Allocate the global ticky counter, -- and establish the ticky-counter @@ -397,21 +391,22 @@ closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details -- Emit the main entry code ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do - -- Emit the slow-entry code (for entering a closure through a PAP) - { mkSlowEntryCode cl_info arg_regs - - ; let lf_info = closureLFInfo cl_info - node_points = nodeMustPointToIt lf_info - ; tickyEnterFun cl_info - ; whenC node_points (ldvEnterClosure cl_info) - ; granYield arg_regs node_points - - -- Main payload - ; entryHeapCheck node arity arg_regs srt $ do - { enterCostCentre cl_info cc body + -- Emit the slow-entry code (for entering a closure through a PAP) + { mkSlowEntryCode cl_info arg_regs + + ; let lf_info = closureLFInfo cl_info + node_points = nodeMustPointToIt lf_info + ; tickyEnterFun cl_info + ; whenC node_points (ldvEnterClosure cl_info) + ; granYield arg_regs node_points + + -- Main payload + ; entryHeapCheck (if node_points then Just node else Nothing) arity arg_regs $ do + { enterCostCentre cl_info cc body ; fv_bindings <- mapM bind_fv fv_details - ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after* - ; cgExpr body }} -- heap check, to reduce live vars over check + -- Load free vars out of closure *after* + ; if node_points then load_fvs node lf_info fv_bindings else return () + ; cgExpr body }} -- heap check, to reduce live vars over check } @@ -422,7 +417,7 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode () load_fvs node lf_info = mapCs (\ (reg, off) -> - pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag) + emit $ mkTaggedObjectLoad reg node off tag) where tag = lfDynTag lf_info ----------------------------------------- @@ -454,18 +449,19 @@ mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" ----------------------------------------- thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack -> - C_SRT -> LocalReg -> Int -> StgExpr -> FCode () -thunkCode cl_info fv_details cc srt node arity body + LocalReg -> Int -> StgExpr -> FCode () +thunkCode cl_info fv_details cc node arity body = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info) ; tickyEnterThunk cl_info ; ldvEnterClosure cl_info -- NB: Node always points when profiling ; granThunk node_points -- Heap overflow check - ; entryHeapCheck node arity [] srt $ do + ; entryHeapCheck (if node_points then Just node else Nothing) arity [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check - whenC (blackHoleOnEntry cl_info && node_points) + dflags <- getDynFlags + ; whenC (blackHoleOnEntry dflags cl_info && node_points) (blackHoleIt cl_info) -- Push update frame @@ -598,7 +594,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 @@ -620,8 +616,7 @@ link_caf cl_info is_upd = do ; return 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