X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgProf.hs;h=47dabed3ad7732f746e5c8a515cd167fc4527e39;hp=daff2f666563eec045d3aeea63d9c1fac476b7b8;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=1f379510d8a0ea12c273c72129e7d25643ad2ed7 diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index daff2f6..47dabed 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -2,10 +2,17 @@ -- -- Code generation for profiling -- --- (c) The University of Glasgow 2004 +-- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -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/WorkingConventions#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" @@ -32,30 +39,28 @@ module CgProf ( #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 ( moduleNameString ) -import qualified Module ( moduleName ) -- clashes with CgMonad.moduleName -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 ----------------------------------------------------------------------------- -- @@ -157,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 @@ -244,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 = @@ -259,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 @@ -293,7 +301,8 @@ emitCostCentreDecl -> Code emitCostCentreDecl cc = do { label <- mkStringCLit (costCentreUserName cc) - ; modl <- mkStringCLit (moduleNameString (Module.moduleName (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. @@ -350,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 @@ -369,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 @@ -396,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 @@ -448,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) | @@ -458,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)))