Cleanup and fixes to profiling

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