compiler/codeGen/CgProf.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generation for profiling
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CgProf (
  10         mkCCostCentre, mkCCostCentreStack,
  11
  12         -- Cost-centre Profiling
  13         dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
  14         enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
  15         chooseDynCostCentres,
  16         costCentreFrom,
  17         curCCS, curCCSAddr,
  18         emitCostCentreDecl, emitCostCentreStackDecl,
  19         emitRegisterCC, emitRegisterCCS,
  20         emitSetCCC, emitCCS,
  21
  22         -- Lag/drag/void stuff
  23         ldvEnter, ldvEnterClosure, ldvRecordCreate
  24   ) where
  25
  26 #include "HsVersions.h"
  27 #include "../includes/MachDeps.h"
  28  -- For WORD_SIZE_IN_BITS only.
  29 #include "../includes/rts/Constants.h"
  30         -- For LDV_CREATE_MASK, LDV_STATE_USE
  31         -- which are StgWords
  32 #include "../includes/DerivedConstants.h"
  33         -- For REP_xxx constants, which are MachReps
  34
  35 import ClosureInfo
  36 import CgUtils
  37 import CgMonad
  38 import SMRep
  39
  40 import OldCmm
  41 import OldCmmUtils
  42 import CLabel
  43
  44 import Id
  45 import qualified Module
  46 import CostCentre
  47 import StgSyn
  48 import StaticFlags
  49 import FastString
  50 import Module
  51 import Constants        -- Lots of field offsets
  52 import Outputable
  53
  54 import Data.Char
  55 import Control.Monad
  56
  57 -----------------------------------------------------------------------------
  58 --
  59 -- Cost-centre-stack Profiling
  60 --
  61 -----------------------------------------------------------------------------
  62
  63 -- Expression representing the current cost centre stack
  64 curCCS :: CmmExpr
  65 curCCS = CmmLoad curCCSAddr bWord
  66
  67 -- Address of current CCS variable, for storing into
  68 curCCSAddr :: CmmExpr
  69 curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
  70
  71 mkCCostCentre :: CostCentre -> CmmLit
  72 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
  73
  74 mkCCostCentreStack :: CostCentreStack -> CmmLit
  75 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
  76
  77 costCentreFrom :: CmmExpr       -- A closure pointer
  78                -> CmmExpr       -- The cost centre from that closure
  79 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord
  80
  81 staticProfHdr :: CostCentreStack -> [CmmLit]
  82 -- The profiling header words in a static closure
  83 -- Was SET_STATIC_PROF_HDR
  84 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
  85                                   staticLdvInit]
  86
  87 dynProfHdr :: CmmExpr -> [CmmExpr]
  88 -- Profiling header words in a dynamic closure
  89 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
  90
  91 initUpdFrameProf :: CmmExpr -> Code
  92 -- Initialise the profiling field of an update frame
  93 initUpdFrameProf frame_amode
  94   = ifProfiling $       -- frame->header.prof.ccs = CCCS
  95     stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
  96         -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
  97         -- is unnecessary because it is not used anyhow.
  98
  99 -- -----------------------------------------------------------------------------
 100 -- Recording allocation in a cost centre
 101
 102 -- | Record the allocation of a closure.  The CmmExpr is the cost
 103 -- centre stack to which to attribute the allocation.
 104 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
 105 profDynAlloc cl_info ccs
 106   = ifProfiling $
 107     profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
 108
 109 -- | Record the allocation of a closure (size is given by a CmmExpr)
 110 -- The size must be in words, because the allocation counter in a CCS counts
 111 -- in words.
 112 profAlloc :: CmmExpr -> CmmExpr -> Code
 113 profAlloc words ccs
 114   = ifProfiling $
 115     stmtC (addToMemE alloc_rep
 116                 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
 117                 (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
 118                   [CmmMachOp mo_wordSub [words,
 119                                          CmmLit (mkIntCLit profHdrSize)]]))
 120                 -- subtract the "profiling overhead", which is the
 121                 -- profiling header in a closure.
 122  where
 123    alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
 124
 125 -- ----------------------------------------------------------------------
 126 -- Setting the cost centre in a new closure
 127
 128 chooseDynCostCentres :: CostCentreStack
 129                      -> [Id]            -- Args
 130                      -> StgExpr         -- Body
 131                      -> FCode (CmmExpr, CmmExpr)
 132 -- Called when alllcating a closure
 133 -- Tells which cost centre to put in the object, and which
 134 -- to blame the cost of allocation on
 135 chooseDynCostCentres ccs args body = do
 136   -- Cost-centre we record in the object
 137   use_ccs <- emitCCS ccs
 138
 139   -- Cost-centre on whom we blame the allocation
 140   let blame_ccs
 141         | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
 142         | otherwise               = use_ccs
 143
 144   return (use_ccs, blame_ccs)
 145
 146
 147 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
 148 -- These pushes must be performed before we can refer to the stack in
 149 -- an expression.
 150 emitCCS :: CostCentreStack -> FCode CmmExpr
 151 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
 152   where
 153         (cc's, ccs') = decomposeCCS ccs
 154
 155         push_em ccs [] = return ccs
 156         push_em ccs (cc:rest) = do
 157           tmp <- newTemp bWord -- TODO FIXME NOW
 158           pushCostCentre tmp ccs cc
 159           push_em (CmmReg (CmmLocal tmp)) rest
 160
 161 ccsExpr :: CostCentreStack -> CmmExpr
 162 ccsExpr ccs
 163   | isCurrentCCS ccs = curCCS
 164   | otherwise        = CmmLit (mkCCostCentreStack ccs)
 165
 166
 167 isBox :: StgExpr -> Bool
 168 -- If it's an utterly trivial RHS, then it must be
 169 -- one introduced by boxHigherOrderArgs for profiling,
 170 -- so we charge it to "OVERHEAD".
 171 -- This looks like a GROSS HACK to me --SDM
 172 isBox (StgApp _ []) = True
 173 isBox _             = False
 174
 175
 176 -- -----------------------------------------------------------------------
 177 -- Setting the current cost centre on entry to a closure
 178
 179 -- For lexically scoped profiling we have to load the cost centre from
 180 -- the closure entered, if the costs are not supposed to be inherited.
 181 -- This is done immediately on entering the fast entry point.
 182
 183 -- Load current cost centre from closure, if not inherited.
 184 -- Node is guaranteed to point to it, if profiling and not inherited.
 185
 186 enterCostCentre
 187    :: ClosureInfo
 188    -> CostCentreStack
 189    -> StgExpr   -- The RHS of the closure
 190    -> Code
 191
 192 -- We used to have a special case for bindings of form
 193 --      f = g True
 194 -- where g has arity 2.  The RHS is a thunk, but we don't
 195 -- need to update it; and we want to subsume costs.
 196 -- We don't have these sort of PAPs any more, so the special
 197 -- case has gone away.
 198
 199 enterCostCentre closure_info ccs body
 200   = ifProfiling $
 201     ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
 202     enter_cost_centre closure_info ccs body
 203
 204 enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> Code
 205 enter_cost_centre closure_info ccs body
 206   | isSubsumedCCS ccs
 207   = ASSERT(isToplevClosure closure_info)
 208     ASSERT(re_entrant)
 209     enter_ccs_fsub
 210
 211   | isDerivedFromCurrentCCS ccs
 212   = do {
 213         if re_entrant && not is_box
 214           then
 215                 enter_ccs_fun node_ccs
 216           else
 217                 stmtC (CmmStore curCCSAddr node_ccs)
 218
 219         -- don't forget to bump the scc count.  This closure might have been
 220         -- of the form   let x = _scc_ "x" e in ...x..., which the SCCfinal
 221         -- pass has turned into simply  let x = e in ...x... and attached
 222         -- the _scc_ as PushCostCentre(x,CCCS) on the x closure.  So that
 223         -- we don't lose the scc counter, bump it in the entry code for x.
 224         -- ToDo: for a multi-push we should really bump the counter for
 225         -- each of the intervening CCSs, not just the top one.
 226        ; when (not (isCurrentCCS ccs)) $
 227                 stmtC (bumpSccCount curCCS)
 228        }
 229
 230   | isCafCCS ccs
 231   = ASSERT(isToplevClosure closure_info)
 232     ASSERT(not re_entrant)
 233     do  {       -- This is just a special case of the isDerivedFromCurrentCCS
 234                 -- case above.  We could delete this, but it's a micro
 235                 -- optimisation and saves a bit of code.
 236           stmtC (CmmStore curCCSAddr enc_ccs)
 237         ; stmtC (bumpSccCount node_ccs)
 238         }
 239
 240   | otherwise
 241   = panic "enterCostCentre"
 242   where
 243     enc_ccs    = CmmLit (mkCCostCentreStack ccs)
 244     re_entrant = closureReEntrant closure_info
 245     node_ccs   = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
 246     is_box     = isBox body
 247
 248     -- if this is a function, then node will be tagged; we must subract the tag
 249     node_tag = funTag closure_info
 250
 251 -- set the current CCS when entering a PAP
 252 enterCostCentrePAP :: CmmExpr -> Code
 253 enterCostCentrePAP closure =
 254   ifProfiling $ do
 255     enter_ccs_fun (costCentreFrom closure)
 256     enteringPAP 1
 257
 258 enterCostCentreThunk :: CmmExpr -> Code
 259 enterCostCentreThunk closure =
 260   ifProfiling $ do
 261     stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
 262
 263 enter_ccs_fun :: CmmExpr -> Code
 264 enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [CmmHinted stack AddrHint] False
 265                         -- ToDo: vols
 266
 267 enter_ccs_fsub :: Code
 268 enter_ccs_fsub = enteringPAP 0
 269
 270 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
 271 -- code and the function entry code; we don't want the function's
 272 -- entry code to also update CCCS in the event that it was called via
 273 -- a PAP, so we set the flag entering_PAP to indicate that we are
 274 -- entering via a PAP.
 275 enteringPAP :: Integer -> Code
 276 enteringPAP n
 277   = stmtC (CmmStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP"))))
 278                 (CmmLit (CmmInt n cIntWidth)))
 279
 280 ifProfiling :: Code -> Code
 281 ifProfiling code
 282   | opt_SccProfilingOn = code
 283   | otherwise          = nopC
 284
 285 ifProfilingL :: [a] -> [a]
 286 ifProfilingL xs
 287   | opt_SccProfilingOn = xs
 288   | otherwise          = []
 289
 290
 291 -- ---------------------------------------------------------------------------
 292 -- Initialising Cost Centres & CCSs
 293
 294 emitCostCentreDecl
 295    :: CostCentre
 296    -> Code
 297 emitCostCentreDecl cc = do
 298   { label <- mkStringCLit (costCentreUserName cc)
 299   ; modl  <- mkStringCLit (Module.moduleNameString
 300                                 (Module.moduleName (cc_mod cc)))
 301                 -- All cost centres will be in the main package, since we
 302                 -- don't normally use -auto-all or add SCCs to other packages.
 303                 -- Hence don't emit the package name in the module here.
 304   ; let
 305      lits = [ zero,     -- StgInt ccID,
 306               label,    -- char *label,
 307               modl,     -- char *module,
 308               zero,     -- StgWord time_ticks
 309               zero64,   -- StgWord64 mem_alloc
 310               subsumed, -- StgInt is_caf
 311               zero      -- struct _CostCentre *link
 312             ]
 313   ; emitDataLits (mkCCLabel cc) lits
 314   }
 315   where
 316         subsumed | isCafCC cc = mkIntCLit (ord 'c')  -- 'c' == is a CAF
 317                  | otherwise  = mkIntCLit (ord 'B')  -- 'B' == is boring
 318
 319
 320 emitCostCentreStackDecl
 321    :: CostCentreStack
 322    -> Code
 323 emitCostCentreStackDecl ccs
 324   | Just cc <- maybeSingletonCCS ccs = do
 325   { let
 326         -- Note: to avoid making any assumptions about how the
 327         -- C compiler (that compiles the RTS, in particular) does
 328         -- layouts of structs containing long-longs, simply
 329         -- pad out the struct with zero words until we hit the
 330         -- size of the overall struct (which we get via DerivedConstants.h)
 331         --
 332      lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
 333   ; emitDataLits (mkCCSLabel ccs) lits
 334   }
 335   | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
 336
 337 zero :: CmmLit
 338 zero = mkIntCLit 0
 339 zero64 :: CmmLit
 340 zero64 = CmmInt 0 W64
 341
 342 sizeof_ccs_words :: Int
 343 sizeof_ccs_words
 344     -- round up to the next word.
 345   | ms == 0   = ws
 346   | otherwise = ws + 1
 347   where
 348    (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
 349
 350 -- ---------------------------------------------------------------------------
 351 -- Registering CCs and CCSs
 352
 353 --   (cc)->link = CC_LIST;
 354 --   CC_LIST = (cc);
 355 --   (cc)->ccID = CC_ID++;
 356
 357 emitRegisterCC :: CostCentre -> Code
 358 emitRegisterCC cc = do
 359   { tmp <- newTemp cInt
 360   ; stmtsC [
 361      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
 362                  (CmmLoad cC_LIST bWord),
 363      CmmStore cC_LIST cc_lit,
 364      CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
 365      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
 366      CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
 367    ]
 368   }
 369   where
 370     cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
 371
 372 --  (ccs)->prevStack = CCS_LIST;
 373 --  CCS_LIST = (ccs);
 374 --  (ccs)->ccsID = CCS_ID++;
 375
 376 emitRegisterCCS :: CostCentreStack -> Code
 377 emitRegisterCCS ccs = do
 378   { tmp <- newTemp cInt
 379   ; stmtsC [
 380      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
 381                         (CmmLoad cCS_LIST bWord),
 382      CmmStore cCS_LIST ccs_lit,
 383      CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
 384      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
 385      CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
 386    ]
 387   }
 388   where
 389     ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
 390
 391
 392 cC_LIST, cC_ID :: CmmExpr
 393 cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
 394 cC_ID   = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
 395
 396 cCS_LIST, cCS_ID :: CmmExpr
 397 cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
 398 cCS_ID   = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
 399
 400 -- ---------------------------------------------------------------------------
 401 -- Set the current cost centre stack
 402
 403 emitSetCCC :: CostCentre -> Code
 404 emitSetCCC cc
 405   | not opt_SccProfilingOn = nopC
 406   | otherwise = do
 407     tmp <- newTemp bWord -- TODO FIXME NOW
 408     ASSERT( sccAbleCostCentre cc )
 409       pushCostCentre tmp curCCS cc
 410     stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp)))
 411     when (isSccCountCostCentre cc) $
 412         stmtC (bumpSccCount curCCS)
 413
 414 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
 415 pushCostCentre result ccs cc
 416   = emitRtsCallWithResult result AddrHint
 417         rtsPackageId
 418         (fsLit "PushCostCentre") [CmmHinted ccs AddrHint,
 419                                  CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
 420         False
 421
 422 bumpSccCount :: CmmExpr -> CmmStmt
 423 bumpSccCount ccs
 424   = addToMem (typeWidth REP_CostCentreStack_scc_count)
 425          (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
 426
 427 -----------------------------------------------------------------------------
 428 --
 429 --              Lag/drag/void stuff
 430 --
 431 -----------------------------------------------------------------------------
 432
 433 --
 434 -- Initial value for the LDV field in a static closure
 435 --
 436 staticLdvInit :: CmmLit
 437 staticLdvInit = zeroCLit
 438
 439 --
 440 -- Initial value of the LDV field in a dynamic closure
 441 --
 442 dynLdvInit :: CmmExpr
 443 dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
 444   CmmMachOp mo_wordOr [
 445       CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
 446       CmmLit (mkWordCLit lDV_STATE_CREATE)
 447   ]
 448
 449 --
 450 -- Initialise the LDV word of a new closure
 451 --
 452 ldvRecordCreate :: CmmExpr -> Code
 453 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
 454
 455 --
 456 -- Called when a closure is entered, marks the closure as having been "used".
 457 -- The closure is not an 'inherently used' one.
 458 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 459 -- profiling.
 460 --
 461 ldvEnterClosure :: ClosureInfo -> Code
 462 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
 463   where tag = funTag closure_info
 464         -- don't forget to substract node's tag
 465
 466 ldvEnter :: CmmExpr -> Code
 467 -- Argument is a closure pointer
 468 ldvEnter cl_ptr
 469   =  ifProfiling $
 470      -- if (era > 0) {
 471      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
 472      --                era | LDV_STATE_USE }
 473     emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
 474            (stmtC (CmmStore ldv_wd new_ldv_wd))
 475   where
 476         -- don't forget to substract node's tag
 477     ldv_wd = ldvWord cl_ptr
 478     new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
 479                                        (CmmLit (mkWordCLit lDV_CREATE_MASK)))
 480                  (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
 481
 482 loadEra :: CmmExpr
 483 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
 484           [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
 485
 486 ldvWord :: CmmExpr -> CmmExpr
 487 -- Takes the address of a closure, and returns
 488 -- the address of the LDV word in the closure
 489 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
 490
 491 -- LDV constants, from ghc/includes/Constants.h
 492 lDV_SHIFT :: Int
 493 lDV_SHIFT = LDV_SHIFT
 494 --lDV_STATE_MASK :: StgWord
 495 --lDV_STATE_MASK   = LDV_STATE_MASK
 496 lDV_CREATE_MASK :: StgWord
 497 lDV_CREATE_MASK  = LDV_CREATE_MASK
 498 --lDV_LAST_MASK    :: StgWord
 499 --lDV_LAST_MASK    = LDV_LAST_MASK
 500 lDV_STATE_CREATE :: StgWord
 501 lDV_STATE_CREATE = LDV_STATE_CREATE
 502 lDV_STATE_USE    :: StgWord
 503 lDV_STATE_USE    = LDV_STATE_USE
 504