compiler/codeGen/CgProf.hs

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