--
-----------------------------------------------------------------------------
-module StgCmmBind (
- cgTopRhsClosure,
+module StgCmmBind (
+ cgTopRhsClosure,
cgBind,
- emitBlackHoleCode
+ emitBlackHoleCode,
+ pushUpdateFrame
) where
#include "HsVersions.h"
-import StgCmmMonad
import StgCmmExpr
+import StgCmmMonad
import StgCmmEnv
import StgCmmCon
import StgCmmHeap
import StgCmmLayout
import StgCmmUtils
import StgCmmClosure
+import StgCmmForeign (emitPrimCall)
-import MkZipCfgCmm
+import MkGraph
import CoreSyn ( AltCon(..) )
import SMRep
-import Cmm
+import CmmDecl
+import CmmExpr
import CmmUtils
import CLabel
import StgSyn
-import CostCentre
+import CostCentre
import Id
+import Control.Monad
import Name
import Module
import ListSetOps
import FastString
import Maybes
-import Data.List
-
------------------------------------------------------------------------
-- Top-level bindings
------------------------------------------------------------------------
-> StgBinderInfo
-> UpdateFlag
-> SRT
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr
- -> FCode (Id, CgIdInfo)
+ -> FCode CgIdInfo
-cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
+cgTopRhsClosure id ccs _ upd_flag srt args body = do
{ -- LAY OUT THE OBJECT
let name = idName id
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
- ; forkClosureBody $ do
- { node <- bindToReg id lf_info
- ; closureCodeBody binder_info closure_info
- ccs srt_info node args body }
+ ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
+ (_, _, 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
+ (nonVoidIds args) (length args) body fv_details)
- ; returnFC (id, cg_id_info) }
+ ; returnFC cg_id_info }
------------------------------------------------------------------------
-- Non-top-level bindings
cgBind :: StgBinding -> FCode ()
cgBind (StgNonRec name rhs)
- = do { (name, info) <- cgRhs name rhs
- ; addBindC name info }
+ = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
+ ; addBindC (cg_id info) info
+ ; emit (init <*> body) }
cgBind (StgRec pairs)
- = do { new_binds <- fixC (\ new_binds ->
- do { addBindsC new_binds
- ; listFCs [ cgRhs b e | (b,e) <- pairs ] })
- ; addBindsC new_binds }
+ = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
+ do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
+ ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
+ ; addBindsC new_binds
+ ; emit (catAGraphs inits <*> body) }
+
+{- Recursive let-bindings are tricky.
+ Consider the following pseudocode:
+ let x = \_ -> ... y ...
+ y = \_ -> ... z ...
+ z = \_ -> ... x ...
+ in ...
+ For each binding, we need to allocate a closure, and each closure must
+ capture the address of the other closures.
+ We want to generate the following C-- code:
+ // Initialization Code
+ x = hp - 24; // heap address of x's closure
+ y = hp - 40; // heap address of x's closure
+ z = hp - 64; // heap address of x's closure
+ // allocate and initialize x
+ m[hp-8] = ...
+ m[hp-16] = y // the closure for x captures y
+ m[hp-24] = x_info;
+ // allocate and initialize y
+ m[hp-32] = z; // the closure for y captures z
+ m[hp-40] = y_info;
+ // allocate and initialize z
+ ...
+
+ For each closure, we must generate not only the code to allocate and
+ initialize the closure itself, but also some Initialization Code that
+ sets a variable holding the closure pointer.
+ The complication here is that we don't know the heap offsets a priori,
+ which has two consequences:
+ 1. we need a fixpoint
+ 2. we can't trivially separate the Initialization Code from the
+ code that compiles the right-hand-sides
+
+ Note: We don't need this complication with let-no-escapes, because
+ in that case, the names are bound to labels in the environment,
+ and we don't need to emit any code to witness that binding.
+-}
--------------------
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
-- The Id is passed along so a binding can be set up
+ -- The returned values are the binding for the environment
+ -- and the Initialization Code that witnesses the binding
cgRhs name (StgRhsCon maybe_cc con args)
- = do { idinfo <- buildDynCon name maybe_cc con args
- ; return (name, idinfo) }
+ = buildDynCon name maybe_cc con args
cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
- = mkRhsClosure name cc bi fvs upd_flag srt args body
+ = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
------------------------------------------------------------------------
-- Non-constructor right hand sides
------------------------------------------------------------------------
mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
- -> [Id] -- Free vars
+ -> [NonVoid Id] -- Free vars
-> UpdateFlag -> SRT
- -> [Id] -- Args
+ -> [Id] -- Args
-> StgExpr
- -> FCode (Id, CgIdInfo)
+ -> FCode (CgIdInfo, CmmAGraph)
{- mkRhsClosure looks for two special forms of the right-hand side:
a) selector thunks
---------- Note [Selectors] ------------------
mkRhsClosure bndr cc bi
- [the_fv] -- Just one free var
+ [NonVoid the_fv] -- Just one free var
upd_flag -- Updatable thunk
_srt
[] -- A thunk
(isUpdatable upd_flag)
(_, params_w_offsets) = layOutDynConstr con (addIdReps params)
-- Just want the layout
- maybe_offset = assocMaybe params_w_offsets selectee
+ maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
body@(StgApp fun_id args)
| args `lengthIs` (arity-1)
- && all isFollowableArg (map idCgRep fvs)
+ && all isFollowableArg (map (idCgRep . stripNV) fvs)
&& isUpdatable upd_flag
- && arity <= mAX_SPEC_AP_SIZE
+ && arity <= mAX_SPEC_AP_SIZE
-- Ha! an Ap thunk
= cgStdThunk bndr cc bi body lf_info payload
arity = length fvs
---------- Default case ------------------
-mkRhsClosure bndr cc bi fvs upd_flag srt args body
+mkRhsClosure bndr cc _ fvs upd_flag srt 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.
-- NB we can be sure that Node will point to it, because we
- -- havn't told mkClosureLFInfo about this; so if the binder
+ -- haven't told mkClosureLFInfo about this; so if the binder
-- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-- stored in the closure itself, so it will make sure that
-- Node points to it...
; let
is_elem = isIn "cgRhsClosure"
- bndr_is_a_fv = bndr `is_elem` fvs
- reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+ bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
+ reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
| otherwise = fvs
-
+
-- MAKE CLOSURE INFO FOR THIS CLOSURE
; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
; mod_name <- getModuleName
; c_srt <- getSRTInfo srt
; let name = idName bndr
descr = closureDescription mod_name name
- fv_details :: [(Id, VirtualHpOffset)]
- (tot_wds, ptr_wds, fv_details)
- = mkVirtHeapOffsets (isLFThunk lf_info)
- (addIdReps reduced_fvs)
+ fv_details :: [(NonVoid Id, VirtualHpOffset)]
+ (tot_wds, ptr_wds, fv_details)
+ = mkVirtHeapOffsets (isLFThunk lf_info)
+ (addIdReps (map stripNV reduced_fvs))
closure_info = mkClosureInfo False -- Not static
bndr lf_info tot_wds ptr_wds
c_srt descr
-- BUILD ITS INFO TABLE AND CODE
- ; forkClosureBody $ do
- { -- Bind the binder itself
- -- It does no harm to have it in the envt even if
- -- it's not a free variable; and we need a reg for it
- node <- bindToReg bndr lf_info
-
- -- Bind the free variables
- ; mapCs (bind_fv node) fv_details
-
- -- And compile the body
- ; closureCodeBody bi closure_info cc c_srt node args body }
+ ; forkClosureBody $
+ -- 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 (nonVoidIds args)
+ (length args) body fv_details
-- BUILD THE OBJECT
; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
; emit (mkComment $ mkFastString "calling allocDynClosure")
- ; tmp <- allocDynClosure closure_info use_cc blame_cc
- (mapFst StgVarArg fv_details)
-
+ ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
+ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
+ (map toVarArg fv_details)
+
-- RETURN
- ; return (bndr, regIdInfo bndr lf_info tmp) }
- where
- -- A function closure pointer may be tagged, so we
- -- must take it into account when accessing the free variables.
- tag = tagForArity (length args)
+ ; regIdInfo bndr lf_info tmp init }
- bind_fv node (id, off)
- = do { reg <- rebindToReg id
- ; emit $ mkTaggedObjectLoad reg node off tag }
+-- Use with care; if used inappropriately, it could break invariants.
+stripNV :: NonVoid a -> a
+stripNV (NonVoid a) = a
-------------------------
cgStdThunk
-> StgExpr
-> LambdaFormInfo
-> [StgArg] -- payload
- -> FCode (Id, CgIdInfo)
+ -> FCode (CgIdInfo, CmmAGraph)
cgStdThunk bndr cc _bndr_info body lf_info payload
= do -- AHA! A STANDARD-FORM THUNK
{ -- LAY OUT THE OBJECT
mod_name <- getModuleName
- ; let (tot_wds, ptr_wds, payload_w_offsets)
+ ; let (tot_wds, ptr_wds, payload_w_offsets)
= mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
descr = closureDescription mod_name (idName bndr)
closure_info = mkClosureInfo False -- Not static
- bndr lf_info tot_wds ptr_wds
+ bndr lf_info tot_wds ptr_wds
NoC_SRT -- No SRT for a std-form closure
descr
; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
-- BUILD THE OBJECT
- ; tmp <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
+ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
-- RETURN
- ; returnFC (bndr, regIdInfo bndr lf_info tmp) }
+ ; regIdInfo bndr lf_info tmp init }
mkClosureLFInfo :: Id -- The binder
-> TopLevelFlag -- True of top level
- -> [Id] -- Free vars
+ -> [NonVoid Id] -- Free vars
-> UpdateFlag -- Update flag
- -> [Id] -- Args
+ -> [Id] -- Args
-> FCode LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args
- | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
+ | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
| otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
- ; return (mkLFReEntrant top fvs args arg_descr) }
+ ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
------------------------------------------------------------------------
-- The code for closures}
------------------------------------------------------------------------
-closureCodeBody :: StgBinderInfo -- XXX: unused?
+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
- -> LocalReg -- The closure itself; first argument
- -- The Id is in scope already, bound to this reg
- -> [Id]
+ -> [NonVoid Id] -- incoming args to the closure
+ -> Int -- arity, including void args
-> StgExpr
+ -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
-> FCode ()
-{- There are two main cases for the code for closures.
+{- There are two main cases for the code for closures.
* If there are *no arguments*, then the closure is a thunk, and not in
normal form. So it should set up an update frame (if it is
normal form, so there is no need to set up an update frame.
The Macros for GrAnSim are produced at the beginning of the
- argSatisfactionCheck (by calling fetchAndReschedule).
+ argSatisfactionCheck (by calling fetchAndReschedule).
There info if Node points to closure is available. -- HWL -}
-closureCodeBody _binder_info cl_info cc srt node args body
- | null args -- No args i.e. thunk
- = do { code <- getCode $ thunkCode cl_info cc srt node body
- ; emitClosureCodeAndInfoTable cl_info [node] code }
+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 node arity body
-closureCodeBody _binder_info cl_info cc srt node args body
+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
- -- label for this block
- let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
- ; emitTickyCounter cl_info args
- ; setTickyCtrLabel ticky_ctr_lbl $ do
-
--- -- XXX: no slow-entry code for now
--- -- Emit the slow-entry code
--- { reg_save_code <- mkSlowEntryCode cl_info reg_args
-
- -- Emit the main entry code
- ; let node_points = nodeMustPointToIt (closureLFInfo cl_info)
- ; arg_regs <- bindArgsToRegs args
- ; blks <- forkProc $ getCode $ do
- { enterCostCentre cl_info cc body
- ; tickyEnterFun cl_info
- ; whenC node_points (ldvEnterClosure cl_info)
- ; granYield arg_regs node_points
-
- -- Main payload
- ; entryHeapCheck node arg_regs srt $
- cgExpr body }
-
- ; emitClosureCodeAndInfoTable cl_info (node:arg_regs) blks
+ do { -- Allocate the global ticky counter,
+ -- and establish the ticky-counter
+ -- label for this block
+ let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $
+ clHasCafRefs cl_info
+ ; emitTickyCounter cl_info (map stripNV args)
+ ; setTickyCtrLabel ticky_ctr_lbl $ do
+
+ -- Emit the main entry code
+ ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $
+ \(offset, node, arg_regs) -> do
+ -- Emit 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
+ node' = if node_points then Just node else Nothing
+ ; tickyEnterFun cl_info
+ ; whenC node_points (ldvEnterClosure cl_info)
+ ; granYield arg_regs node_points
+
+ -- Main payload
+ ; entryHeapCheck cl_info offset node' arity arg_regs $ do
+ { enterCostCentre cl_info cc body
+ ; fv_bindings <- mapM bind_fv fv_details
+ -- Load free vars out of closure *after*
+ -- heap check, to reduce live vars over check
+ ; if node_points then load_fvs node lf_info fv_bindings
+ else return ()
+ ; cgExpr body }}
}
-{-
+-- A function closure pointer may be tagged, so we
+-- must take it into account when accessing the free variables.
+bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
+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) ->
+ emit $ mkTaggedObjectLoad reg node off tag)
+ where tag = lfDynTag lf_info
+
-----------------------------------------
-- The "slow entry" code for a function. This entry point takes its
-- arguments on the stack. It loads the arguments into registers
-- according to the calling convention, and jumps to the function's
-- normal entry point. The function's closure is assumed to be in
-- R1/node.
---
--- The slow entry point is used in two places:
---
--- (a) unknown calls: eg. stg_PAP_entry
--- (b) returning from a heap-check failure
+--
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
-mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
+mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
-- If this function doesn't have a specialised ArgDescr, we need
--- to generate the function's arg bitmap, slow-entry code, and
--- register-save code for the heap-check failure
--- Here, we emit the slow-entry code, and
--- return the register-save assignments
-mkSlowEntryCode cl_info reg_args
+-- to generate the function's arg bitmap and slow-entry code.
+-- Here, we emit the slow-entry code.
+mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
+mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
| Just (_, ArgGen _) <- closureFunInfo cl_info
- = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
- ; return save_stmts }
- | otherwise = return noStmts
+ = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
+ | otherwise = return ()
where
- name = closureName cl_info
- slow_lbl = mkSlowEntryLabel name
-
- load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
- save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
-
- reps_w_regs :: [(CgRep,GlobalReg)]
- reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
- (final_stk_offset, stk_offsets)
- = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
- 0 reps_w_regs
-
- load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
- mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
- (CmmLoad (cmmRegOffW spReg offset)
- (argMachRep rep))
-
- save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
- mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegType reg )
- CmmStore (cmmRegOffW spReg offset)
- (CmmReg (CmmGlobal reg))
-
- stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
- stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
- jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
--}
+ caf_refs = clHasCafRefs cl_info
+ name = closureName cl_info
+ slow_lbl = mkSlowEntryLabel name caf_refs
+ fast_lbl = enterLocalIdLabel name caf_refs
+ -- mkDirectJump does not clobber `Node' containing function closure
+ jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
+ initUpdFrameOff
-----------------------------------------
-thunkCode :: ClosureInfo -> CostCentreStack -> C_SRT -> LocalReg -> StgExpr -> FCode ()
-thunkCode cl_info cc srt node body
- = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
-
- ; tickyEnterThunk cl_info
- ; ldvEnterClosure cl_info -- NB: Node always points when profiling
- ; granThunk node_points
+thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
+ -> LocalReg -> Int -> StgExpr -> FCode ()
+thunkCode cl_info fv_details cc node arity body
+ = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
+ node' = if node_points then Just node else Nothing
+ ; tickyEnterThunk cl_info
+ ; ldvEnterClosure cl_info -- NB: Node always points when profiling
+ ; granThunk node_points
-- Heap overflow check
- ; entryHeapCheck node [] srt $ do
- { -- Overwrite with black hole if necessary
- -- but *after* the heap-overflow check
- whenC (blackHoleOnEntry cl_info && node_points)
- (blackHoleIt cl_info)
-
- -- Push update frame
- ; setupUpdate cl_info node
-
- -- We only enter cc after setting up update so
- -- that cc of enclosing scope will be recorded
- -- in update frame CAF/DICT functions will be
- -- subsumed by this enclosing cc
- ; enterCostCentre cl_info cc body
-
- ; cgExpr body } }
+ ; entryHeapCheck cl_info 0 node' arity [] $ do
+ { -- Overwrite with black hole if necessary
+ -- but *after* the heap-overflow check
+ dflags <- getDynFlags
+ ; whenC (blackHoleOnEntry dflags cl_info && node_points)
+ (blackHoleIt cl_info)
+
+ -- Push update frame
+ ; setupUpdate cl_info node $
+ -- We only enter cc after setting up update so
+ -- that cc of enclosing scope will be recorded
+ -- in update frame CAF/DICT functions will be
+ -- subsumed by this enclosing cc
+ do { enterCostCentre cl_info cc body
+ ; let lf_info = closureLFInfo cl_info
+ ; fv_bindings <- mapM bind_fv fv_details
+ ; load_fvs node lf_info fv_bindings
+ ; cgExpr body }}}
------------------------------------------------------------------------
blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
emitBlackHoleCode :: Bool -> FCode ()
-emitBlackHoleCode is_single_entry
- | eager_blackholing = do
+emitBlackHoleCode is_single_entry
+ | eager_blackholing = do
tickyBlackHole (not is_single_entry)
+ emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)))
+ emitPrimCall [] MO_WriteBarrier []
emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
- | otherwise =
+ | otherwise =
nopC
where
- bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info")
- | otherwise = mkRtsDataLabel (sLit "stg_BLACKHOLE_info")
+ bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
+ | otherwise = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info")
-- If we wanted to do eager blackholing with slop filling,
-- we'd need to do it at the *end* of a basic block, otherwise
-- currently eager blackholing doesn't work with profiling.
--
-- 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
+ -- 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
+ eager_blackholing = False
-setupUpdate :: ClosureInfo -> LocalReg -> FCode ()
+setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
-- extracted by a subsequent enterCostCentre
-setupUpdate closure_info node
+setupUpdate closure_info node body
| closureReEntrant closure_info
- = return ()
+ = body
| not (isStaticClosure closure_info)
- = if closureUpdReqd closure_info
- then do { tickyPushUpdateFrame; pushUpdateFrame node }
- else tickyUpdateFrameOmitted
-
+ = if not (closureUpdReqd closure_info)
+ then do tickyUpdateFrameOmitted; body
+ else do
+ tickyPushUpdateFrame
+ --dflags <- getDynFlags
+ let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel]
+ --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+ -- then pushUpdateFrame es body -- XXX black hole
+ -- else pushUpdateFrame es body
+ pushUpdateFrame es body
+
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
{ upd_closure <- link_caf closure_info True
- ; pushUpdateFrame upd_closure }
- else tickyUpdateFrameOmitted
+ ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
+ mkLblExpr mkUpdInfoLabel] body } -- XXX black hole
+ else do {tickyUpdateFrameOmitted; body}
}
-pushUpdateFrame :: LocalReg -> FCode ()
-pushUpdateFrame cl_reg
- = emit (mkAddToContext (mkLblExpr mkUpdInfoLabel)
- [CmmReg (CmmLocal cl_reg)])
+-----------------------------------------------------------------------------
+-- Setting up update frames
+
+-- Push the update frame on the stack in the Entry area,
+-- leaving room for the return address that is already
+-- at the old end of the area.
+pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
+pushUpdateFrame es body
+ = do -- [EZY] I'm not sure if we need to special-case for BH too
+ updfr <- getUpdFrameOff
+ offset <- foldM push updfr es
+ withUpdFrameOff offset body
+ where push off e =
+ do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
+ return base
+ where base = off + widthInBytes (cmmExprWidth e)
-----------------------------------------------------------------------------
-- Entering a CAF
-- allocated black hole to be empty.
--
-- Why do we make a black hole in the heap when we enter a CAF?
---
+--
-- - for a generational garbage collector, which needs a fast
-- test for whether an updatee is in an old generation or not
--
-- ToDo [Feb 04] This entire link_caf nonsense could all be moved
-- into the "newCAF" RTS procedure, which we call anyway, including
-- the allocation of the black-hole indirection closure.
--- That way, code size would fall, the CAF-handling code would
+-- That way, code size would fall, the CAF-handling code would
-- be closer together, and the compiler wouldn't need to know
-- about off_indirectee etc.
-- 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
- ; hp_rel <- allocDynClosure bh_cl_info use_cc blame_cc []
+ tso = CmmReg (CmmGlobal CurrentTSO)
+ -- XXX ezyang: FIXME
+ ; (hp_rel, init) <- allocDynClosureCmm bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
+ ; emit init
-- Call the RTS function newCAF to add the CAF to the CafList
-- so that the garbage collector can find them
- -- This must be done *before* the info table pointer is overwritten,
+ -- 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,AddrHint)] [node] False
+ ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
+ [ (CmmReg (CmmGlobal BaseReg), AddrHint),
+ (CmmReg nodeReg, AddrHint) ]
+ [node] False
-- node is live, so save it.
- -- Overwrite the closure with a (static) indirection
+ -- Overwrite the closure with a (static) indirection
-- to the newly-allocated black hole
; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
mkStore (CmmReg nodeReg) ind_static_info)
; 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
------------------------------------------------------------------------
--- Profiling
+-- Profiling
------------------------------------------------------------------------
-- For "global" data constructors the description is simply occurrence
else pprModule mod_name <> char '.' <> ppr name) <>
char '>')
-- showSDocDump, because we want to see the unique on the Name.
-
+
projects / ghc-hetmet.git / blobdiff