diff options
Diffstat (limited to 'compiler/codeGen/StgCmmProf.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 177 |
1 files changed, 10 insertions, 167 deletions
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index b1aca6e37e..17b61c6a59 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -12,11 +12,10 @@ module StgCmmProf ( -- Cost-centre Profiling dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, - enterCostCentre, enterCostCentrePAP, enterCostCentreThunk, - chooseDynCostCentres, - costCentreFrom, + enterCostCentreThunk, + costCentreFrom, curCCS, curCCSAddr, - emitSetCCC, emitCCS, + emitSetCCC, saveCurrentCostCentre, restoreCurrentCostCentre, @@ -43,17 +42,14 @@ import Cmm import CmmUtils import CLabel -import Id import qualified Module import CostCentre -import StgSyn import StaticFlags import FastString import Module -import Constants -- Lots of field offsets +import Constants -- Lots of field offsets import Outputable -import Data.Char import Control.Monad ----------------------------------------------------------------------------- @@ -177,161 +173,14 @@ profAlloc words ccs where alloc_rep = REP_CostCentreStack_mem_alloc --- ---------------------------------------------------------------------- --- Setting the cost centre in a new closure - -chooseDynCostCentres :: CostCentreStack - -> [Id] -- Args - -> StgExpr -- Body - -> FCode (CmmExpr, CmmExpr) --- Called when allocating a closure --- Tells which cost centre to put in the object, and which --- to blame the cost of allocation on -chooseDynCostCentres ccs args body = do - -- Cost-centre we record in the object - use_ccs <- emitCCS ccs - - -- Cost-centre on whom we blame the allocation - let blame_ccs - | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS) - | otherwise = use_ccs - - return (use_ccs, blame_ccs) - - --- Some CostCentreStacks are a sequence of pushes on top of CCCS. --- These pushes must be performed before we can refer to the stack in --- an expression. -emitCCS :: CostCentreStack -> FCode CmmExpr -emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's) - where - (cc's, ccs') = decomposeCCS ccs - - push_em ccs [] = return ccs - push_em ccs (cc:rest) = do - tmp <- newTemp ccsType - pushCostCentre tmp ccs cc - push_em (CmmReg (CmmLocal tmp)) rest - -ccsExpr :: CostCentreStack -> CmmExpr -ccsExpr ccs - | isCurrentCCS ccs = curCCS - | otherwise = CmmLit (mkCCostCentreStack ccs) - - -isBox :: StgExpr -> Bool --- If it's an utterly trivial RHS, then it must be --- one introduced by boxHigherOrderArgs for profiling, --- so we charge it to "OVERHEAD". --- This looks like a GROSS HACK to me --SDM -isBox (StgApp _ []) = True -isBox _ = False - - -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure --- For lexically scoped profiling we have to load the cost centre from --- the closure entered, if the costs are not supposed to be inherited. --- This is done immediately on entering the fast entry point. - --- Load current cost centre from closure, if not inherited. --- Node is guaranteed to point to it, if profiling and not inherited. - -enterCostCentre - :: ClosureInfo - -> CostCentreStack - -> StgExpr -- The RHS of the closure - -> FCode () - --- We used to have a special case for bindings of form --- f = g True --- where g has arity 2. The RHS is a thunk, but we don't --- need to update it; and we want to subsume costs. --- We don't have these sort of PAPs any more, so the special --- case has gone away. - -enterCostCentre closure_info ccs body - = ifProfiling $ - ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs) - enter_cost_centre closure_info ccs body - -enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> FCode () -enter_cost_centre closure_info ccs body - | isSubsumedCCS ccs - = ASSERT(isToplevClosure closure_info) - ASSERT(re_entrant) - enter_ccs_fsub - - | isDerivedFromCurrentCCS ccs - = do { - if re_entrant && not is_box - then - enter_ccs_fun node_ccs - else - emit (mkStore curCCSAddr node_ccs) - - -- don't forget to bump the scc count. This closure might have been - -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal - -- pass has turned into simply let x = e in ...x... and attached - -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that - -- we don't lose the scc counter, bump it in the entry code for x. - -- ToDo: for a multi-push we should really bump the counter for - -- each of the intervening CCSs, not just the top one. - ; when (not (isCurrentCCS ccs)) $ - emit (bumpSccCount curCCS) - } - - | isCafCCS ccs - = ASSERT(isToplevClosure closure_info) - ASSERT(not re_entrant) - do { -- This is just a special case of the isDerivedFromCurrentCCS - -- case above. We could delete this, but it's a micro - -- optimisation and saves a bit of code. - emit (mkStore curCCSAddr enc_ccs) - ; emit (bumpSccCount node_ccs) - } - - | otherwise - = panic "enterCostCentre" - where - enc_ccs = CmmLit (mkCCostCentreStack ccs) - re_entrant = closureReEntrant closure_info - node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag)) - is_box = isBox body - - -- if this is a function, then node will be tagged; we must subract the tag - node_tag = funTag closure_info - --- set the current CCS when entering a PAP -enterCostCentrePAP :: CmmExpr -> FCode () -enterCostCentrePAP closure = - ifProfiling $ do - enter_ccs_fun (costCentreFrom closure) - enteringPAP 1 - enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure = ifProfiling $ do emit $ mkStore curCCSAddr (costCentreFrom closure) -enter_ccs_fun :: CmmExpr -> FCode () -enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [(stack,AddrHint)] False - -- ToDo: vols - -enter_ccs_fsub :: FCode () -enter_ccs_fsub = enteringPAP 0 - --- When entering a PAP, EnterFunCCS is called by both the PAP entry --- code and the function entry code; we don't want the function's --- entry code to also update CCCS in the event that it was called via --- a PAP, so we set the flag entering_PAP to indicate that we are --- entering via a PAP. -enteringPAP :: Integer -> FCode () -enteringPAP n - = emit (mkStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP")))) - (CmmLit (CmmInt n cIntWidth))) - ifProfiling :: FCode () -> FCode () ifProfiling code | opt_SccProfilingOn = code @@ -368,14 +217,10 @@ emitCostCentreDecl cc = do modl, -- char *module, zero, -- StgWord time_ticks zero64, -- StgWord64 mem_alloc - subsumed, -- StgInt is_caf - zero -- struct _CostCentre *link + zero -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } - where - subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF - | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring emitCostCentreStackDecl :: CostCentreStack -> FCode () emitCostCentreStackDecl ccs @@ -408,16 +253,14 @@ sizeof_ccs_words -- --------------------------------------------------------------------------- -- Set the current cost centre stack -emitSetCCC :: CostCentre -> FCode () -emitSetCCC cc +emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () +emitSetCCC cc tick push | not opt_SccProfilingOn = nopC | otherwise = do tmp <- newTemp ccsType -- TODO FIXME NOW - ASSERT( sccAbleCostCentre cc ) - pushCostCentre tmp curCCS cc - emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp))) - when (isSccCountCostCentre cc) $ - emit (bumpSccCount curCCS) + pushCostCentre tmp curCCS cc + when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp))) + when push $ emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc |