+{-# 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/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- Code generation for profiling
--
--- (c) The University of Glasgow 2004
+-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
emitSetCCC, emitCCS,
-- Lag/drag/void stuff
- ldvEnter, ldvRecordCreate
+ ldvEnter, ldvEnterClosure, ldvRecordCreate
) where
#include "HsVersions.h"
#include "../includes/DerivedConstants.h"
-- For REP_xxx constants, which are MachReps
-import ClosureInfo ( ClosureInfo, closureSize,
- closureName, isToplevClosure, closureReEntrant, )
+import ClosureInfo
import CgUtils
import CgMonad
-import SMRep ( StgWord, profHdrSize )
+import SMRep
import Cmm
import MachOp
-import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
-import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel )
+import CmmUtils
+import CLabel
-import Module ( pprModule )
-import Id ( Id )
+import Id
+import qualified Module
import CostCentre
-import StgSyn ( GenStgExpr(..), StgExpr )
-import StaticFlags ( opt_SccProfilingOn )
-import FastString ( FastString )
+import StgSyn
+import StaticFlags
+import FastString
import Constants -- Lots of field offsets
import Outputable
-import Maybe
-import Char ( ord )
-import Monad ( when )
+import Data.Maybe
+import Data.Char
+import Control.Monad
-----------------------------------------------------------------------------
--
-- 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)
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
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 =
ifProfiling $ do
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
-enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
+enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [CmmKinded stack PtrHint] False
-- ToDo: vols
enter_ccs_fsub = enteringPAP 0
-- entering via a PAP.
enteringPAP :: Integer -> Code
enteringPAP n
- = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
+ = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP"))))
(CmmLit (CmmInt n cIntRep)))
ifProfiling :: Code -> Code
-> Code
emitCostCentreDecl cc = do
{ label <- mkStringCLit (costCentreUserName cc)
- ; modl <- mkStringCLit (moduleString (cc_mod cc))
+ ; modl <- mkStringCLit (Module.moduleNameString
+ (Module.moduleName (cc_mod cc)))
+ -- 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,
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
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
ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
-cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
-cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
+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 = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST")))
+cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID")))
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
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)]
+ (sLit "PushCostCentre") [CmmKinded ccs PtrHint,
+ CmmKinded (CmmLit (mkCCostCentre cc)) PtrHint]
+ False
bumpSccCount :: CmmExpr -> CmmStmt
bumpSccCount ccs
-- 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) |
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)))
loadEra :: CmmExpr
loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
- [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
+ [CmmLoad (mkLblExpr (mkRtsDataLabel (sLit "era"))) cIntRep]
ldvWord :: CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns