X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcodeGen%2FCgProf.hs;h=39d4505feea9075c14bb576a4bd3d44fa672d860;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hp=27ee54c50d24b8c3fcb505739551e1def71b2cce;hpb=d31dfb32ea936c22628b508c28a36c12e631430a;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 27ee54c..39d4505 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -6,6 +6,13 @@
 --
 -----------------------------------------------------------------------------
 
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
 module CgProf (
 	mkCCostCentre, mkCCostCentreStack,
 
@@ -20,7 +27,7 @@ module CgProf (
 	emitSetCCC, emitCCS,
 
 	-- Lag/drag/void stuff
-	ldvEnter, ldvRecordCreate
+	ldvEnter, ldvEnterClosure, ldvRecordCreate
   ) where
 
 #include "HsVersions.h"
@@ -242,9 +249,12 @@ enter_cost_centre closure_info ccs body
   where
     enc_ccs    = CmmLit (mkCCostCentreStack ccs)
     re_entrant = closureReEntrant closure_info
-    node_ccs   = costCentreFrom (CmmReg nodeReg)
+    node_ccs   = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
     is_box     = isBox body
 
+    -- if this is a function, then node will be tagged; we must subract the tag
+    node_tag = funTag closure_info
+
 -- set the current CCS when entering a PAP
 enterCostCentrePAP :: CmmExpr -> Code
 enterCostCentrePAP closure = 
@@ -448,9 +458,14 @@ ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 -- profiling.
 --
+ldvEnterClosure :: ClosureInfo -> Code
+ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
+  where tag = funTag closure_info
+        -- don't forget to substract node's tag
+  
 ldvEnter :: CmmExpr -> Code
 -- Argument is a closure pointer
-ldvEnter cl_ptr 
+ldvEnter cl_ptr
   =  ifProfiling $
      -- if (era > 0) {
      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -458,6 +473,7 @@ ldvEnter cl_ptr
     emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
 	   (stmtC (CmmStore ldv_wd new_ldv_wd))
   where
+        -- don't forget to substract node's tag
     ldv_wd = ldvWord cl_ptr
     new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
 				       (CmmLit (mkWordCLit lDV_CREATE_MASK)))