ghc/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 "../includes/ghcconfig.h"
  28         -- Needed by Constants.h
  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           ( moduleNameUserString )
  47 import Id               ( Id )
  48 import CostCentre
  49 import StgSyn           ( GenStgExpr(..), StgExpr )
  50 import CmdLineOpts      ( opt_SccProfilingOn )
  51 import FastString       ( FastString, mkFastString, LitString )
  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
 263 enter_ccs_fsub = enteringPAP 0
 264
 265 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
 266 -- code and the function entry code; we don't want the function's
 267 -- entry code to also update CCCS in the event that it was called via
 268 -- a PAP, so we set the flag entering_PAP to indicate that we are
 269 -- entering via a PAP.
 270 enteringPAP :: Integer -> Code
 271 enteringPAP n
 272   = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
 273                 (CmmLit (CmmInt n cIntRep)))
 274
 275 ifProfiling :: Code -> Code
 276 ifProfiling code
 277   | opt_SccProfilingOn = code
 278   | otherwise          = nopC
 279
 280 ifProfilingL :: [a] -> [a]
 281 ifProfilingL xs
 282   | opt_SccProfilingOn = xs
 283   | otherwise          = []
 284
 285
 286 -- ---------------------------------------------------------------------------
 287 -- Initialising Cost Centres & CCSs
 288
 289 emitCostCentreDecl
 290    :: CostCentre
 291    -> Code
 292 emitCostCentreDecl cc = do
 293   { label <- mkStringCLit (costCentreUserName cc)
 294   ; modl  <- mkStringCLit (moduleNameUserString (cc_mod cc))
 295   ; let
 296      lits = [ zero,     -- StgInt ccID,
 297               label,    -- char *label,
 298               modl,     -- char *module,
 299               zero,     -- StgWord time_ticks
 300               zero64,   -- StgWord64 mem_alloc
 301               subsumed, -- StgInt is_caf
 302               zero      -- struct _CostCentre *link
 303             ]
 304   ; emitDataLits (mkCCLabel cc) lits
 305   }
 306   where
 307         subsumed | isCafCC cc = mkIntCLit (ord 'c')  -- 'c' == is a CAF
 308                  | otherwise  = mkIntCLit (ord 'B')  -- 'B' == is boring
 309
 310
 311 emitCostCentreStackDecl
 312    :: CostCentreStack
 313    -> Code
 314 emitCostCentreStackDecl ccs
 315   | Just cc <- maybeSingletonCCS ccs = do
 316   { let
 317      lits = [ zero,
 318               mkCCostCentre cc,
 319               zero,   -- struct _CostCentreStack *prevStack;
 320               zero,   -- struct _IndexTable *indexTable;
 321               zero,   -- StgWord    selected;
 322               zero64, -- StgWord64  scc_count;
 323               zero,   -- StgWord    time_ticks;
 324               zero64, -- StgWord64  mem_alloc;
 325               zero,   -- StgWord    inherited_ticks;
 326               zero64, -- StgWord64  inherited_alloc;
 327               zero    -- CostCentre *root;
 328            ]
 329   ; emitDataLits (mkCCSLabel ccs) lits
 330   }
 331   | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
 332
 333 zero = mkIntCLit 0
 334 zero64 = CmmInt 0 I64
 335
 336
 337 -- ---------------------------------------------------------------------------
 338 -- Registering CCs and CCSs
 339
 340 --   (cc)->link = CC_LIST;
 341 --   CC_LIST = (cc);
 342 --   (cc)->ccID = CC_ID++;
 343
 344 emitRegisterCC :: CostCentre -> Code
 345 emitRegisterCC cc = do
 346   { tmp <- newTemp cIntRep
 347   ; stmtsC [
 348      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
 349                  (CmmLoad cC_LIST wordRep),
 350      CmmStore cC_LIST cc_lit,
 351      CmmAssign tmp (CmmLoad cC_ID cIntRep),
 352      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
 353      CmmStore cC_ID (cmmRegOffB tmp 1)
 354    ]
 355   }
 356   where
 357     cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
 358
 359 --  (ccs)->prevStack = CCS_LIST;
 360 --  CCS_LIST = (ccs);
 361 --  (ccs)->ccsID = CCS_ID++;
 362
 363 emitRegisterCCS :: CostCentreStack -> Code
 364 emitRegisterCCS ccs = do
 365   { tmp <- newTemp cIntRep
 366   ; stmtsC [
 367      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
 368                         (CmmLoad cCS_LIST wordRep),
 369      CmmStore cCS_LIST ccs_lit,
 370      CmmAssign tmp (CmmLoad cCS_ID cIntRep),
 371      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
 372      CmmStore cCS_ID (cmmRegOffB tmp 1)
 373    ]
 374   }
 375   where
 376     ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
 377
 378
 379 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
 380 cC_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
 381
 382 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
 383 cCS_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
 384
 385 -- ---------------------------------------------------------------------------
 386 -- Set the current cost centre stack
 387
 388 emitSetCCC :: CostCentre -> Code
 389 emitSetCCC cc
 390   | not opt_SccProfilingOn = nopC
 391   | otherwise = do
 392     tmp <- newTemp wordRep
 393     ASSERT( sccAbleCostCentre cc )
 394       pushCostCentre tmp curCCS cc
 395     stmtC (CmmStore curCCSAddr (CmmReg tmp))
 396     when (isSccCountCostCentre cc) $
 397         stmtC (bumpSccCount curCCS)
 398
 399 pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
 400 pushCostCentre result ccs cc
 401   = emitRtsCallWithResult result PtrHint
 402         SLIT("PushCostCentre") [(ccs,PtrHint),
 403                                 (CmmLit (mkCCostCentre cc), PtrHint)]
 404
 405 bumpSccCount :: CmmExpr -> CmmStmt
 406 bumpSccCount ccs
 407   = addToMem REP_CostCentreStack_scc_count
 408          (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
 409
 410 -----------------------------------------------------------------------------
 411 --
 412 --              Lag/drag/void stuff
 413 --
 414 -----------------------------------------------------------------------------
 415
 416 --
 417 -- Initial value for the LDV field in a static closure
 418 --
 419 staticLdvInit :: CmmLit
 420 staticLdvInit = zeroCLit
 421
 422 --
 423 -- Initial value of the LDV field in a dynamic closure
 424 --
 425 dynLdvInit :: CmmExpr
 426 dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
 427   CmmMachOp mo_wordOr [
 428       CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
 429       CmmLit (mkWordCLit lDV_STATE_CREATE)
 430   ]
 431
 432 --
 433 -- Initialise the LDV word of a new closure
 434 --
 435 ldvRecordCreate :: CmmExpr -> Code
 436 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
 437
 438 --
 439 -- Called when a closure is entered, marks the closure as having been "used".
 440 -- The closure is not an 'inherently used' one.
 441 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 442 -- profiling.
 443 --
 444 ldvEnter :: CmmExpr -> Code
 445 -- Argument is a closure pointer
 446 ldvEnter cl_ptr
 447   =  ifProfiling $
 448      -- if (era > 0) {
 449      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
 450      --                era | LDV_STATE_USE }
 451     emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
 452            (stmtC (CmmStore ldv_wd new_ldv_wd))
 453   where
 454     ldv_wd = ldvWord cl_ptr
 455     new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
 456                                        (CmmLit (mkWordCLit lDV_CREATE_MASK)))
 457                  (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
 458
 459 loadEra :: CmmExpr
 460 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
 461           [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
 462
 463 ldvWord :: CmmExpr -> CmmExpr
 464 -- Takes the address of a closure, and returns
 465 -- the address of the LDV word in the closure
 466 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
 467
 468 -- LDV constants, from ghc/includes/Constants.h
 469 lDV_SHIFT        = (LDV_SHIFT :: Int)
 470 --lDV_STATE_MASK   = (LDV_STATE_MASK :: StgWord)
 471 lDV_CREATE_MASK  = (LDV_CREATE_MASK :: StgWord)
 472 --lDV_LAST_MASK    = (LDV_LAST_MASK :: StgWord)
 473 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
 474 lDV_STATE_USE    = (LDV_STATE_USE :: StgWord)
 475