-{-# 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
import SMRep
import Cmm
-import MachOp
import CmmUtils
import CLabel
import Constants -- Lots of field offsets
import Outputable
-import Data.Maybe
import Data.Char
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)
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
= 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
push_em ccs [] = return ccs
push_em ccs (cc:rest) = do
- tmp <- newNonPtrTemp wordRep -- TODO FIXME NOW
+ tmp <- newTemp bWord -- TODO FIXME NOW
pushCostCentre tmp ccs cc
push_em (CmmReg (CmmLocal tmp)) rest
-- 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
-- -----------------------------------------------------------------------
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)
ifProfiling $ do
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
-enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False
+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
-- 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
}
| 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
emitRegisterCC :: CostCentre -> Code
emitRegisterCC cc = do
- { tmp <- newNonPtrTemp 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 (CmmLocal tmp) (CmmLoad cC_ID cIntRep),
+ CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
]
emitRegisterCCS :: CostCentreStack -> Code
emitRegisterCCS ccs = do
- { tmp <- newNonPtrTemp 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 (CmmLocal tmp) (CmmLoad cCS_ID cIntRep),
+ CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
]
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
emitSetCCC cc
| not opt_SccProfilingOn = nopC
| otherwise = do
- tmp <- newNonPtrTemp wordRep -- TODO FIXME NOW
+ tmp <- newTemp bWord -- TODO FIXME NOW
ASSERT( sccAbleCostCentre cc )
pushCostCentre tmp curCCS cc
stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp)))
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
-----------------------------------------------------------------------------
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
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
projects / ghc-hetmet.git / blobdiff