Commit 1469f1eb authored by Simon Marlow's avatar Simon Marlow
Browse files

More changes aimed at improving call stacks.

  - Attach a SrcSpan to every CostCentre.  This had the side effect
    that CostCentres that used to be merged because they had the same
    name are now considered distinct; so I had to add a Unique to
    CostCentre to give them distinct object-code symbols.

  - New flag: -fprof-auto-calls.  This flag adds an automatic SCC to
    every call site (application, to be precise).  This is typically
    more useful for call stacks than annotating whole functions.

Various tidy-ups at the same time: removed unused NoCostCentre
constructor, and refactored a bit in Coverage.lhs.

The call stack we get from traceStack now looks like this:

Stack trace:
  Main.CAF (<entire-module>)
  Main.main.xs (callstack002.hs:18:12-24)
  Main.map (callstack002.hs:13:12-16)
  Main.map.go (callstack002.hs:15:21-34)
  Main.map.go (callstack002.hs:15:21-23)
  Main.f (callstack002.hs:10:7-43)
parent 6f4bde14
......@@ -56,9 +56,9 @@ module Unique (
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkCostCentreUnique,
mkBuiltinUnique,
mkPseudoUniqueC,
mkPseudoUniqueD,
mkPseudoUniqueE,
mkPseudoUniqueH
......@@ -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))
......
......@@ -170,10 +170,14 @@ 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,
loc, -- char *srcloc,
zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
is_caf, -- StgInt is_caf
......
......@@ -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,
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
......
......@@ -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
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)
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)
......
......@@ -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
......
......@@ -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
......
......@@ -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 -----------------------------------------------
......
......@@ -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,9 +100,8 @@ 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)
-----------------------------------------------------------------------------
......@@ -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}
......@@ -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), ())
......
......@@ -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
......
......@@ -435,6 +435,24 @@ MAIN MAIN 102 0 0.0 0.0 100.0 1
</listitem>
</varlistentry>
<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>:
......
......@@ -1290,7 +1290,7 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar
<listitem>