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 "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           ( moduleUserString )
  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 (moduleUserString (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         -- Note: to avoid making any assumptions about how the
 318         -- C compiler (that compiles the RTS, in particular) does
 319         -- layouts of structs containing long-longs, simply
 320         -- pad out the struct with zero words until we hit the
 321         -- size of the overall struct (which we get via DerivedConstants.h)
 322         --
 323      lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
 324   ; emitDataLits (mkCCSLabel ccs) lits
 325   }
 326   | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
 327
 328 zero = mkIntCLit 0
 329 zero64 = CmmInt 0 I64
 330
 331 sizeof_ccs_words :: Int
 332 sizeof_ccs_words
 333     -- round up to the next word.
 334   | ms == 0   = ws
 335   | otherwise = ws + 1
 336   where
 337    (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
 338
 339 -- ---------------------------------------------------------------------------
 340 -- Registering CCs and CCSs
 341
 342 --   (cc)->link = CC_LIST;
 343 --   CC_LIST = (cc);
 344 --   (cc)->ccID = CC_ID++;
 345
 346 emitRegisterCC :: CostCentre -> Code
 347 emitRegisterCC cc = do
 348   { tmp <- newTemp cIntRep
 349   ; stmtsC [
 350      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
 351                  (CmmLoad cC_LIST wordRep),
 352      CmmStore cC_LIST cc_lit,
 353      CmmAssign tmp (CmmLoad cC_ID cIntRep),
 354      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
 355      CmmStore cC_ID (cmmRegOffB tmp 1)
 356    ]
 357   }
 358   where
 359     cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
 360
 361 --  (ccs)->prevStack = CCS_LIST;
 362 --  CCS_LIST = (ccs);
 363 --  (ccs)->ccsID = CCS_ID++;
 364
 365 emitRegisterCCS :: CostCentreStack -> Code
 366 emitRegisterCCS ccs = do
 367   { tmp <- newTemp cIntRep
 368   ; stmtsC [
 369      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
 370                         (CmmLoad cCS_LIST wordRep),
 371      CmmStore cCS_LIST ccs_lit,
 372      CmmAssign tmp (CmmLoad cCS_ID cIntRep),
 373      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
 374      CmmStore cCS_ID (cmmRegOffB tmp 1)
 375    ]
 376   }
 377   where
 378     ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
 379
 380
 381 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
 382 cC_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
 383
 384 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
 385 cCS_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
 386
 387 -- ---------------------------------------------------------------------------
 388 -- Set the current cost centre stack
 389
 390 emitSetCCC :: CostCentre -> Code
 391 emitSetCCC cc
 392   | not opt_SccProfilingOn = nopC
 393   | otherwise = do
 394     tmp <- newTemp wordRep
 395     ASSERT( sccAbleCostCentre cc )
 396       pushCostCentre tmp curCCS cc
 397     stmtC (CmmStore curCCSAddr (CmmReg tmp))
 398     when (isSccCountCostCentre cc) $
 399         stmtC (bumpSccCount curCCS)
 400
 401 pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
 402 pushCostCentre result ccs cc
 403   = emitRtsCallWithResult result PtrHint
 404         SLIT("PushCostCentre") [(ccs,PtrHint),
 405                                 (CmmLit (mkCCostCentre cc), PtrHint)]
 406
 407 bumpSccCount :: CmmExpr -> CmmStmt
 408 bumpSccCount ccs
 409   = addToMem REP_CostCentreStack_scc_count
 410          (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
 411
 412 -----------------------------------------------------------------------------
 413 --
 414 --              Lag/drag/void stuff
 415 --
 416 -----------------------------------------------------------------------------
 417
 418 --
 419 -- Initial value for the LDV field in a static closure
 420 --
 421 staticLdvInit :: CmmLit
 422 staticLdvInit = zeroCLit
 423
 424 --
 425 -- Initial value of the LDV field in a dynamic closure
 426 --
 427 dynLdvInit :: CmmExpr
 428 dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
 429   CmmMachOp mo_wordOr [
 430       CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
 431       CmmLit (mkWordCLit lDV_STATE_CREATE)
 432   ]
 433
 434 --
 435 -- Initialise the LDV word of a new closure
 436 --
 437 ldvRecordCreate :: CmmExpr -> Code
 438 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
 439
 440 --
 441 -- Called when a closure is entered, marks the closure as having been "used".
 442 -- The closure is not an 'inherently used' one.
 443 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 444 -- profiling.
 445 --
 446 ldvEnter :: CmmExpr -> Code
 447 -- Argument is a closure pointer
 448 ldvEnter cl_ptr
 449   =  ifProfiling $
 450      -- if (era > 0) {
 451      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
 452      --                era | LDV_STATE_USE }
 453     emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
 454            (stmtC (CmmStore ldv_wd new_ldv_wd))
 455   where
 456     ldv_wd = ldvWord cl_ptr
 457     new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
 458                                        (CmmLit (mkWordCLit lDV_CREATE_MASK)))
 459                  (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
 460
 461 loadEra :: CmmExpr
 462 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
 463           [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
 464
 465 ldvWord :: CmmExpr -> CmmExpr
 466 -- Takes the address of a closure, and returns
 467 -- the address of the LDV word in the closure
 468 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
 469
 470 -- LDV constants, from ghc/includes/Constants.h
 471 lDV_SHIFT        = (LDV_SHIFT :: Int)
 472 --lDV_STATE_MASK   = (LDV_STATE_MASK :: StgWord)
 473 lDV_CREATE_MASK  = (LDV_CREATE_MASK :: StgWord)
 474 --lDV_LAST_MASK    = (LDV_LAST_MASK :: StgWord)
 475 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
 476 lDV_STATE_USE    = (LDV_STATE_USE :: StgWord)
 477