diff options
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 6 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 40 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 14 |
3 files changed, 33 insertions, 27 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 2c102b2140..ec804dec1e 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -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 diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 5031693cc5..0577c514ea 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -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 diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index af2b0203ec..13c8eccb9a 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -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 |