X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmBind.hs;h=2947d330425a4969dce83247ead02c8141d44660;hb=16b9e80dc14db24509f051f294b5b51943285090;hp=0e8d853969ba1bb2ea50e50ddc736358e9589513;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69;p=ghc-hetmet.git diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0e8d853..2947d33 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -6,16 +6,17 @@ -- ----------------------------------------------------------------------------- -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 @@ -25,16 +26,19 @@ import StgCmmGran 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 @@ -45,8 +49,6 @@ import Outputable import FastString import Maybes -import Data.List - ------------------------------------------------------------------------ -- Top-level bindings ------------------------------------------------------------------------ @@ -59,11 +61,11 @@ cgTopRhsClosure :: Id -> 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 @@ -77,12 +79,14 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do -- 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 @@ -90,36 +94,76 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do 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 @@ -158,7 +202,7 @@ for semi-obvious reasons. ---------- 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 @@ -184,7 +228,7 @@ mkRhsClosure bndr cc bi (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 @@ -197,9 +241,9 @@ mkRhsClosure bndr cc bi 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 @@ -211,65 +255,57 @@ mkRhsClosure bndr cc bi 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 @@ -279,56 +315,56 @@ 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 @@ -338,121 +374,114 @@ closureCodeBody :: StgBinderInfo -- XXX: unused? 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 }}} ------------------------------------------------------------------------ @@ -465,15 +494,17 @@ blackHoleIt :: ClosureInfo -> FCode () 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 @@ -485,39 +516,59 @@ emitBlackHoleCode is_single_entry -- 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 @@ -530,7 +581,7 @@ pushUpdateFrame cl_reg -- 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 -- @@ -548,7 +599,7 @@ pushUpdateFrame cl_reg -- 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. @@ -561,20 +612,26 @@ 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 - ; 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) @@ -582,8 +639,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 @@ -593,7 +649,7 @@ link_caf cl_info is_upd = do ------------------------------------------------------------------------ --- Profiling +-- Profiling ------------------------------------------------------------------------ -- For "global" data constructors the description is simply occurrence @@ -612,4 +668,4 @@ closureDescription mod_name name else pprModule mod_name <> char '.' <> ppr name) <> char '>') -- showSDocDump, because we want to see the unique on the Name. - +