import StgCmmExpr
import StgCmmMonad
-import StgCmmExpr
import StgCmmEnv
import StgCmmCon
import StgCmmHeap
import StgSyn
import CostCentre
import Id
-import Monad (foldM, liftM)
+import Control.Monad
import Name
import Module
import ListSetOps
import FastString
import Maybes
-import Data.List
-
------------------------------------------------------------------------
-- Top-level bindings
------------------------------------------------------------------------
; 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
-- 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 $ 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
-----------------------------------------
; granThunk node_points
-- Heap overflow check
- ; entryHeapCheck node arity [] $ 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