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         emitSetCCC, emitCCS,
  20
  21         -- Lag/drag/void stuff
  22         ldvEnter, ldvEnterClosure, ldvRecordCreate
  23   ) where
  24
  25 #include "HsVersions.h"
  26 #include "../includes/MachDeps.h"
  27  -- For WORD_SIZE_IN_BITS only.
  28 #include "../includes/rts/Constants.h"
  29         -- For LDV_CREATE_MASK, LDV_STATE_USE
  30         -- which are StgWords
  31 #include "../includes/DerivedConstants.h"
  32         -- For REP_xxx constants, which are MachReps
  33
  34 import ClosureInfo
  35 import CgUtils
  36 import CgMonad
  37 import SMRep
  38
  39 import OldCmm
  40 import OldCmmUtils
  41 import CLabel
  42
  43 import Id
  44 import qualified Module
  45 import CostCentre
  46 import StgSyn
  47 import StaticFlags
  48 import FastString
  49 import Module
  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 (mkCmmDataLabel rtsPackageId (fsLit "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 rtsPackageId (fsLit "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 (mkCmmDataLabel rtsPackageId (fsLit "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 -- Set the current cost centre stack
 351
 352 emitSetCCC :: CostCentre -> Code
 353 emitSetCCC cc
 354   | not opt_SccProfilingOn = nopC
 355   | otherwise = do
 356     tmp <- newTemp bWord -- TODO FIXME NOW
 357     ASSERT( sccAbleCostCentre cc )
 358       pushCostCentre tmp curCCS cc
 359     stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp)))
 360     when (isSccCountCostCentre cc) $
 361         stmtC (bumpSccCount curCCS)
 362
 363 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
 364 pushCostCentre result ccs cc
 365   = emitRtsCallWithResult result AddrHint
 366         rtsPackageId
 367         (fsLit "PushCostCentre") [CmmHinted ccs AddrHint,
 368                                  CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
 369         False
 370
 371 bumpSccCount :: CmmExpr -> CmmStmt
 372 bumpSccCount ccs
 373   = addToMem (typeWidth REP_CostCentreStack_scc_count)
 374          (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
 375
 376 -----------------------------------------------------------------------------
 377 --
 378 --              Lag/drag/void stuff
 379 --
 380 -----------------------------------------------------------------------------
 381
 382 --
 383 -- Initial value for the LDV field in a static closure
 384 --
 385 staticLdvInit :: CmmLit
 386 staticLdvInit = zeroCLit
 387
 388 --
 389 -- Initial value of the LDV field in a dynamic closure
 390 --
 391 dynLdvInit :: CmmExpr
 392 dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
 393   CmmMachOp mo_wordOr [
 394       CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
 395       CmmLit (mkWordCLit lDV_STATE_CREATE)
 396   ]
 397
 398 --
 399 -- Initialise the LDV word of a new closure
 400 --
 401 ldvRecordCreate :: CmmExpr -> Code
 402 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
 403
 404 --
 405 -- Called when a closure is entered, marks the closure as having been "used".
 406 -- The closure is not an 'inherently used' one.
 407 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 408 -- profiling.
 409 --
 410 ldvEnterClosure :: ClosureInfo -> Code
 411 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
 412   where tag = funTag closure_info
 413         -- don't forget to substract node's tag
 414
 415 ldvEnter :: CmmExpr -> Code
 416 -- Argument is a closure pointer
 417 ldvEnter cl_ptr
 418   =  ifProfiling $
 419      -- if (era > 0) {
 420      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
 421      --                era | LDV_STATE_USE }
 422     emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
 423            (stmtC (CmmStore ldv_wd new_ldv_wd))
 424   where
 425         -- don't forget to substract node's tag
 426     ldv_wd = ldvWord cl_ptr
 427     new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
 428                                        (CmmLit (mkWordCLit lDV_CREATE_MASK)))
 429                  (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
 430
 431 loadEra :: CmmExpr
 432 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
 433           [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
 434
 435 ldvWord :: CmmExpr -> CmmExpr
 436 -- Takes the address of a closure, and returns
 437 -- the address of the LDV word in the closure
 438 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
 439
 440 -- LDV constants, from ghc/includes/Constants.h
 441 lDV_SHIFT :: Int
 442 lDV_SHIFT = LDV_SHIFT
 443 --lDV_STATE_MASK :: StgWord
 444 --lDV_STATE_MASK   = LDV_STATE_MASK
 445 lDV_CREATE_MASK :: StgWord
 446 lDV_CREATE_MASK  = LDV_CREATE_MASK
 447 --lDV_LAST_MASK    :: StgWord
 448 --lDV_LAST_MASK    = LDV_LAST_MASK
 449 lDV_STATE_CREATE :: StgWord
 450 lDV_STATE_CREATE = LDV_STATE_CREATE
 451 lDV_STATE_USE    :: StgWord
 452 lDV_STATE_USE    = LDV_STATE_USE
 453