compiler/codeGen/CgProf.hs

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