X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmProf.hs;h=08bf52952c092944514c9d5847d14974fd3223d4;hb=417f4d59739cc478ca47d081c22d7b0a928c4e95;hp=f442295d25eadad020b20f3d5e4ab834aa586131;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69;p=ghc-hetmet.git diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index f442295..08bf529 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -1,6 +1,3 @@ -{-# OPTIONS -w #-} --- Lots of missing type sigs etc - ----------------------------------------------------------------------------- -- -- Code generation for profiling @@ -28,9 +25,9 @@ module StgCmmProf ( ) 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" @@ -41,9 +38,9 @@ import StgCmmUtils import StgCmmMonad import SMRep -import MkZipCfgCmm -import Cmm -import TyCon ( PrimRep(..) ) +import MkGraph +import CmmExpr +import CmmDecl import CmmUtils import CLabel @@ -53,10 +50,10 @@ import CostCentre import StgSyn import StaticFlags import FastString +import Module import Constants -- Lots of field offsets import Outputable -import Data.Maybe import Data.Char import Control.Monad @@ -78,7 +75,7 @@ curCCS = CmmLoad curCCSAddr ccsType -- 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) @@ -185,10 +182,10 @@ profAlloc words ccs -- Setting the cost centre in a new closure chooseDynCostCentres :: CostCentreStack - -> [Id] -- Args + -> [Id] -- Args -> StgExpr -- Body -> FCode (CmmExpr, CmmExpr) --- Called when alllcating a closure +-- Called when allocating a closure -- Tells which cost centre to put in the object, and which -- to blame the cost of allocation on chooseDynCostCentres ccs args body = do @@ -228,8 +225,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 -- ----------------------------------------------------------------------- @@ -260,6 +257,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 -> FCode () enter_cost_centre closure_info ccs body | isSubsumedCCS ccs = ASSERT(isToplevClosure closure_info) @@ -318,9 +316,11 @@ enterCostCentreThunk closure = ifProfiling $ do emit $ mkStore curCCSAddr (costCentreFrom closure) -enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [(stack,AddrHint)] False +enter_ccs_fun :: CmmExpr -> FCode () +enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [(stack,AddrHint)] False -- ToDo: vols +enter_ccs_fsub :: FCode () enter_ccs_fsub = enteringPAP 0 -- When entering a PAP, EnterFunCCS is called by both the PAP entry @@ -330,7 +330,7 @@ enter_ccs_fsub = enteringPAP 0 -- entering via a PAP. enteringPAP :: Integer -> FCode () enteringPAP n - = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP")))) + = emit (mkStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP")))) (CmmLit (CmmInt n cIntWidth))) ifProfiling :: FCode () -> FCode () @@ -348,14 +348,12 @@ ifProfilingL xs -- Initialising Cost Centres & CCSs --------------------------------------------------------------- -initCostCentres :: CollectedCCs -> FCode CmmAGraph --- Emit the declarations, and return code to register them +initCostCentres :: CollectedCCs -> FCode () +-- Emit the declarations initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = getCode $ whenC opt_SccProfilingOn $ + = whenC opt_SccProfilingOn $ do { mapM_ emitCostCentreDecl local_CCs - ; mapM_ emitCostCentreStackDecl singleton_CCSs - ; emit $ catAGraphs $ map mkRegisterCC local_CCs - ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs } + ; mapM_ emitCostCentreStackDecl singleton_CCSs } emitCostCentreDecl :: CostCentre -> FCode () @@ -395,7 +393,9 @@ emitCostCentreStackDecl ccs -- pad out the struct with zero words until we hit the -- size of the overall struct (which we get via DerivedConstants.h) +zero :: CmmLit zero = mkIntCLit 0 +zero64 :: CmmLit zero64 = CmmInt 0 W64 sizeof_ccs_words :: Int @@ -407,52 +407,6 @@ sizeof_ccs_words (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE -- --------------------------------------------------------------------------- --- Registering CCs and CCSs - --- (cc)->link = CC_LIST; --- CC_LIST = (cc); --- (cc)->ccID = CC_ID++; - -mkRegisterCC :: CostCentre -> CmmAGraph -mkRegisterCC cc - = withTemp cInt $ \tmp -> - catAGraphs [ - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) - (CmmLoad cC_LIST bWord), - mkStore cC_LIST cc_lit, - mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt), - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), - mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - where - cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) - --- (ccs)->prevStack = CCS_LIST; --- CCS_LIST = (ccs); --- (ccs)->ccsID = CCS_ID++; - -mkRegisterCCS :: CostCentreStack -> CmmAGraph -mkRegisterCCS ccs - = withTemp cInt $ \ tmp -> - catAGraphs [ - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) - (CmmLoad cCS_LIST bWord), - mkStore cCS_LIST ccs_lit, - mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt), - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), - mkStore 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"))) - -cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID"))) - --- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> FCode () @@ -469,7 +423,8 @@ emitSetCCC cc pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - (sLit "PushCostCentre") [(ccs,AddrHint), + rtsPackageId + (fsLit "PushCostCentre") [(ccs,AddrHint), (CmmLit (mkCCostCentre cc), AddrHint)] False @@ -536,7 +491,7 @@ ldvEnter cl_ptr loadEra :: CmmExpr loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) - [CmmLoad (mkLblExpr (mkRtsDataLabel (sLit "era"))) cInt] + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt] ldvWord :: CmmExpr -> CmmExpr -- Takes the address of a closure, and returns @@ -544,10 +499,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