X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgProf.hs;h=7750c0f08ef8861bcd0f42f02be6909794ecf24b;hp=bc5473a6e53b5bd18c650f237ed60e1679bb3f0a;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=49c98d143c382a1341e1046f5ca00819a25691ba

diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index bc5473a..7750c0f 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -20,7 +20,7 @@ module CgProf (
 	emitSetCCC, emitCCS,
 
 	-- Lag/drag/void stuff
-	ldvEnter, ldvRecordCreate
+	ldvEnter, ldvEnterClosure, ldvRecordCreate
   ) where
 
 #include "HsVersions.h"
@@ -38,7 +38,6 @@ import CgMonad
 import SMRep
 
 import Cmm
-import MachOp
 import CmmUtils
 import CLabel
 
@@ -51,7 +50,6 @@ import FastString
 import Constants	-- Lots of field offsets
 import Outputable
 
-import Data.Maybe
 import Data.Char
 import Control.Monad
 
@@ -63,11 +61,11 @@ import Control.Monad
 
 -- Expression representing the current cost centre stack
 curCCS :: CmmExpr
-curCCS = CmmLoad curCCSAddr wordRep
+curCCS = CmmLoad curCCSAddr bWord
 
 -- Address of current CCS variable, for storing into
 curCCSAddr :: CmmExpr
-curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS")))
+curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS")))
 
 mkCCostCentre :: CostCentre -> CmmLit
 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
@@ -77,7 +75,7 @@ mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
 
 costCentreFrom :: CmmExpr 	-- A closure pointer
 	       -> CmmExpr	-- The cost centre from that closure
-costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) wordRep
+costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord
 
 staticProfHdr :: CostCentreStack -> [CmmLit]
 -- The profiling header words in a static closure
@@ -115,13 +113,13 @@ profAlloc words ccs
   = ifProfiling $
     stmtC (addToMemE alloc_rep
 		(cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
-	  	(CmmMachOp (MO_U_Conv wordRep alloc_rep) $
+	  	(CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
 		  [CmmMachOp mo_wordSub [words, 
 					 CmmLit (mkIntCLit profHdrSize)]]))
 		-- subtract the "profiling overhead", which is the
 		-- profiling header in a closure.
  where 
-	alloc_rep =  REP_CostCentreStack_mem_alloc
+   alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
 
 -- ----------------------------------------------------------------------
 -- Setting the cost centre in a new closure
@@ -155,9 +153,9 @@ emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
 
 	push_em ccs [] = return ccs
 	push_em ccs (cc:rest) = do
-  	  tmp <- newTemp wordRep
+  	  tmp <- newTemp bWord -- TODO FIXME NOW
 	  pushCostCentre tmp ccs cc
-	  push_em (CmmReg tmp) rest
+	  push_em (CmmReg (CmmLocal tmp)) rest
 
 ccsExpr :: CostCentreStack -> CmmExpr
 ccsExpr ccs
@@ -170,8 +168,8 @@ isBox :: StgExpr -> Bool
 -- one introduced by boxHigherOrderArgs for profiling,
 -- so we charge it to "OVERHEAD".
 -- This looks like a GROSS HACK to me --SDM
-isBox (StgApp fun []) = True
-isBox other	      = False
+isBox (StgApp _ []) = True
+isBox _             = False
 
 
 -- -----------------------------------------------------------------------
@@ -202,6 +200,7 @@ enterCostCentre closure_info ccs body
     ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
     enter_cost_centre closure_info ccs body
 
+enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> Code
 enter_cost_centre closure_info ccs body
   | isSubsumedCCS ccs
   = ASSERT(isToplevClosure closure_info)
@@ -242,9 +241,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 = 
@@ -257,9 +259,11 @@ enterCostCentreThunk closure =
   ifProfiling $ do 
     stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
 
-enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
+enter_ccs_fun :: CmmExpr -> Code
+enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [CmmHinted stack AddrHint] False
 			-- ToDo: vols
 
+enter_ccs_fsub :: Code
 enter_ccs_fsub = enteringPAP 0
 
 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
@@ -269,8 +273,8 @@ enter_ccs_fsub = enteringPAP 0
 -- entering via a PAP.
 enteringPAP :: Integer -> Code
 enteringPAP n
-  = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
-		(CmmLit (CmmInt n cIntRep)))
+  = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP"))))
+		(CmmLit (CmmInt n cIntWidth)))
 
 ifProfiling :: Code -> Code
 ifProfiling code
@@ -329,8 +333,10 @@ emitCostCentreStackDecl ccs
   }
   | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
 
+zero :: CmmLit
 zero = mkIntCLit 0
-zero64 = CmmInt 0 I64
+zero64 :: CmmLit
+zero64 = CmmInt 0 W64
 
 sizeof_ccs_words :: Int
 sizeof_ccs_words 
