X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgProf.hs;h=0cf209e89cfe26d41fd809a39348914449aa9e6a;hp=1488e34956ddafd3096c2c3c71f58444fd84bd86;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 1488e34..0cf209e 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -2,7 +2,7 @@ -- -- Code generation for profiling -- --- (c) The University of Glasgow 2004 +-- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- @@ -20,41 +20,39 @@ module CgProf ( emitSetCCC, emitCCS, -- Lag/drag/void stuff - ldvEnter, ldvRecordCreate + ldvEnter, ldvEnterClosure, ldvRecordCreate ) where #include "HsVersions.h" -#include "MachDeps.h" +#include "../includes/MachDeps.h" -- For WORD_SIZE_IN_BITS only. -#include "../includes/Constants.h" +#include "../includes/rts/Constants.h" -- For LDV_CREATE_MASK, LDV_STATE_USE -- which are StgWords #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 OldCmm +import OldCmmUtils +import CLabel -import Module ( moduleString ) -import Id ( Id ) +import Id +import qualified Module import CostCentre -import StgSyn ( GenStgExpr(..), StgExpr ) -import StaticFlags ( opt_SccProfilingOn ) -import FastString ( FastString, mkFastString, LitString ) +import StgSyn +import StaticFlags +import FastString +import Module import Constants -- Lots of field offsets import Outputable -import Maybe -import Char ( ord ) -import Monad ( when ) +import Data.Char +import Control.Monad ----------------------------------------------------------------------------- -- @@ -64,11 +62,11 @@ import Monad ( when ) -- 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 (mkCmmDataLabel rtsPackageId (fsLit "CCCS"))) mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -78,7 +76,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 @@ -116,13 +114,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 @@ -156,9 +154,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 @@ -171,8 +169,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 -- ----------------------------------------------------------------------- @@ -203,6 +201,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) @@ -243,9 +242,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 = @@ -258,9 +260,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 rtsPackageId (fsLit "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 @@ -270,8 +274,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 (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP")))) + (CmmLit (CmmInt n cIntWidth))) ifProfiling :: Code -> Code ifProfiling code @@ -292,7 +296,11 @@ emitCostCentreDecl -> 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, @@ -326,8 +334,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 @@ -346,14 +356,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 @@ -365,25 +375,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 (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) +cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "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 (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) +cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -392,22 +404,24 @@ 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 + rtsPackageId + (fsLit "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 ----------------------------------------------------------------------------- @@ -444,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) | @@ -454,14 +473,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 (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] ldvWord :: CmmExpr -> CmmExpr -- Takes the address of a closure, and returns @@ -469,10 +489,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