compiler/codeGen/CgProf.hs

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