diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 1e5d6b9f4fdc..0ba99aed3604 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -204,8 +204,9 @@ cgRhs :: Id -- (see above) ) -cgRhs name (StgRhsCon cc con args) - = buildDynCon name cc con args +cgRhs id (StgRhsCon cc con args) + = withNewTickyCounterThunk (idName id) $ + buildDynCon id True cc con args cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) = do dflags <- getDynFlags @@ -363,7 +364,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) ; let info_tbl = mkCmmInfo closure_info - ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc + ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc (map toVarArg fv_details) -- RETURN @@ -381,8 +382,9 @@ cgRhsStdThunk bndr lf_info payload ; return (id_info, gen_code reg) } where - gen_code reg - = do -- AHA! A STANDARD-FORM THUNK + gen_code reg -- AHA! A STANDARD-FORM THUNK + = withNewTickyCounterStdThunk (idName bndr) $ + do { -- LAY OUT THE OBJECT mod_name <- getModuleName ; dflags <- getDynFlags @@ -397,9 +399,11 @@ cgRhsStdThunk bndr lf_info payload -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body ; let use_cc = curCCS; blame_cc = curCCS + ; tickyEnterStdThunk + -- BUILD THE OBJECT ; let info_tbl = mkCmmInfo closure_info - ; hp_plus_n <- allocDynClosure info_tbl lf_info + ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc payload_w_offsets -- RETURN @@ -448,7 +452,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 - = withNewTickyCounterThunk cl_info $ + = ASSERT ( not (isStaticClosure cl_info) ) + withNewTickyCounterThunk (closureName cl_info) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where @@ -552,7 +557,7 @@ 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 { tickyEnterThunk cl_info + do { tickyEnterThunk ; enterCostCentreThunk (CmmReg nodeReg) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details @@ -717,7 +722,7 @@ link_caf node _is_upd = do blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) - ; hp_rel <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole + ; hp_rel <- allocDynClosureCmm Nothing cafBlackHoleInfoTable mkLFBlackHole use_cc blame_cc [(tso,fixedHdrSize dflags)] -- small optimisation: we duplicate the hp_rel expression in -- both the newCAF call and the value returned below. diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 3e95c59d120e..d2a25ebd6c87 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -109,19 +109,21 @@ cgTopRhsCon id con args buildDynCon :: Id -- Name of the thing to which this constr will -- be bound + -> Bool -- is it genuinely bound to that name, or just for profiling? -> CostCentreStack -- Where to grab cost centre from; -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor -> [StgArg] -- Its args -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code -buildDynCon binder cc con args +buildDynCon binder actually_bound cc con args = do dflags <- getDynFlags - buildDynCon' dflags (targetPlatform dflags) binder cc con args + buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args + buildDynCon' :: DynFlags -> Platform - -> Id + -> Id -> Bool -> CostCentreStack -> DataCon -> [StgArg] @@ -148,7 +150,7 @@ premature looking at the args will cause the compiler to black-hole! -- which have exclusively size-zero (VoidRep) args, we generate no code -- at all. -buildDynCon' dflags _ binder _cc con [] +buildDynCon' dflags _ binder _ _cc con [] = return (litIdInfo dflags binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), return mkNop) @@ -179,7 +181,7 @@ We don't support this optimisation when compiling into Windows DLLs yet because they don't support cross package data references well. -} -buildDynCon' dflags platform binder _cc con [arg] +buildDynCon' dflags platform binder _ _cc con [arg] | maybeIntLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) , StgLitArg (MachInt val) <- arg @@ -193,7 +195,7 @@ buildDynCon' dflags platform binder _cc con [arg] ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode , return mkNop) } -buildDynCon' dflags platform binder _cc con [arg] +buildDynCon' dflags platform binder _ _cc con [arg] | maybeCharLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) , StgLitArg (MachChar val) <- arg @@ -208,7 +210,7 @@ buildDynCon' dflags platform binder _cc con [arg] , return mkNop) } -------- buildDynCon': the general case ----------- -buildDynCon' dflags _ binder ccs con args +buildDynCon' dflags _ binder actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -222,7 +224,10 @@ buildDynCon' dflags _ binder ccs con args nonptr_wds = tot_wds - ptr_wds info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds - ; hp_plus_n <- allocDynClosure info_tbl lf_info + ; let ticky_name | actually_bound = Just binder + | otherwise = Nothing + + ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info use_cc blame_cc args_w_offsets ; return (mkRhsInit dflags reg lf_info hp_plus_n) } where diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 78080218f83f..d7edf8e19395 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -610,10 +610,11 @@ cgConApp con stg_args | otherwise -- Boxed constructors; allocate and return = ASSERT( stg_args `lengthIs` dataConRepRepArity con ) - do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) + do { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False currentCCS con stg_args - -- The first "con" says that the name bound to this closure is - -- is "con", which is a bit of a fudge, but it only affects profiling + -- The first "con" says that the name bound to this + -- closure is is "con", which is a bit of a fudge, but + -- it only affects profiling (hence the False) ; emit =<< fcode_init ; emitReturn [idInfoToAmode idinfo] } diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 0a817030e5ad..b8962cedb42f 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -42,6 +42,7 @@ import Cmm import CmmUtils import CostCentre import IdInfo( CafInfo(..), mayHaveCafRefs ) +import Id ( Id ) import Module import DynFlags import FastString( mkFastString, fsLit ) @@ -54,7 +55,8 @@ import Data.Maybe (isJust) ----------------------------------------------------------- allocDynClosure - :: CmmInfoTable + :: Maybe Id + -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -- Cost Centre to stick in the object -> CmmExpr -- Cost Centre to blame for this alloc @@ -66,7 +68,7 @@ allocDynClosure -> FCode CmmExpr -- returns Hp+n allocDynClosureCmm - :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr + :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> FCode CmmExpr -- returns Hp+n @@ -88,19 +90,19 @@ allocDynClosureCmm -- significant - see test T4801. -allocDynClosure info_tbl lf_info use_cc _blame_cc args_w_offsets +allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do { let (args, offsets) = unzip args_w_offsets ; cmm_args <- mapM getArgAmode args -- No void args - ; allocDynClosureCmm info_tbl lf_info + ; allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc (zip cmm_args offsets) } -allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets +allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do { virt_hp <- getVirtHp -- SAY WHAT WE ARE ABOUT TO DO ; let rep = cit_rep info_tbl - ; tickyDynAlloc (toRednCountsLbl $ cit_lbl info_tbl) rep lf_info + ; tickyDynAlloc mb_id rep lf_info ; profDynAlloc rep use_cc -- FIND THE OFFSET OF THE INFO-PTR WORD diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index dd7e95078fd3..1f3d5c488663 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -514,7 +514,7 @@ getTickyCtrLabel = do info <- getInfoDown return (cgd_ticky info) -setTickyCtrLabel :: CLabel -> FCode () -> FCode () +setTickyCtrLabel :: CLabel -> FCode a -> FCode a setTickyCtrLabel ticky code = do info <- getInfoDown withInfoDown code (info {cgd_ticky = ticky}) diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 64271386391e..79afe0b17e7f 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -65,8 +65,9 @@ the code generator as well as the RTS because: module StgCmmTicky ( withNewTickyCounterFun, - withNewTickyCounterThunk, withNewTickyCounterLNE, + withNewTickyCounterThunk, + withNewTickyCounterStdThunk, tickyDynAlloc, tickyAllocHeap, @@ -87,7 +88,8 @@ module StgCmmTicky ( tickyEnterViaNode, tickyEnterFun, - tickyEnterThunk, + tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value + -- thunks only tickyEnterLNE, tickyUpdateBhCaf, @@ -141,22 +143,22 @@ import Control.Monad ( when ) data TickyClosureType = TickyFun | TickyThunk | TickyLNE -withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode () -> FCode () +withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a withNewTickyCounterFun = withNewTickyCounter TickyFun withNewTickyCounterLNE nm args code = do b <- tickyLNEIsOn if not b then code else withNewTickyCounter TickyLNE nm args code -withNewTickyCounterThunk :: ClosureInfo -> FCode () -> FCode () -withNewTickyCounterThunk cl_info code - | isStaticClosure cl_info = code -- static thunks are uninteresting - | otherwise = do +withNewTickyCounterThunk,withNewTickyCounterStdThunk :: Name -> FCode a -> FCode a +withNewTickyCounterThunk name code = do b <- tickyDynThunkIsOn - if not b then code else withNewTickyCounter TickyThunk (closureName cl_info) [] code + if not b then code else withNewTickyCounter TickyThunk name [] code + +withNewTickyCounterStdThunk = withNewTickyCounterThunk -- args does not include the void arguments -withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode () -> FCode () +withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a withNewTickyCounter cloType name args m = do lbl <- emitTickyCounter cloType name args setTickyCtrLabel lbl m @@ -222,23 +224,28 @@ tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") -- ----------------------------------------------------------------------------- -- Ticky entries -tickyEnterDynCon, tickyEnterStaticCon, - tickyEnterStaticThunk, tickyEnterViaNode :: FCode () +-- NB the name-specific entries are only available for names that have +-- dedicated Cmm code. As far as I know, this just rules out +-- constructor thunks. For them, there is no CMM code block to put the +-- bump of name-specific ticky counter into. On the other hand, we can +-- still track allocation their allocation. + +tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode () tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") -tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr") tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") -tickyEnterThunk :: ClosureInfo -> FCode () -tickyEnterThunk cl_info - | isStaticClosure cl_info = tickyEnterStaticThunk - | otherwise = ifTicky $ do +tickyEnterThunk :: FCode () +tickyEnterThunk = ifTicky $ do bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") ifTickyDynThunk $ do ticky_ctr_lbl <- getTickyCtrLabel registerTickyCtrAtEntryDyn ticky_ctr_lbl bumpTickyEntryCount ticky_ctr_lbl +tickyEnterStdThunk :: FCode () +tickyEnterStdThunk = tickyEnterThunk + tickyBlackHole :: Bool{-updatable-} -> FCode () tickyBlackHole updatable = ifTicky (bumpTickyCounter ctr) @@ -390,20 +397,21 @@ bad for both space and time). -- ----------------------------------------------------------------------------- -- Ticky allocation -tickyDynAlloc :: Maybe CLabel -> SMRep -> LambdaFormInfo -> FCode () +tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () -- Called when doing a dynamic heap allocation; the LambdaFormInfo -- used to distinguish between closure types -- -- TODO what else to count while we're here? -tickyDynAlloc mb_ctr_lbl rep lf = ifTicky $ getDynFlags >>= \dflags -> +tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags -> let bytes = wORD_SIZE dflags * heapClosureSize dflags rep countGlobal tot ctr = do bumpTickyCounterBy tot bytes bumpTickyCounter ctr - countSpecific = ifTickyAllocd $ case mb_ctr_lbl of + countSpecific = ifTickyAllocd $ case mb_id of Nothing -> return () - Just ctr_lbl -> do + Just id -> do + let ctr_lbl = mkRednCountsLabel (idName id) registerTickyCtr ctr_lbl bumpTickyAllocd ctr_lbl bytes @@ -414,6 +422,7 @@ tickyDynAlloc mb_ctr_lbl rep lf = ifTicky $ getDynFlags >>= \dflags -> in case () of _ | isConRep rep -> + ifTickyDynThunk countSpecific >> countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr") | isThunkRep rep -> ifTickyDynThunk countSpecific >>