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