-{-# OPTIONS -w #-}
--- Lots of missing type sigs etc
-
-----------------------------------------------------------------------------
--
-- Code generation for profiling
) 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 StgCmmClosure
-import StgCmmEnv
import StgCmmUtils
import StgCmmMonad
import SMRep
-import MkZipCfgCmm
-import Cmm
-import TyCon ( PrimRep(..) )
+import MkGraph
+import CmmExpr
+import CmmDecl
import CmmUtils
import CLabel
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
-- 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)
-- 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 -> FCode ()
enter_cost_centre closure_info ccs body
| isSubsumedCCS ccs
= ASSERT(isToplevClosure closure_info)
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
-- 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 ()
-- 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 ()
-- 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
(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 ()
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
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
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