Commit ddd6af07 authored by Simon Marlow's avatar Simon Marlow
Browse files

Cleanup and fixes to profiling

parent 149e04b3
......@@ -427,6 +427,10 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
node_points = nodeMustPointToIt dflags lf_info
node' = if node_points then Just node else Nothing
; tickyEnterFun cl_info
; enterCostCentreFun cc
(CmmMachOp mo_wordSub
[ CmmReg nodeReg
, CmmLit (mkIntCLit (funTag cl_info)) ])
; whenC node_points (ldvEnterClosure cl_info)
; granYield arg_regs node_points
......@@ -670,7 +674,7 @@ link_caf _is_upd = do
[ (CmmReg (CmmGlobal BaseReg), AddrHint),
(CmmReg nodeReg, AddrHint),
(hp_rel, AddrHint) ]
(Just [node]) False
False
-- node is live, so save it.
-- see Note [atomic CAF entry] in rts/sm/Storage.c
......
......@@ -19,7 +19,7 @@ module StgCmmProf (
-- Cost-centre Profiling
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
enterCostCentreThunk,
enterCostCentreThunk, enterCostCentreFun,
costCentreFrom,
curCCS, storeCurCCS,
emitSetCCC,
......@@ -190,6 +190,15 @@ enterCostCentreThunk closure =
ifProfiling $ do
emit $ storeCurCCS (costCentreFrom closure)
enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
enterCostCentreFun ccs closure =
ifProfiling $ do
if isCurrentCCS ccs
then emitRtsCall rtsPackageId (fsLit "enterFunCCS")
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(costCentreFrom closure, AddrHint)] False
else return () -- top-level function, nothing to do
ifProfiling :: FCode () -> FCode ()
ifProfiling code
= do dflags <- getDynFlags
......@@ -224,20 +233,19 @@ emitCostCentreDecl cc = do
$ Module.moduleName
$ cc_mod cc)
; dflags <- getDynFlags
; loc <- newStringCLit (showPpr dflags (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,
zero64, -- StgWord64 mem_alloc
zero, -- StgWord time_ticks
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
]
; loc <- newByteStringCLit $ bytesFS $ mkFastString $
showPpr dflags (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,
zero64, -- StgWord64 mem_alloc
zero, -- StgWord time_ticks
is_caf, -- StgInt is_caf
zero -- struct _CostCentre *link
]
; emitDataLits (mkCCLabel cc) lits
}
where
......@@ -289,7 +297,7 @@ pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
rtsPackageId
(fsLit "PushCostCentre") [(ccs,AddrHint),
(fsLit "pushCostCentre") [(ccs,AddrHint),
(CmmLit (mkCCostCentre cc), AddrHint)]
False
......
......@@ -17,7 +17,7 @@ module StgCmmUtils (
cgLit, mkSimpleLit,
emitDataLits, mkDataLits,
emitRODataLits, mkRODataLits,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, emitRtsCallGen,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
assignTemp, newTemp,
newUnboxedTupleRegs,
......@@ -179,17 +179,12 @@ tagToClosure tycon tag
-------------------------------------------------------------------------
emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args Nothing safe
-- The 'Nothing' says "save all global registers"
emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
emitRtsCallWithVols pkg fun args vols safe
= emitRtsCallGen [] pkg fun args (Just vols) safe
emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe
emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCallGen [(res,hint)] pkg fun args Nothing safe
= emitRtsCallGen [(res,hint)] pkg fun args safe
-- Make a call to an RTS C procedure
emitRtsCallGen
......@@ -197,10 +192,9 @@ emitRtsCallGen
-> PackageId
-> FastString
-> [(CmmExpr,ForeignHint)]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
-> FCode ()
emitRtsCallGen res pkg fun args _vols safe
emitRtsCallGen res pkg fun args safe
= do { dflags <- getDynFlags
; updfr_off <- getUpdFrameOff
; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment