diff options
Diffstat (limited to 'compiler/codeGen/StgCmmProf.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 96 |
1 files changed, 44 insertions, 52 deletions
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 3307604a87..5044d763a4 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -6,28 +6,21 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmProf ( - initCostCentres, ccType, ccsType, - mkCCostCentre, mkCCostCentreStack, + initCostCentres, ccType, ccsType, + mkCCostCentre, mkCCostCentreStack, - -- Cost-centre Profiling - dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, + -- Cost-centre Profiling + dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, enterCostCentreThunk, enterCostCentreFun, costCentreFrom, curCCS, storeCurCCS, emitSetCCC, - saveCurrentCostCentre, restoreCurrentCostCentre, + saveCurrentCostCentre, restoreCurrentCostCentre, - -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate + -- Lag/drag/void stuff + ldvEnter, ldvEnterClosure, ldvRecordCreate ) where #include "HsVersions.h" @@ -78,8 +71,8 @@ mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) costCentreFrom :: DynFlags - -> CmmExpr -- A closure pointer - -> CmmExpr -- The cost centre from that closure + -> CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) -- | The profiling header words in a static closure @@ -94,43 +87,43 @@ dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame - = ifProfiling $ -- frame->header.prof.ccs = CCCS + = ifProfiling $ -- frame->header.prof.ccs = CCCS do dflags <- getDynFlags emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) - -- is unnecessary because it is not used anyhow. + -- is unnecessary because it is not used anyhow. --------------------------------------------------------------------------- --- Saving and restoring the current cost centre +-- Saving and restoring the current cost centre --------------------------------------------------------------------------- -{- Note [Saving the current cost centre] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The current cost centre is like a global register. Like other +{- Note [Saving the current cost centre] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The current cost centre is like a global register. Like other global registers, it's a caller-saves one. But consider - case (f x) of (p,q) -> rhs -Since 'f' may set the cost centre, we must restore it + case (f x) of (p,q) -> rhs +Since 'f' may set the cost centre, we must restore it before resuming rhs. So we want code like this: - local_cc = CCC -- save - r = f( x ) - CCC = local_cc -- restore + local_cc = CCC -- save + r = f( x ) + CCC = local_cc -- restore That is, we explicitly "save" the current cost centre in a LocalReg, local_cc; and restore it after the call. The C-- infrastructure will arrange to save local_cc across the -call. +call. The same goes for join points; - let j x = join-stuff - in blah-blah + let j x = join-stuff + in blah-blah We want this kind of code: - local_cc = CCC -- save - blah-blah - J: + local_cc = CCC -- save + blah-blah + J: CCC = local_cc -- restore -} saveCurrentCostCentre :: FCode (Maybe LocalReg) - -- Returns Nothing if profiling is off + -- Returns Nothing if profiling is off saveCurrentCostCentre = do dflags <- getDynFlags if not (gopt Opt_SccProfilingOn dflags) @@ -140,7 +133,7 @@ saveCurrentCostCentre return (Just local_cc) restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing +restoreCurrentCostCentre Nothing = return () restoreCurrentCostCentre (Just local_cc) = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) @@ -178,7 +171,7 @@ profAlloc words ccs -- Setting the current cost centre on entry to a closure enterCostCentreThunk :: CmmExpr -> FCode () -enterCostCentreThunk closure = +enterCostCentreThunk closure = ifProfiling $ do dflags <- getDynFlags emit $ storeCurCCS (costCentreFrom dflags closure) @@ -207,7 +200,7 @@ ifProfilingL dflags xs --------------------------------------------------------------- --- Initialising Cost Centres & CCSs +-- Initialising Cost Centres & CCSs --------------------------------------------------------------- initCostCentres :: CollectedCCs -> FCode () @@ -220,7 +213,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () -emitCostCentreDecl cc = do +emitCostCentreDecl cc = do { dflags <- getDynFlags ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF | otherwise = zero dflags @@ -233,20 +226,20 @@ emitCostCentreDecl cc = do showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero dflags, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, + lits = [ zero dflags, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf zero dflags -- struct _CostCentre *link - ] + ] ; emitDataLits (mkCCLabel cc) lits } emitCostCentreStackDecl :: CostCentreStack -> FCode () -emitCostCentreStackDecl ccs +emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of Just cc -> do dflags <- getDynFlags @@ -290,19 +283,19 @@ emitSetCCC cc tick push pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageId (fsLit "pushCostCentre") [(ccs,AddrHint), - (CmmLit (mkCCostCentre cc), AddrHint)] + (CmmLit (mkCCostCentre cc), AddrHint)] False bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph bumpSccCount dflags ccs = addToMem (rEP_CostCentreStack_scc_count dflags) - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- -- --- Lag/drag/void stuff +-- Lag/drag/void stuff -- ----------------------------------------------------------------------------- @@ -316,12 +309,12 @@ staticLdvInit = zeroCLit -- Initial value of the LDV field in a dynamic closure -- dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) ] - + -- -- Initialise the LDV word of a new closure -- @@ -340,7 +333,7 @@ ldvEnterClosure closure_info = do dflags <- getDynFlags let tag = funTag dflags closure_info ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- don't forget to substract node's tag - + ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do @@ -364,8 +357,7 @@ loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +-- Takes the address of a closure, and returns -- the address of the LDV word in the closure ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) - |