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/Constants.h"
  28         -- For LDV_CREATE_MASK, LDV_STATE_USE
  29         -- which are StgWords
  30 #include "../includes/DerivedConstants.h"
  31         -- For REP_xxx constants, which are MachReps
  32
  33 import ClosureInfo      ( ClosureInfo, closureSize,
  34                           closureName, isToplevClosure, closureReEntrant, )
  35 import CgUtils
  36 import CgMonad
  37 import SMRep            ( StgWord, profHdrSize )
  38
  39 import Cmm
  40 import MachOp
  41 import CmmUtils         ( zeroCLit, mkIntCLit, mkLblExpr )
  42 import CLabel           ( mkCCLabel, mkCCSLabel, mkRtsDataLabel )
  43
  44 import Module           ( moduleUserString )
  45 import Id               ( Id )
  46 import CostCentre
  47 import StgSyn           ( GenStgExpr(..), StgExpr )
  48 import CmdLineOpts      ( opt_SccProfilingOn )
  49 import FastString       ( FastString, mkFastString, LitString )
  50 import Constants        -- Lots of field offsets
  51 import Outputable
  52
  53 import Maybe
  54 import Char             ( ord )
  55 import Monad            ( when )
  56
  57 -----------------------------------------------------------------------------
  58 --
  59 -- Cost-centre-stack Profiling
  60 --
  61 -----------------------------------------------------------------------------
  62
  63 -- Expression representing the current cost centre stack
  64 curCCS :: CmmExpr
  65 curCCS = CmmLoad curCCSAddr wordRep
  66
  67 -- Address of current CCS variable, for storing into
  68 curCCSAddr :: CmmExpr
  69 curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS")))
  70
  71 mkCCostCentre :: CostCentre -> CmmLit
  72 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
  73
  74 mkCCostCentreStack :: CostCentreStack -> CmmLit
  75 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
  76
  77 costCentreFrom :: CmmExpr       -- A closure pointer
  78                -> CmmExpr       -- The cost centre from that closure
  79 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) wordRep
  80
  81 staticProfHdr :: CostCentreStack -> [CmmLit]
  82 -- The profiling header words in a static closure
  83 -- Was SET_STATIC_PROF_HDR
  84 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
  85                                   staticLdvInit]
  86
  87 dynProfHdr :: CmmExpr -> [CmmExpr]
  88 -- Profiling header words in a dynamic closure
  89 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
  90
  91 initUpdFrameProf :: CmmExpr -> Code
  92 -- Initialise the profiling field of an update frame
  93 initUpdFrameProf frame_amode
  94   = ifProfiling $       -- frame->header.prof.ccs = CCCS
  95     stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
  96         -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
  97         -- is unnecessary because it is not used anyhow.
  98
  99 -- -----------------------------------------------------------------------------
 100 -- Recording allocation in a cost centre
 101
 102 -- | Record the allocation of a closure.  The CmmExpr is the cost
 103 -- centre stack to which to attribute the allocation.
 104 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
 105 profDynAlloc cl_info ccs
 106   = ifProfiling $
 107     profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
 108
 109 -- | Record the allocation of a closure (size is given by a CmmExpr)
 110 -- The size must be in words, because the allocation counter in a CCS counts
 111 -- in words.
 112 profAlloc :: CmmExpr -> CmmExpr -> Code
 113 profAlloc words ccs
 114   = ifProfiling $
 115     stmtC (addToMemE alloc_rep
 116                 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
 117                 (CmmMachOp (MO_U_Conv wordRep alloc_rep) $
 118                   [CmmMachOp mo_wordSub [words,
 119                                          CmmLit (mkIntCLit profHdrSize)]]))
 120                 -- subtract the "profiling overhead", which is the
 121                 -- profiling header in a closure.
 122  where
 123         alloc_rep =  REP_CostCentreStack_mem_alloc
 124
 125 -- ----------------------------------------------------------------------
 126 -- Setting the cost centre in a new closure
 127
 128 chooseDynCostCentres :: CostCentreStack
 129                      -> [Id]            -- Args
 130                      -> StgExpr         -- Body
 131                      -> FCode (CmmExpr, CmmExpr)
 132 -- Called when alllcating a closure
 133 -- Tells which cost centre to put in the object, and which
 134 -- to blame the cost of allocation on
 135 chooseDynCostCentres ccs args body = do
 136   -- Cost-centre we record in the object
 137   use_ccs <- emitCCS ccs
 138
 139   -- Cost-centre on whom we blame the allocation
 140   let blame_ccs
 141         | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
 142         | otherwise               = use_ccs
 143
 144   return (use_ccs, blame_ccs)
 145
 146
 147 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
 148 -- These pushes must be performed before we can refer to the stack in
 149 -- an expression.
 150 emitCCS :: CostCentreStack -> FCode CmmExpr
 151 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
 152   where
 153         (cc's, ccs') = decomposeCCS ccs
 154
 155         push_em ccs [] = return ccs
 156         push_em ccs (cc:rest) = do
 157           tmp <- newTemp wordRep
 158           pushCostCentre tmp ccs cc
 159           push_em (CmmReg tmp) rest
 160
 161 ccsExpr :: CostCentreStack -> CmmExpr
 162 ccsExpr ccs
 163   | isCurrentCCS ccs = curCCS
 164   | otherwise        = CmmLit (mkCCostCentreStack ccs)
 165
 166
 167 isBox :: StgExpr -> Bool
 168 -- If it's an utterly trivial RHS, then it must be
 169 -- one introduced by boxHigherOrderArgs for profiling,
 170 -- so we charge it to "OVERHEAD".
 171 -- This looks like a GROSS HACK to me --SDM
 172 isBox (StgApp fun []) = True
 173 isBox other           = False
 174
 175
 176 -- -----------------------------------------------------------------------
 177 -- Setting the current cost centre on entry to a closure
 178
 179 -- For lexically scoped profiling we have to load the cost centre from
 180 -- the closure entered, if the costs are not supposed to be inherited.
 181 -- This is done immediately on entering the fast entry point.
 182
 183 -- Load current cost centre from closure, if not inherited.
 184 -- Node is guaranteed to point to it, if profiling and not inherited.
 185
 186 enterCostCentre
 187    :: ClosureInfo
 188    -> CostCentreStack
 189    -> StgExpr   -- The RHS of the closure
 190    -> Code
 191
 192 -- We used to have a special case for bindings of form
 193 --      f = g True
 194 -- where g has arity 2.  The RHS is a thunk, but we don't
 195 -- need to update it; and we want to subsume costs.
 196 -- We don't have these sort of PAPs any more, so the special
 197 -- case has gone away.
 198
 199 enterCostCentre closure_info ccs body
 200   = ifProfiling $
 201     ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
 202     enter_cost_centre closure_info ccs body
 203
 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 (CmmReg nodeReg)
 245     is_box     = isBox body
 246
 247 -- set the current CCS when entering a PAP
 248 enterCostCentrePAP :: CmmExpr -> Code
 249 enterCostCentrePAP closure =
 250   ifProfiling $ do
 251     enter_ccs_fun (costCentreFrom closure)
 252     enteringPAP 1
 253
 254 enterCostCentreThunk :: CmmExpr -> Code
 255 enterCostCentreThunk closure =
 256   ifProfiling $ do
 257     stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
 258
 259 enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
 260
 261 enter_ccs_fsub = enteringPAP 0
 262
 263 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
 264 -- code and the function entry code; we don't want the function's
 265 -- entry code to also update CCCS in the event that it was called via
 266 -- a PAP, so we set the flag entering_PAP to indicate that we are
 267 -- entering via a PAP.
 268 enteringPAP :: Integer -> Code
 269 enteringPAP n
 270   = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
 271                 (CmmLit (CmmInt n cIntRep)))
 272
 273 ifProfiling :: Code -> Code
 274 ifProfiling code
 275   | opt_SccProfilingOn = code
 276   | otherwise          = nopC
 277
 278 ifProfilingL :: [a] -> [a]
 279 ifProfilingL xs
 280   | opt_SccProfilingOn = xs
 281   | otherwise          = []
 282
 283
 284 -- ---------------------------------------------------------------------------
 285 -- Initialising Cost Centres & CCSs
 286
 287 emitCostCentreDecl
 288    :: CostCentre
 289    -> Code
 290 emitCostCentreDecl cc = do
 291   { label <- mkStringCLit (costCentreUserName cc)
 292   ; modl  <- mkStringCLit (moduleUserString (cc_mod cc))
 293   ; let
 294      lits = [ zero,     -- StgInt ccID,
 295               label,    -- char *label,
 296               modl,     -- char *module,
 297               zero,     -- StgWord time_ticks
 298               zero64,   -- StgWord64 mem_alloc
 299               subsumed, -- StgInt is_caf
 300               zero      -- struct _CostCentre *link
 301             ]
 302   ; emitDataLits (mkCCLabel cc) lits
 303   }
 304   where
 305         subsumed | isCafCC cc = mkIntCLit (ord 'c')  -- 'c' == is a CAF
 306                  | otherwise  = mkIntCLit (ord 'B')  -- 'B' == is boring
 307
 308
 309 emitCostCentreStackDecl
 310    :: CostCentreStack
 311    -> Code
 312 emitCostCentreStackDecl ccs
 313   | Just cc <- maybeSingletonCCS ccs = do
 314   { let
 315      lits = [ zero,
 316               mkCCostCentre cc,
 317               zero,   -- struct _CostCentreStack *prevStack;
 318               zero,   -- struct _IndexTable *indexTable;
 319               zero,   -- StgWord    selected;
 320               zero64, -- StgWord64  scc_count;
 321               zero,   -- StgWord    time_ticks;
 322               zero64, -- StgWord64  mem_alloc;
 323               zero,   -- StgWord    inherited_ticks;
 324               zero64, -- StgWord64  inherited_alloc;
 325               zero    -- CostCentre *root;
 326            ]
 327   ; emitDataLits (mkCCSLabel ccs) lits
 328   }
 329   | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
 330
 331 zero = mkIntCLit 0
 332 zero64 = CmmInt 0 I64
 333
 334
 335 -- ---------------------------------------------------------------------------
 336 -- Registering CCs and CCSs
 337
 338 --   (cc)->link = CC_LIST;
 339 --   CC_LIST = (cc);
 340 --   (cc)->ccID = CC_ID++;
 341
 342 emitRegisterCC :: CostCentre -> Code
 343 emitRegisterCC cc = do
 344   { tmp <- newTemp cIntRep
 345   ; stmtsC [
 346      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
 347                  (CmmLoad cC_LIST wordRep),
 348      CmmStore cC_LIST cc_lit,
 349      CmmAssign tmp (CmmLoad cC_ID cIntRep),
 350      CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
 351      CmmStore cC_ID (cmmRegOffB tmp 1)
 352    ]
 353   }
 354   where
 355     cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
 356
 357 --  (ccs)->prevStack = CCS_LIST;
 358 --  CCS_LIST = (ccs);
 359 --  (ccs)->ccsID = CCS_ID++;
 360
 361 emitRegisterCCS :: CostCentreStack -> Code
 362 emitRegisterCCS ccs = do
 363   { tmp <- newTemp cIntRep
 364   ; stmtsC [
 365      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
 366                         (CmmLoad cCS_LIST wordRep),
 367      CmmStore cCS_LIST ccs_lit,
 368      CmmAssign tmp (CmmLoad cCS_ID cIntRep),
 369      CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
 370      CmmStore cCS_ID (cmmRegOffB tmp 1)
 371    ]
 372   }
 373   where
 374     ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
 375
 376
 377 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
 378 cC_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
 379
 380 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
 381 cCS_ID   = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
 382
 383 -- ---------------------------------------------------------------------------
 384 -- Set the current cost centre stack
 385
 386 emitSetCCC :: CostCentre -> Code
 387 emitSetCCC cc
 388   | not opt_SccProfilingOn = nopC
 389   | otherwise = do
 390     tmp <- newTemp wordRep
 391     ASSERT( sccAbleCostCentre cc )
 392       pushCostCentre tmp curCCS cc
 393     stmtC (CmmStore curCCSAddr (CmmReg tmp))
 394     when (isSccCountCostCentre cc) $
 395         stmtC (bumpSccCount curCCS)
 396
 397 pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
 398 pushCostCentre result ccs cc
 399   = emitRtsCallWithResult result PtrHint
 400         SLIT("PushCostCentre") [(ccs,PtrHint),
 401                                 (CmmLit (mkCCostCentre cc), PtrHint)]
 402
 403 bumpSccCount :: CmmExpr -> CmmStmt
 404 bumpSccCount ccs
 405   = addToMem REP_CostCentreStack_scc_count
 406          (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
 407
 408 -----------------------------------------------------------------------------
 409 --
 410 --              Lag/drag/void stuff
 411 --
 412 -----------------------------------------------------------------------------
 413
 414 --
 415 -- Initial value for the LDV field in a static closure
 416 --
 417 staticLdvInit :: CmmLit
 418 staticLdvInit = zeroCLit
 419
 420 --
 421 -- Initial value of the LDV field in a dynamic closure
 422 --
 423 dynLdvInit :: CmmExpr
 424 dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
 425   CmmMachOp mo_wordOr [
 426       CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
 427       CmmLit (mkWordCLit lDV_STATE_CREATE)
 428   ]
 429
 430 --
 431 -- Initialise the LDV word of a new closure
 432 --
 433 ldvRecordCreate :: CmmExpr -> Code
 434 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
 435
 436 --
 437 -- Called when a closure is entered, marks the closure as having been "used".
 438 -- The closure is not an 'inherently used' one.
 439 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
 440 -- profiling.
 441 --
 442 ldvEnter :: CmmExpr -> Code
 443 -- Argument is a closure pointer
 444 ldvEnter cl_ptr
 445   =  ifProfiling $
 446      -- if (era > 0) {
 447      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
 448      --                era | LDV_STATE_USE }
 449     emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
 450            (stmtC (CmmStore ldv_wd new_ldv_wd))
 451   where
 452     ldv_wd = ldvWord cl_ptr
 453     new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
 454                                        (CmmLit (mkWordCLit lDV_CREATE_MASK)))
 455                  (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
 456
 457 loadEra :: CmmExpr
 458 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
 459           [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
 460
 461 ldvWord :: CmmExpr -> CmmExpr
 462 -- Takes the address of a closure, and returns
 463 -- the address of the LDV word in the closure
 464 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
 465
 466 -- LDV constants, from ghc/includes/Constants.h
 467 lDV_SHIFT        = (LDV_SHIFT :: Int)
 468 --lDV_STATE_MASK   = (LDV_STATE_MASK :: StgWord)
 469 lDV_CREATE_MASK  = (LDV_CREATE_MASK :: StgWord)
 470 --lDV_LAST_MASK    = (LDV_LAST_MASK :: StgWord)
 471 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
 472 lDV_STATE_USE    = (LDV_STATE_USE :: StgWord)
 473