import StgCmmExpr
import StgCmmMonad
-import StgCmmExpr
import StgCmmEnv
import StgCmmCon
import StgCmmHeap
import FastString
import Maybes
-import Data.List
-
------------------------------------------------------------------------
-- Top-level bindings
------------------------------------------------------------------------
(_, _, 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
= 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
-- 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
-> 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
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
-- 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
}
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
-----------------------------------------
-----------------------------------------
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
-- 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
; 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
projects / ghc-hetmet.git / blobdiff