diff options
Diffstat (limited to 'compiler/codeGen/StgCmmBind.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 43 |
1 files changed, 17 insertions, 26 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 136bb52b07..1e5d6b9f4f 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -296,7 +296,7 @@ mkRhsClosure dflags bndr _cc _bi (StgApp fun_id args) | args `lengthIs` (arity-1) - && all (isGcPtrRep . idPrimRep . stripNV) fvs + && all (isGcPtrRep . idPrimRep . unsafe_stripNV) fvs && isUpdatable upd_flag && arity <= mAX_SPEC_AP_SIZE dflags && not (gopt Opt_SccProfilingOn dflags) @@ -344,7 +344,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body fv_details :: [(NonVoid Id, VirtualHpOffset)] (tot_wds, ptr_wds, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) - (addIdReps (map stripNV reduced_fvs)) + (addIdReps (map unsafe_stripNV reduced_fvs)) closure_info = mkClosureInfo dflags False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -369,11 +369,6 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body -- RETURN ; return (mkRhsInit dflags reg lf_info hp_plus_n) } - --- Use with care; if used inappropriately, it could break invariants. -stripNV :: NonVoid a -> a -stripNV (NonVoid a) = a - ------------------------- cgRhsStdThunk :: Id @@ -418,10 +413,10 @@ mkClosureLFInfo :: Id -- The binder -> [Id] -- Args -> FCode LambdaFormInfo mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag) + | null args = return (mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag) | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) } + ; return (mkLFReEntrant top (map unsafe_stripNV fvs) args arg_descr) } ------------------------------------------------------------------------ @@ -453,7 +448,8 @@ closureCodeBody :: Bool -- whether this is a top-level binding closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details | arity == 0 -- No args i.e. thunk - = emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ + = withNewTickyCounterThunk cl_info $ + emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where lf_info = closureLFInfo cl_info @@ -461,12 +457,7 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = -- Note: args may be [], if all args are Void - do { -- Allocate the global ticky counter, - -- and establish the ticky-counter - -- label for this block - let ticky_ctr_lbl = closureRednCountsLabel cl_info - ; emitTickyCounter cl_info (map stripNV args) - ; setTickyCtrLabel ticky_ctr_lbl $ do + withNewTickyCounterFun (closureName cl_info) args $ do { ; let lf_info = closureLFInfo cl_info @@ -479,20 +470,20 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details { mkSlowEntryCode bndr cl_info arg_regs ; dflags <- getDynFlags - ; let lf_info = closureLFInfo cl_info - node_points = nodeMustPointToIt dflags lf_info + ; let node_points = nodeMustPointToIt dflags lf_info node' = if node_points then Just node else Nothing - ; tickyEnterFun cl_info - ; enterCostCentreFun cc - (CmmMachOp (mo_wordSub dflags) - [ CmmReg nodeReg - , mkIntExpr dflags (funTag dflags cl_info) ]) ; when node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do - { fv_bindings <- mapM bind_fv fv_details + { -- ticky after heap check to avoid double counting + tickyEnterFun cl_info + ; enterCostCentreFun cc + (CmmMachOp (mo_wordSub dflags) + [ CmmReg nodeReg + , mkIntExpr dflags (funTag dflags cl_info) ]) + ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check ; when node_points $ load_fvs node lf_info fv_bindings @@ -545,7 +536,6 @@ thunkCode cl_info fv_details _cc node arity body = do { dflags <- getDynFlags ; let node_points = nodeMustPointToIt dflags (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 @@ -562,7 +552,8 @@ thunkCode cl_info fv_details _cc node arity body -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - do { enterCostCentreThunk (CmmReg nodeReg) + do { tickyEnterThunk cl_info + ; enterCostCentreThunk (CmmReg nodeReg) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details ; load_fvs node lf_info fv_bindings |