summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/Unique.lhs10
-rw-r--r--compiler/codeGen/CgProf.hs6
-rw-r--r--compiler/codeGen/StgCmmProf.hs12
-rw-r--r--compiler/deSugar/Coverage.lhs105
-rw-r--r--compiler/deSugar/DsExpr.lhs5
-rw-r--r--compiler/iface/BinIface.hs23
-rw-r--r--compiler/main/DynFlags.hs2
-rw-r--r--compiler/profiling/CostCentre.lhs91
-rw-r--r--compiler/profiling/SCCfinal.lhs8
-rw-r--r--docs/users_guide/ghci.xml3
-rw-r--r--docs/users_guide/profiling.xml18
-rw-r--r--docs/users_guide/runtime_control.xml8
-rw-r--r--includes/rts/prof/CCS.h4
-rw-r--r--rts/Profiling.c14
14 files changed, 199 insertions, 110 deletions
diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs
index 6fba95c0b5..f99a50cfeb 100644
--- a/compiler/basicTypes/Unique.lhs
+++ b/compiler/basicTypes/Unique.lhs
@@ -56,10 +56,10 @@ module Unique (
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
+ mkCostCentreUnique,
mkBuiltinUnique,
- mkPseudoUniqueC,
- mkPseudoUniqueD,
+ mkPseudoUniqueD,
mkPseudoUniqueE,
mkPseudoUniqueH
) where
@@ -359,11 +359,10 @@ mkPArrDataConUnique a = mkUnique ':' (2*a)
initTyVarUnique :: Unique
initTyVarUnique = mkUnique 't' 0
-mkPseudoUniqueC, mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,
+mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,
mkBuiltinUnique :: Int -> Unique
mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUniqueC i = mkUnique 'C' i -- used for getUnique on Regs
mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs
@@ -374,6 +373,9 @@ mkRegSubUnique = mkUnique 'S'
mkRegPairUnique = mkUnique 'P'
mkRegClassUnique = mkUnique 'L'
+mkCostCentreUnique :: Int -> Unique
+mkCostCentreUnique = mkUnique 'C'
+
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique
-- See Note [The Unique of an OccName] in OccName
mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs))
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 3e247ff4d6..92adf1afa7 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -170,11 +170,15 @@ emitCostCentreDecl cc = do
-- All cost centres will be in the main package, since we
-- don't normally use -auto-all or add SCCs to other packages.
-- Hence don't emit the package name in the module here.
+ ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
+ showSDoc (ppr (costCentreSrcSpan cc))
+ -- XXX going via FastString to get UTF-8 encoding is silly
; let
lits = [ zero, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
- zero, -- StgWord time_ticks
+ loc, -- char *srcloc,
+ zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index d9b3583382..8ce1d5b372 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -58,6 +58,7 @@ import Constants -- Lots of field offsets
import Outputable
import Control.Monad
+import Data.Char (ord)
-----------------------------------------------------------------------------
--
@@ -217,18 +218,25 @@ emitCostCentreDecl cc = do
; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
$ Module.moduleName
$ cc_mod cc)
+ ; loc <- newStringCLit (showSDoc (ppr (costCentreSrcSpan cc)))
+ -- XXX should UTF-8 encode
-- All cost centres will be in the main package, since we
-- don't normally use -auto-all or add SCCs to other packages.
-- Hence don't emit the package name in the module here.
; let lits = [ zero, -- StgInt ccID,
label, -- char *label,
- modl, -- char *module,
- zero, -- StgWord time_ticks
+ modl, -- char *module,
+ loc, -- char *srcloc,
+ zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
+ is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
]
; emitDataLits (mkCCLabel cc) lits
}
+ where
+ is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
+ | otherwise = zero
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl ccs
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index fd2895d072..84cb6d628f 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -33,6 +33,7 @@ import HscTypes
import Platform
import StaticFlags
import TyCon
+import Unique
import BasicTypes
import MonadUtils
import Maybes
@@ -177,8 +178,7 @@ data TickDensity
| TickAllFunctions -- for -prof-auto-all
| TickTopFunctions -- for -prof-auto-top
| TickExportedFunctions -- for -prof-auto-exported
- -- maybe also:
- -- | TickCallSites -- for stack tracing
+ | TickCallSites -- for stack tracing
deriving Eq
mkDensity :: DynFlags -> TickDensity
@@ -188,8 +188,13 @@ mkDensity dflags
| ProfAutoAll <- profAuto dflags = TickAllFunctions
| ProfAutoTop <- profAuto dflags = TickTopFunctions
| ProfAutoExports <- profAuto dflags = TickExportedFunctions
+ | ProfAutoCalls <- profAuto dflags = TickCallSites
| otherwise = panic "desnity"
-
+ -- ToDo: -fhpc is taking priority over -fprof-auto here. It seems
+ -- that coverage works perfectly well with profiling, but you don't
+ -- get any auto-generated SCCs. It would make perfect sense to
+ -- allow both of them, and indeed to combine some of the other flags
+ -- (-fprof-auto-calls -fprof-auto-top, for example)
-- | Decide whether to add a tick to a binding or not.
shouldTickBind :: TickDensity
@@ -208,6 +213,7 @@ shouldTickBind density top_lev exported simple_pat inline
TickTopFunctions -> top_lev && not inline
TickExportedFunctions -> exported && not inline
TickForCoverage -> True
+ TickCallSites -> False
shouldTickPatBind :: TickDensity -> Bool -> Bool
shouldTickPatBind density top_lev
@@ -217,6 +223,7 @@ shouldTickPatBind density top_lev
TickTopFunctions -> top_lev
TickExportedFunctions -> False
TickForCoverage -> False
+ TickCallSites -> False
-- -----------------------------------------------------------------------------
-- Adding ticks to bindings
@@ -323,38 +330,60 @@ bindTick density name pos fvs = do
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExpr (L pos e0) = do
+addTickLHsExpr e@(L pos e0) = do
d <- getDensity
case d of
+ TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
TickForCoverage -> tick_it
- TickForBreakPoints -> if isGoodBreakExpr e0 then tick_it else dont_tick_it
+ TickCallSites | isCallSite e0 -> tick_it
_other -> dont_tick_it
where
tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
- dont_tick_it = do e1 <- addTickHsExpr e0; return $ L pos e1
-
--- Add a tick to the expression no matter what it is. There is one exception:
--- for the debugger, if the expression is a 'let', then we don't want to add
--- a tick here because there will definititely be a tick on the body anyway.
-addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExprAlways (L pos e0) = do
+ dont_tick_it = addTickLHsExprNever e
+
+-- Add a tick to an expression which is the RHS of an equation or a binding.
+-- We always consider these to be breakpoints, unless the expression is a 'let'
+-- (because the body will definitely have a tick somewhere). ToDo: perhaps
+-- we should treat 'case' and 'if' the same way?
+addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprRHS e@(L pos e0) = do
d <- getDensity
case d of
- TickForBreakPoints | HsLet _ _ <- e0 -> dont_tick_it
- | otherwise -> tick_it
+ TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+ | otherwise -> tick_it
TickForCoverage -> tick_it
+ TickCallSites | isCallSite e0 -> tick_it
_other -> dont_tick_it
where
tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
- dont_tick_it = do e1 <- addTickHsExpr e0; return $ L pos e1
-
--- | A let body is ticked only if we're doing breakpoints. For coverage, the
--- whole let is ticked, so there's no need to tick the body.
+ dont_tick_it = addTickLHsExprNever e
+
+-- The inner expression of an evaluation context:
+-- let binds in [], ( [] )
+-- we never tick these if we're doing HPC, but otherwise
+-- we treat it like an ordinary expression.
+addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprEvalInner e = do
+ d <- getDensity
+ case d of
+ TickForCoverage -> addTickLHsExprNever e
+ _otherwise -> addTickLHsExpr e
+
+-- | A let body is treated differently from addTickLHsExprEvalInner
+-- above with TickForBreakPoints, because for breakpoints we always
+-- want to tick the body, even if it is not a redex. See test
+-- break012. This gives the user the opportunity to inspect the
+-- values of the let-bound variables.
addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExprLetBody e
- = ifDensity TickForBreakPoints
- (addTickLHsExprAlways e)
- (addTickLHsExprNever e)
+addTickLHsExprLetBody e@(L pos e0) = do
+ d <- getDensity
+ case d of
+ TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+ | otherwise -> tick_it
+ _other -> addTickLHsExprEvalInner e
+ where
+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+ dont_tick_it = addTickLHsExprNever e
-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by
@@ -369,14 +398,19 @@ isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {}) = True
isGoodBreakExpr (OpApp {}) = True
isGoodBreakExpr (NegApp {}) = True
-isGoodBreakExpr (HsCase {}) = True
isGoodBreakExpr (HsIf {}) = True
+isGoodBreakExpr (HsCase {}) = True
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {}) = True
isGoodBreakExpr (PArrSeq {}) = True
isGoodBreakExpr _other = False
+isCallSite :: HsExpr Id -> Bool
+isCallSite HsApp{} = True
+isCallSite OpApp{} = True
+isCallSite _ = False
+
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprOptAlt oneOfMany (L pos e0)
= ifDensity TickForCoverage
@@ -413,16 +447,14 @@ addTickHsExpr (NegApp e neg) =
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan neg)
addTickHsExpr (HsPar e) =
- liftM HsPar $
- ifDensity TickForCoverage (addTickLHsExprNever e)
- (addTickLHsExpr e)
-addTickHsExpr (SectionL e1 e2) =
+ liftM HsPar (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL e1 e2) =
liftM2 SectionL
(addTickLHsExpr e1)
- (addTickLHsExpr e2)
+ (addTickLHsExprNever e2)
addTickHsExpr (SectionR e1 e2) =
liftM2 SectionR
- (addTickLHsExpr e1)
+ (addTickLHsExprNever e1)
(addTickLHsExpr e2)
addTickHsExpr (ExplicitTuple es boxity) =
liftM2 ExplicitTuple
@@ -430,7 +462,8 @@ addTickHsExpr (ExplicitTuple es boxity) =
(return boxity)
addTickHsExpr (HsCase e mgs) =
liftM2 HsCase
- (addTickLHsExpr e)
+ (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
+ -- be evaluated.
(addTickMatchGroup False mgs)
addTickHsExpr (HsIf cnd e1 e2 e3) =
liftM3 (HsIf cnd)
@@ -551,7 +584,7 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
addTickHsExpr e0
_otherwise ->
- addTickLHsExprAlways expr
+ addTickLHsExprRHS expr
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts isGuard stmts = do
@@ -574,7 +607,7 @@ addTickStmt _isGuard (LastStmt e ret) = do
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
- (addTickLHsExprAlways e)
+ (addTickLHsExprRHS e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
@@ -598,8 +631,8 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
, trS_ret = returnExpr, trS_bind = bindExpr
, trS_fmap = liftMExpr }) = do
t_s <- addTickLStmts isGuard stmts
- t_y <- fmapMaybeM addTickLHsExprAlways by
- t_u <- addTickLHsExprAlways using
+ t_y <- fmapMaybeM addTickLHsExprRHS by
+ t_u <- addTickLHsExprRHS using
t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
@@ -616,7 +649,7 @@ addTickStmt isGuard stmt@(RecStmt {})
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
- | otherwise = addTickLHsExprAlways e
+ | otherwise = addTickLHsExprRHS e
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a)
-> TM ([LStmt Id], a)
@@ -987,7 +1020,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path =
cc_name | topOnly = head decl_path
| otherwise = concat (intersperse "." decl_path)
- cc = mkUserCC (mkFastString cc_name) (this_mod env)
+ cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c)
count = countEntries && dopt Opt_ProfCountEntries (dflags env)
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 8b41d3a2af..95645de5f2 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -309,10 +309,11 @@ dsExpr (ExplicitTuple tup_args boxity)
mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
(map (Type . exprType) args ++ args) }
-dsExpr (HsSCC cc expr) = do
+dsExpr (HsSCC cc expr@(L loc _)) = do
mod_name <- getModuleDs
count <- doptDs Opt_ProfCountEntries
- Tick (ProfNote (mkUserCC cc mod_name) count True) <$> dsLExpr expr
+ uniq <- newUnique
+ Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExpr expr
dsExpr (HsCoreAnn _ expr)
= dsLExpr expr
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index eb6ca87ba3..792421daa5 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -938,26 +938,31 @@ instance Binary IsCafCC where
_ -> do return NotCafCC
instance Binary CostCentre where
- put_ bh NoCostCentre = do
+ put_ bh (NormalCC aa ab ac _ad ae) = do
putByte bh 0
- put_ bh (NormalCC aa ab ac) = do
- putByte bh 1
put_ bh aa
put_ bh ab
put_ bh ac
- put_ bh (AllCafsCC ae) = do
- putByte bh 2
+ put_ bh ae
+ put_ bh (AllCafsCC ae _af) = do
+ putByte bh 1
put_ bh ae
get bh = do
h <- getByte bh
case h of
- 0 -> do return NoCostCentre
- 1 -> do aa <- get bh
+ 0 -> do aa <- get bh
ab <- get bh
ac <- get bh
- return (NormalCC aa ab ac)
+ ae <- get bh
+ return (NormalCC aa ab ac noSrcSpan ae)
_ -> do ae <- get bh
- return (AllCafsCC ae)
+ return (AllCafsCC ae noSrcSpan)
+
+ -- We ignore the SrcSpans in CostCentres when we serialise them,
+ -- and set the SrcSpans to noSrcSpan when deserialising. This is
+ -- ok, because we only need the SrcSpan when declaring the
+ -- CostCentre in the original module, it is not used by importing
+ -- modules.
-------------------------------------------------------------------------
-- IfaceTypes and friends
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 9d6d15c0df..947b320e97 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -589,6 +589,7 @@ data ProfAuto
| ProfAutoAll -- ^ top-level and nested functions are annotated
| ProfAutoTop -- ^ top-level functions annotated only
| ProfAutoExports -- ^ exported functions annotated only
+ | ProfAutoCalls -- ^ annotate call-sites
data Settings = Settings {
sTargetPlatform :: Platform, -- Filled in by SysTools
@@ -1637,6 +1638,7 @@ dynamic_flags = [
, Flag "fprof-auto" (noArg (\d -> d { profAuto = ProfAutoAll } ))
, Flag "fprof-auto-top" (noArg (\d -> d { profAuto = ProfAutoTop } ))
, Flag "fprof-auto-exported" (noArg (\d -> d { profAuto = ProfAutoExports } ))
+ , Flag "fprof-auto-calls" (noArg (\d -> d { profAuto = ProfAutoCalls } ))
, Flag "fno-prof-auto" (noArg (\d -> d { profAuto = NoProfAuto } ))
------ Compiler flags -----------------------------------------------
diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs
index 2a44121dfd..a4d7d1a398 100644
--- a/compiler/profiling/CostCentre.lhs
+++ b/compiler/profiling/CostCentre.lhs
@@ -15,7 +15,6 @@ module CostCentre (
CostCentreStack,
CollectedCCs,
noCCS, currentCCS, dontCareCCS,
- noCostCentre, noCCAttached,
noCCSAttached, isCurrentCCS,
maybeSingletonCCS,
@@ -25,6 +24,7 @@ module CostCentre (
pprCostCentreCore,
costCentreUserName, costCentreUserNameFS,
+ costCentreSrcSpan,
cmpCostCentre -- used for removing dups in a list
) where
@@ -35,6 +35,7 @@ import Module
import Unique
import Outputable
import FastTypes
+import SrcLoc
import FastString
import Util
@@ -43,20 +44,30 @@ import Data.Data
-----------------------------------------------------------------------------
-- Cost Centres
--- | A Cost Centre is the argument of an _scc_ expression.
+-- | A Cost Centre is a single @{-# SCC #-}@ annotation.
data CostCentre
- = NoCostCentre -- Having this constructor avoids having
- -- to use "Maybe CostCentre" all the time.
-
- | NormalCC {
- cc_name :: CcName, -- Name of the cost centre itself
- cc_mod :: Module, -- Name of module defining this CC.
+ = NormalCC {
+ cc_key :: {-# UNPACK #-} !Int,
+ -- ^ Two cost centres may have the same name and
+ -- module but different SrcSpans, so we need a way to
+ -- distinguish them easily and give them different
+ -- object-code labels. So every CostCentre has a
+ -- Unique that is distinct from every other
+ -- CostCentre in the same module.
+ --
+ -- XXX: should really be using Unique here, but we
+ -- need to derive Data below and there's no Data
+ -- instance for Unique.
+ cc_name :: CcName, -- ^ Name of the cost centre itself
+ cc_mod :: Module, -- ^ Name of module defining this CC.
+ cc_loc :: SrcSpan,
cc_is_caf :: IsCafCC -- see below
}
| AllCafsCC {
- cc_mod :: Module -- Name of module defining this CC.
+ cc_mod :: Module, -- Name of module defining this CC.
+ cc_loc :: SrcSpan
}
deriving (Data, Typeable)
@@ -65,9 +76,6 @@ type CcName = FastString
data IsCafCC = NotCafCC | CafCC
deriving (Eq, Ord, Data, Typeable)
-noCostCentre :: CostCentre
-noCostCentre = NoCostCentre
-
instance Eq CostCentre where
c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
@@ -80,10 +88,10 @@ cmpCostCentre :: CostCentre -> CostCentre -> Ordering
cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2})
= m1 `compare` m2
-cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
- (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
- -- first key is module name, then the name, then the cafness
- = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `compare` c2)
+cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1}
+ NormalCC {cc_key = n2, cc_mod = m2}
+ -- first key is module name, then the integer key
+ = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
cmpCostCentre other_1 other_2
= let
@@ -92,18 +100,17 @@ cmpCostCentre other_1 other_2
in
if tag1 <# tag2 then LT else GT
where
- tag_CC NoCostCentre = _ILIT(0)
- tag_CC (NormalCC {}) = _ILIT(1)
- tag_CC (AllCafsCC {}) = _ILIT(2)
+ tag_CC (NormalCC {}) = _ILIT(0)
+ tag_CC (AllCafsCC {}) = _ILIT(1)
-----------------------------------------------------------------------------
-- Predicates on CostCentre
isCafCC :: CostCentre -> Bool
-isCafCC (AllCafsCC {}) = True
+isCafCC (AllCafsCC {}) = True
isCafCC (NormalCC {cc_is_caf = CafCC}) = True
-isCafCC _ = False
+isCafCC _ = False
-- | Is this a cost-centre which records scc counts
isSccCountCC :: CostCentre -> Bool
@@ -112,7 +119,6 @@ isSccCountCC cc | isCafCC cc = False
-- | Is this a cost-centre which can be sccd ?
sccAbleCC :: CostCentre -> Bool
-sccAbleCC NoCostCentre = panic "sccAbleCC:NoCostCentre"
sccAbleCC cc | isCafCC cc = False
| otherwise = True
@@ -123,15 +129,17 @@ ccFromThisModule cc m = cc_mod cc == m
-----------------------------------------------------------------------------
-- Building cost centres
-mkUserCC :: FastString -> Module -> CostCentre
-mkUserCC cc_name mod
- = NormalCC { cc_name = cc_name, cc_mod = mod,
+mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre
+mkUserCC cc_name mod loc key
+ = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod = mod, cc_loc = loc,
cc_is_caf = NotCafCC {-might be changed-}
}
mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
mkAutoCC id mod is_caf
- = NormalCC { cc_name = str, cc_mod = mod,
+ = NormalCC { cc_key = getKey (getUnique id),
+ cc_name = str, cc_mod = mod,
+ cc_loc = nameSrcSpan (getName id),
cc_is_caf = is_caf
}
where
@@ -144,8 +152,8 @@ mkAutoCC id mod is_caf
| otherwise = mkFastString $ showSDoc $
ftext (occNameFS (getOccName id))
<> char '_' <> pprUnique (getUnique name)
-mkAllCafsCC :: Module -> CostCentre
-mkAllCafsCC m = AllCafsCC { cc_mod = m }
+mkAllCafsCC :: Module -> SrcSpan -> CostCentre
+mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
-----------------------------------------------------------------------------
-- Cost Centre Stacks
@@ -198,10 +206,6 @@ noCCSAttached :: CostCentreStack -> Bool
noCCSAttached NoCCS = True
noCCSAttached _ = False
-noCCAttached :: CostCentre -> Bool
-noCCAttached NoCostCentre = True
-noCCAttached _ = False
-
isCurrentCCS :: CostCentreStack -> Bool
isCurrentCCS CurrentCCS = True
isCurrentCCS _ = False
@@ -253,16 +257,15 @@ instance Outputable CostCentre where
-- Printing in Core
pprCostCentreCore :: CostCentre -> SDoc
-pprCostCentreCore NoCostCentre
- = text "__no_cc"
pprCostCentreCore (AllCafsCC {cc_mod = m})
= text "__sccC" <+> braces (ppr m)
-pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
+pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
cc_is_caf = caf})
= text "__scc" <+> braces (hsep [
- ftext (zEncodeFS n),
- ppr m,
- pp_caf caf
+ ppr m <> char '.' <> ftext n,
+ ifPprDebug (ppr key),
+ pp_caf caf,
+ ifPprDebug (ppr loc)
])
pp_caf :: IsCafCC -> SDoc
@@ -271,11 +274,11 @@ pp_caf _ = empty
-- Printing as a C label
ppCostCentreLbl :: CostCentre -> SDoc
-ppCostCentreLbl (NoCostCentre) = text "NONE_cc"
ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
-ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
- = ppr m <> char '_' <> ftext (zEncodeFS n) <>
- text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
+ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
+ cc_is_caf = is_caf})
+ = ppr m <> char '_' <> ftext (zEncodeFS n) <> char '_' <>
+ case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
-- This is the name to go in the user-displayed string,
-- recorded in the cost centre declaration
@@ -283,10 +286,12 @@ costCentreUserName :: CostCentre -> String
costCentreUserName = unpackFS . costCentreUserNameFS
costCentreUserNameFS :: CostCentre -> FastString
-costCentreUserNameFS (NoCostCentre) = mkFastString "NO_CC"
costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF"
costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
= case is_caf of
CafCC -> mkFastString "CAF:" `appendFS` name
_ -> name
+
+costCentreSrcSpan :: CostCentre -> SrcSpan
+costCentreSrcSpan = cc_loc
\end{code}
diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs
index 96a21eb056..6fc44c1df9 100644
--- a/compiler/profiling/SCCfinal.lhs
+++ b/compiler/profiling/SCCfinal.lhs
@@ -32,6 +32,8 @@ import UniqSupply ( UniqSupply )
import ListSetOps ( removeDups )
import Outputable
import DynFlags
+import FastString
+import SrcLoc
stgMassageForProfiling
@@ -60,7 +62,8 @@ stgMassageForProfiling dflags mod_name _us stg_binds
fixed_cc_stacks ++ cc_stacks), stg_binds2)
where
- all_cafs_cc = mkAllCafsCC mod_name
+ span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
+ all_cafs_cc = mkAllCafsCC mod_name span
all_cafs_ccs = mkSingletonCCS all_cafs_cc
----------
@@ -244,8 +247,7 @@ thenMM_ expr cont = MassageM $ \mod ccs ->
collectCC :: CostCentre -> MassageM ()
collectCC cc
= MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
- -> ASSERT(not (noCCAttached cc))
- if (cc `ccFromThisModule` mod_name) then
+ -> if (cc `ccFromThisModule` mod_name) then
((cc : local_ccs, extern_ccs, ccss), ())
else -- must declare it "extern"
((local_ccs, cc : extern_ccs, ccss), ())
diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml
index eea6f86fa2..d09a794b11 100644
--- a/docs/users_guide/ghci.xml
+++ b/docs/users_guide/ghci.xml
@@ -1659,7 +1659,8 @@ a :: a
particular call to <literal>head</literal> in your program resulted in
the error can be a painstaking process, usually involving
<literal>Debug.Trace.trace</literal>, or compiling with
- profiling and using <literal>+RTS -xc</literal> (see <xref
+ profiling and using <literal>Debug.Trace.traceStack</literal>
+ or <literal>+RTS -xc</literal> (see <xref
linkend="prof-time-options" />).</para>
<para>The GHCi debugger offers a way to hopefully shed some light on
diff --git a/docs/users_guide/profiling.xml b/docs/users_guide/profiling.xml
index ee3b387e31..25db08045a 100644
--- a/docs/users_guide/profiling.xml
+++ b/docs/users_guide/profiling.xml
@@ -437,6 +437,24 @@ MAIN MAIN 102 0 0.0 0.0 100.0 1
<varlistentry>
<term>
+ <option>-fprof-auto-calls</option>:
+ <indexterm><primary><option>-fprof-auto-calls</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Adds an automatic <literal>SCC</literal> annotation to
+ all <emphasis>call sites</emphasis>. This is particularly
+ useful when using profiling for the purposes of generating
+ stack traces; see the
+ function <literal>traceStack</literal> in the
+ module <literal>Debug.Trace</literal>, or
+ the <literal>-xc</literal> RTS flag
+ (<xref linkend="rts-options-debugging" />) for more
+ details.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
<option>-fprof-cafs</option>:
<indexterm><primary><option>-fprof-cafs</option></primary></indexterm>
</term>
diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml
index 793ceec46b..7b2b469a0a 100644
--- a/docs/users_guide/runtime_control.xml
+++ b/docs/users_guide/runtime_control.xml
@@ -1290,7 +1290,7 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar
<listitem>
<para>(Only available when the program is compiled for
profiling.) When an exception is raised in the program,
- this option causes the current cost-centre-stack to be
+ this option causes a stack trace to be
dumped to <literal>stderr</literal>.</para>
<para>This can be particularly useful for debugging: if your
@@ -1337,6 +1337,12 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar
<para>Implementation details aside, the function names in
the stack should hopefully give you enough clues to track
down the bug.</para>
+
+ <para>
+ See also the function <literal>traceStack</literal> in the
+ module <literal>Debug.Trace</literal> for another way to
+ view call stacks.
+ </para>
</listitem>
</varlistentry>
diff --git a/includes/rts/prof/CCS.h b/includes/rts/prof/CCS.h
index 9737fc9c18..36404aaf91 100644
--- a/includes/rts/prof/CCS.h
+++ b/includes/rts/prof/CCS.h
@@ -34,6 +34,7 @@ typedef struct _CostCentre {
char * label;
char * module;
+ char * srcloc;
// used for accumulating costs at the end of the run...
StgWord time_ticks;
@@ -203,11 +204,12 @@ extern CostCentreStack * RTS_VAR(CCS_LIST); // registered CCS list
* Declaring Cost Centres & Cost Centre Stacks.
* -------------------------------------------------------------------------- */
-# define CC_DECLARE(cc_ident,name,mod,caf,is_local) \
+# define CC_DECLARE(cc_ident,name,mod,loc,caf,is_local) \
is_local CostCentre cc_ident[1] \
= {{ ccID : 0, \
label : name, \
module : mod, \
+ srcloc : loc, \
time_ticks : 0, \
mem_alloc : 0, \
link : 0, \
diff --git a/rts/Profiling.c b/rts/Profiling.c
index 7fb7f9e3cf..ed374b562f 100644
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -87,13 +87,13 @@ Mutex ccs_mutex;
* traverse pinned memory.
*/
-CC_DECLARE(CC_MAIN, "MAIN", "MAIN", CC_NOT_CAF, );
-CC_DECLARE(CC_SYSTEM, "SYSTEM", "SYSTEM", CC_NOT_CAF, );
-CC_DECLARE(CC_GC, "GC", "GC", CC_NOT_CAF, );
-CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", CC_NOT_CAF, );
-CC_DECLARE(CC_DONT_CARE, "DONT_CARE", "MAIN", CC_NOT_CAF, );
-CC_DECLARE(CC_PINNED, "PINNED", "SYSTEM", CC_NOT_CAF, );
-CC_DECLARE(CC_IDLE, "IDLE", "IDLE", CC_NOT_CAF, );
+CC_DECLARE(CC_MAIN, "MAIN", "MAIN", "<built-in>", CC_NOT_CAF, );
+CC_DECLARE(CC_SYSTEM, "SYSTEM", "SYSTEM", "<built-in>", CC_NOT_CAF, );
+CC_DECLARE(CC_GC, "GC", "GC", "<built-in>", CC_NOT_CAF, );
+CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", "<built-in>", CC_NOT_CAF, );
+CC_DECLARE(CC_DONT_CARE, "DONT_CARE", "MAIN", "<built-in>", CC_NOT_CAF, );
+CC_DECLARE(CC_PINNED, "PINNED", "SYSTEM", "<built-in>", CC_NOT_CAF, );
+CC_DECLARE(CC_IDLE, "IDLE", "IDLE", "<built-in>", CC_NOT_CAF, );
CCS_DECLARE(CCS_MAIN, CC_MAIN, );
CCS_DECLARE(CCS_SYSTEM, CC_SYSTEM, );
View Lorry Controller Status