@@ -349,14 +355,14 @@ sizeof_ccs_words
 
 emitRegisterCC :: CostCentre -> Code
 emitRegisterCC cc = do
-  { tmp <- newTemp cIntRep
+  { tmp <- newTemp cInt
   ; stmtsC [
      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
-		 (CmmLoad cC_LIST wordRep),
+		 (CmmLoad cC_LIST bWord),
      CmmStore cC_LIST cc_lit,
-     CmmAssign tmp (CmmLoad cC_ID cIntRep),
-     CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
-     CmmStore cC_ID (cmmRegOffB tmp 1)
+     CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
+     CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
+     CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
    ]
   }
   where
@@ -368,25 +374,27 @@ emitRegisterCC cc = do
 
 emitRegisterCCS :: CostCentreStack -> Code
 emitRegisterCCS ccs = do
-  { tmp <- newTemp cIntRep
+  { tmp <- newTemp cInt
   ; stmtsC [
      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) 
-			(CmmLoad cCS_LIST wordRep),
+			(CmmLoad cCS_LIST bWord),
      CmmStore cCS_LIST ccs_lit,
-     CmmAssign tmp (CmmLoad cCS_ID cIntRep),
-     CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
-     CmmStore cCS_ID (cmmRegOffB tmp 1)
+     CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
+     CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
+     CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
    ]
   }
   where
     ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
 
 
-cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
-cC_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
+cC_LIST, cC_ID :: CmmExpr
+cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST")))
+cC_ID   = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID")))
 
-cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
-cCS_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
+cCS_LIST, cCS_ID :: CmmExpr
+cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST")))
+cCS_ID   = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID")))
 
 -- ---------------------------------------------------------------------------
 -- Set the current cost centre stack
@@ -395,22 +403,23 @@ emitSetCCC :: CostCentre -> Code
 emitSetCCC cc
   | not opt_SccProfilingOn = nopC
   | otherwise = do 
-    tmp <- newTemp wordRep
+    tmp <- newTemp bWord -- TODO FIXME NOW
     ASSERT( sccAbleCostCentre cc )
       pushCostCentre tmp curCCS cc
-    stmtC (CmmStore curCCSAddr (CmmReg tmp))
+    stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp)))
     when (isSccCountCostCentre cc) $ 
 	stmtC (bumpSccCount curCCS)
 
-pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
+pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
 pushCostCentre result ccs cc
-  = emitRtsCallWithResult result PtrHint
-	SLIT("PushCostCentre") [(ccs,PtrHint), 
-				(CmmLit (mkCCostCentre cc), PtrHint)]
+  = emitRtsCallWithResult result AddrHint
+	(sLit "PushCostCentre") [CmmHinted ccs AddrHint, 
+				 CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
+        False
 
 bumpSccCount :: CmmExpr -> CmmStmt
 bumpSccCount ccs
-  = addToMem REP_CostCentreStack_scc_count
+  = addToMem (typeWidth REP_CostCentreStack_scc_count)
 	 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
 
 -----------------------------------------------------------------------------
@@ -447,9 +456,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) |
@@ -457,14 +471,15 @@ 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)
+    new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
 				       (CmmLit (mkWordCLit lDV_CREATE_MASK)))
 		 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
 
 loadEra :: CmmExpr 
-loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
-	  [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
+loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
+	  [CmmLoad (mkLblExpr (mkRtsDataLabel $ sLit("era"))) cInt]
 
 ldvWord :: CmmExpr -> CmmExpr
 -- Takes the address of a closure, and returns 
@@ -472,10 +487,16 @@ ldvWord :: CmmExpr -> CmmExpr
 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
 
 -- LDV constants, from ghc/includes/Constants.h
-lDV_SHIFT	 = (LDV_SHIFT :: Int)
---lDV_STATE_MASK   = (LDV_STATE_MASK :: StgWord)
-lDV_CREATE_MASK  = (LDV_CREATE_MASK :: StgWord)
---lDV_LAST_MASK    = (LDV_LAST_MASK :: StgWord)
-lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
-lDV_STATE_USE    = (LDV_STATE_USE :: StgWord)
+lDV_SHIFT :: Int
+lDV_SHIFT = LDV_SHIFT
+--lDV_STATE_MASK :: StgWord
+--lDV_STATE_MASK   = LDV_STATE_MASK
+lDV_CREATE_MASK :: StgWord
+lDV_CREATE_MASK  = LDV_CREATE_MASK
+--lDV_LAST_MASK    :: StgWord
+--lDV_LAST_MASK    = LDV_LAST_MASK
+lDV_STATE_CREATE :: StgWord
+lDV_STATE_CREATE = LDV_STATE_CREATE
+lDV_STATE_USE    :: StgWord
+lDV_STATE_USE    = LDV_STATE_USE