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, 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 <- newTemp wordRep
 159           pushCostCentre tmp ccs cc
 160           push_em (CmmReg 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 (CmmReg nodeReg)
 246     is_box     = isBox body
 247
 248 -- set the current CCS when entering a PAP
 249 enterCostCentrePAP :: CmmExpr -> Code
 250 enterCostCentrePAP closure =
 251   ifProfiling $ do
 252     enter_ccs_fun (costCentreFrom closure)
 253     enteringPAP 1
 254
 255 enterCostCentreThunk :: CmmExpr -> Code
 256 enterCostCentreThunk closure =
 257   ifProfiling $ do
 258     stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
 259
 260 enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
 261                         -- ToDo: vols
 262
 263 enter_ccs_fsub = enteringPAP 0
 264
 265 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
 266 -- code and the function entry code; we don't want the function's
 267 -- entry code to also update CCCS in the event that it was called via
 268 -- a PAP, so we set the flag entering_PAP to indicate that we are
 269 -- entering via a PAP.
 270 enteringPAP :: Integer -> Code
 271 enteringPAP n
 272   = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
 273                 (CmmLit (CmmInt n cIntRep)))
 274
 275 ifProfiling :: Code -> Code
 276 ifProfiling code
 277   | opt_SccProfilingOn = code
 278   | otherwise          = nopC
 279
 280 ifProfilingL :: [a] -> [a]
 281 ifProfilingL xs
 282   | opt_SccProfilingOn = xs
 283   | otherwise          = []
 284
 285
 286 -- ---------------------------------------------------------------------------
 287 -- Initialising Cost Centres & CCSs
 288
 289 emitCostCentreDecl
 290    :: CostCentre
 291    -> Code
 292 emitCostCentreDecl cc = do
 293   { label <- mkStringCLit (costCentreUserName cc)
 294   ; modl  <- mkStringCLit (Module.moduleNameString
 295                                 (Module.moduleName (cc_mod cc)))
 296                 -- All cost centres will be in the main package, since we
 297                 -- don't normally use -auto-all or add SCCs to other packages.
 298                 -- Hence don't emit the package name in the module here.
 299   ; let
 300      lits = [ zero,     -- StgInt ccID,
 301               label,    -- char *label,
 302               modl,     -- char *module,
 303               zero,     -- StgWord time_ticks
 304               zero64,   -- StgWord64 mem_alloc
 305               subsumed, -- StgInt is_caf
 306               zero      -- struct _CostCentre *link
 307             ]
 308   ; emitDataLits (mkCCLabel cc) lits
 309   }
 310   where
 311         subsumed | isCafCC cc = mkIntCLit (ord 'c')  -- 'c' == is a CAF
 312                  | otherwise  = mkIntCLit (ord 'B')  -- 'B' == is boring
 313
 314
 315 emitCostCentreStackDecl
 316    :: CostCentreStack
 317    -> Code
 318 emitCostCentreStackDecl ccs
 319   | Just cc <- maybeSingletonCCS ccs = do
 320   { let
 321         -- Note: to avoid making any assumptions about how the
 322         -- C compiler (that compiles the RTS, in particular) does
 323         -- layouts of structs containing long-longs, simply
 324         -- pad out the struct with zero words until we hit the
 325         -- size of the overall struct (which we get via DerivedConstants.h)
 326         --
 327      lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
 328   ; emitDataLits (mkCCSLabel ccs) lits
 329   }
 330   | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
 331
 332 zero = mkIntCLit 0
 333 zero64 = CmmInt 0 I64
 334
 335 sizeof_ccs_words :: Int
 336 sizeof_ccs_words
 337     -- round up to the next word.
 338   | ms == 0   = ws
 339   | otherwise = ws + 1
 340   where
 341    (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
 342
 343 -- ---------------------------------------------------------------------------
 344 -- Registering CCs and CCSs
 345
 346 --   (cc)->link = CC_LIST;
 347 --   CC_LIST = (cc);
 348 --   (cc)->ccID = CC_ID++;
 349
 350 emitRegisterCC :: CostCentre -> Code
 351 emitRegisterCC cc = do
 352   { tmp <- newTemp cIntRep
 353   ; stmtsC [
 354      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
 355                  (CmmLoad cC_LIST wordRep),
 356      CmmStore cC_LIST cc_lit,
 357      CmmAssign tmp (CmmLoad cC_ID cIntRep),
 358      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
 359      CmmStore cC_ID (cmmRegOffB tmp 1)
 360    ]
 361   }
 362   where
 363     cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
 364
 365 --  (ccs)->prevStack = CCS_LIST;
 366 --  CCS_LIST = (ccs);
 367 --  (ccs)->ccsID = CCS_ID++;
 368
 369 emitRegisterCCS :: CostCentreStack -> Code
 370 emitRegisterCCS ccs = do
 371   { tmp <- newTemp cIntRep
 372   ; stmtsC [
 373      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
 374                         (CmmLoad cCS_LIST wordRep),
 375      CmmStore cCS_LIST ccs_lit,
 376      CmmAssign tmp (CmmLoad cCS_ID cIntRep),
 377      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
 378      CmmStore cCS_ID (cmmRegOffB tmp 1)
 379    ]
 380   }
 381   where
 382     ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
 383
 384
 385 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
 386 cC_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
 387
 388 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
 389 cCS_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
 390
 391 -- ---------------------------------------------------------------------------
 392 -- Set the current cost centre stack
 393
 394 emitSetCCC :: CostCentre -> Code
 395 emitSetCCC cc
 396   | not opt_SccProfilingOn = nopC
 397   | otherwise = do
 398     tmp <- newTemp wordRep
 399     ASSERT( sccAbleCostCentre cc )
 400       pushCostCentre tmp curCCS cc
 401     stmtC (CmmStore curCCSAddr (CmmReg tmp))
 402     when (isSccCountCostCentre cc) $
 403         stmtC (bumpSccCount curCCS)
 404
 405 pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
 406 pushCostCentre result ccs cc
 407   = emitRtsCallWithResult result PtrHint
 408         SLIT("PushCostCentre") [(ccs,PtrHint),
 409                                 (CmmLit (mkCCostCentre cc), PtrHint)]
 410
 411 bumpSccCount :: CmmExpr -> CmmStmt
 412 bumpSccCount ccs
 413   = addToMem REP_CostCentreStack_scc_count
 414          (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
 415
 416 -----------------------------------------------------------------------------
 417 --
 418 --              Lag/drag/void stuff
 419 --
 420 -----------------------------------------------------------------------------
 421
 422 --
 423 -- Initial value for the LDV field in a static closure
 424 --
 425 staticLdvInit :: CmmLit
 426 staticLdvInit = zeroCLit
 427
 428 --
 429 -- Initial value of the LDV field in a dynamic closure
 430 --
 431 dynLdvInit :: CmmExpr
 432 dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
 433   CmmMachOp mo_wordOr [
 434       CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
 435       CmmLit (mkWordCLit lDV_STATE_CREATE)
 436   ]
 437
 438 --
 439 -- Initialise the LDV word of a new closure
 440 --
 441 ldvRecordCreate :: CmmExpr -> Code
 442 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
 443
 444 --
 445 -- Called when a closure is entered, marks the closure as having been "used".
 446 -- The closure is not an 'inherently used' one.
 447 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 448 -- profiling.
 449 --
 450 ldvEnter :: CmmExpr -> Code
 451 -- Argument is a closure pointer
 452 ldvEnter cl_ptr
 453   =  ifProfiling $
 454      -- if (era > 0) {
 455      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
 456      --                era | LDV_STATE_USE }
 457     emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
 458            (stmtC (CmmStore ldv_wd new_ldv_wd))
 459   where
 460     ldv_wd = ldvWord cl_ptr
 461     new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
 462                                        (CmmLit (mkWordCLit lDV_CREATE_MASK)))
 463                  (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
 464
 465 loadEra :: CmmExpr
 466 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
 467           [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
 468
 469 ldvWord :: CmmExpr -> CmmExpr
 470 -- Takes the address of a closure, and returns
 471 -- the address of the LDV word in the closure
 472 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
 473
 474 -- LDV constants, from ghc/includes/Constants.h
 475 lDV_SHIFT        = (LDV_SHIFT :: Int)
 476 --lDV_STATE_MASK   = (LDV_STATE_MASK :: StgWord)
 477 lDV_CREATE_MASK  = (LDV_CREATE_MASK :: StgWord)
 478 --lDV_LAST_MASK    = (LDV_LAST_MASK :: StgWord)
 479 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
 480 lDV_STATE_USE    = (LDV_STATE_USE :: StgWord)
 481