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