Use OPTIONS rather than OPTIONS_GHC for pragmas

[ghc-hetmet.git] / compiler / codeGen / CgProf.hs

diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index bc5473a..39d4505 100644 (file)
--- 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"
@@ -155,9 +162,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 <- newNonPtrTemp wordRep -- TODO FIXME NOW
          pushCostCentre tmp ccs cc
-         push_em (CmmReg tmp) rest
+         push_em (CmmReg (CmmLocal tmp)) rest
 
 ccsExpr :: CostCentreStack -> CmmExpr
 ccsExpr ccs
@@ -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 = 
@@ -257,7 +267,7 @@ enterCostCentreThunk closure =
   ifProfiling $ do 
     stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
 
-enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
+enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False
                        -- ToDo: vols
 
 enter_ccs_fsub = enteringPAP 0
@@ -349,14 +359,14 @@ sizeof_ccs_words
 
 emitRegisterCC :: CostCentre -> Code
 emitRegisterCC cc = do
-  { tmp <- newTemp cIntRep
+  { tmp <- newNonPtrTemp cIntRep
   ; stmtsC [
      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
                 (CmmLoad cC_LIST wordRep),
      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 cIntRep),
+     CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
+     CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
    ]
   }
   where
@@ -368,14 +378,14 @@ emitRegisterCC cc = do
 
 emitRegisterCCS :: CostCentreStack -> Code
 emitRegisterCCS ccs = do
-  { tmp <- newTemp cIntRep
+  { tmp <- newNonPtrTemp cIntRep
   ; stmtsC [
      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) 
                        (CmmLoad cCS_LIST wordRep),
      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 cIntRep),
+     CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
+     CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
    ]
   }
   where
@@ -395,18 +405,19 @@ emitSetCCC :: CostCentre -> Code
 emitSetCCC cc
   | not opt_SccProfilingOn = nopC
   | otherwise = do 
-    tmp <- newTemp wordRep
+    tmp <- newNonPtrTemp wordRep -- 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)]
+        False
 
 bumpSccCount :: CmmExpr -> CmmStmt
 bumpSccCount ccs
@@ -447,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) |
@@ -457,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)))