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