compiler/codeGen/CgTicky.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generation for ticky-ticky profiling
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CgTicky (
  10         emitTickyCounter,
  11
  12         tickyDynAlloc,
  13         tickyAllocHeap,
  14         tickyAllocPrim,
  15         tickyAllocThunk,
  16         tickyAllocPAP,
  17
  18         tickyPushUpdateFrame,
  19         tickyUpdateFrameOmitted,
  20
  21         tickyEnterDynCon,
  22         tickyEnterStaticCon,
  23         tickyEnterViaNode,
  24
  25         tickyEnterFun,
  26         tickyEnterThunk,
  27
  28         tickyUpdateBhCaf,
  29         tickyBlackHole,
  30         tickyUnboxedTupleReturn, tickyVectoredReturn,
  31         tickyReturnOldCon, tickyReturnNewCon,
  32
  33         tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
  34         tickyUnknownCall, tickySlowCallPat,
  35
  36        staticTickyHdr,
  37   ) where
  38
  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 CmmUtils
  49 import CLabel
  50
  51 import Name
  52 import Id
  53 import IdInfo
  54 import BasicTypes
  55 import FastString
  56 import Constants
  57 import Outputable
  58 import Module
  59
  60 -- Turgid imports for showTypeCategory
  61 import PrelNames
  62 import TcType
  63 import TyCon
  64
  65 import DynFlags
  66
  67 import Data.Maybe
  68
  69 -----------------------------------------------------------------------------
  70 --
  71 --              Ticky-ticky profiling
  72 --
  73 -----------------------------------------------------------------------------
  74
  75 staticTickyHdr :: [CmmLit]
  76 -- krc: not using this right now --
  77 -- in the new version of ticky-ticky, we
  78 -- don't change the closure layout.
  79 -- leave it defined, though, to avoid breaking
  80 -- other things.
  81 staticTickyHdr = []
  82
  83 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
  84 emitTickyCounter cl_info args on_stk
  85   = ifTicky $
  86     do  { mod_name <- getModuleName
  87         ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
  88         ; arg_descr_lit <- mkStringCLit arg_descr
  89         ; emitDataLits ticky_ctr_label  -- Must match layout of StgEntCounter
  90 -- krc: note that all the fields are I32 now; some were I16 before,
  91 -- but the code generator wasn't handling that properly and it led to chaos,
  92 -- panic and disorder.
  93             [ mkIntCLit 0,
  94               mkIntCLit (length args),-- Arity
  95               mkIntCLit on_stk, -- Words passed on stack
  96               fun_descr_lit,
  97               arg_descr_lit,
  98               zeroCLit,                 -- Entry count
  99               zeroCLit,                 -- Allocs
 100               zeroCLit                  -- Link
 101             ] }
 102   where
 103     name = closureName cl_info
 104     ticky_ctr_label = mkRednCountsLabel name NoCafRefs
 105     arg_descr = map (showTypeCategory . idType) args
 106     fun_descr mod_name = ppr_for_ticky_name mod_name name
 107
 108 -- When printing the name of a thing in a ticky file, we want to
 109 -- give the module name even for *local* things.   We print
 110 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
 111 ppr_for_ticky_name :: Module -> Name -> String
 112 ppr_for_ticky_name mod_name name
 113   | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
 114   | otherwise           = showSDocDebug (ppr name)
 115
 116 -- -----------------------------------------------------------------------------
 117 -- Ticky stack frames
 118
 119 tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code
 120 tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr")
 121 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr")
 122
 123 -- -----------------------------------------------------------------------------
 124 -- Ticky entries
 125
 126 tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
 127     tickyEnterStaticThunk, tickyEnterViaNode :: Code
 128 tickyEnterDynCon      = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr")
 129 tickyEnterDynThunk    = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr")
 130 tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr")
 131 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr")
 132 tickyEnterViaNode     = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr")
 133
 134 tickyEnterThunk :: ClosureInfo -> Code
 135 tickyEnterThunk cl_info
 136   | isStaticClosure cl_info = tickyEnterStaticThunk
 137   | otherwise               = tickyEnterDynThunk
 138
 139 tickyBlackHole :: Bool{-updatable-} -> Code
 140 tickyBlackHole updatable
 141   = ifTicky (bumpTickyCounter ctr)
 142   where
 143     ctr | updatable = sLit "UPD_BH_SINGLE_ENTRY_ctr"
 144         | otherwise = sLit "UPD_BH_UPDATABLE_ctr"
 145
 146 tickyUpdateBhCaf :: ClosureInfo -> Code
 147 tickyUpdateBhCaf cl_info
 148   = ifTicky (bumpTickyCounter ctr)
 149   where
 150     ctr | closureUpdReqd cl_info = sLit "UPD_CAF_BH_SINGLE_ENTRY_ctr"
 151         | otherwise              = sLit "UPD_CAF_BH_UPDATABLE_ctr"
 152
 153 tickyEnterFun :: ClosureInfo -> Code
 154 tickyEnterFun cl_info
 155   = ifTicky $
 156     do  { bumpTickyCounter ctr
 157         ; fun_ctr_lbl <- getTickyCtrLabel
 158         ; registerTickyCtr fun_ctr_lbl
 159         ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
 160         }
 161   where
 162     ctr | isStaticClosure cl_info = sLit "ENT_STATIC_FUN_DIRECT_ctr"
 163         | otherwise               = sLit "ENT_DYN_FUN_DIRECT_ctr"
 164
 165 registerTickyCtr :: CLabel -> Code
 166 -- Register a ticky counter
 167 --   if ( ! f_ct.registeredp ) {
 168 --          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */
 169 --          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */
 170 --          f_ct.registeredp = 1 }
 171 registerTickyCtr ctr_lbl
 172   = emitIf test (stmtsC register_stmts)
 173   where
 174     -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
 175     test = CmmMachOp (MO_Eq wordWidth)
 176               [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
 177                                 oFFSET_StgEntCounter_registeredp)) bWord,
 178                CmmLit (mkIntCLit 0)]
 179     register_stmts
 180       = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
 181                    (CmmLoad ticky_entry_ctrs bWord)
 182         , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
 183         , CmmStore (CmmLit (cmmLabelOffB ctr_lbl
 184                                 oFFSET_StgEntCounter_registeredp))
 185                    (CmmLit (mkIntCLit 1)) ]
 186     ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs"))
 187
 188 tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
 189 tickyReturnOldCon arity
 190   = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr")
 191                  ; bumpHistogram (sLit "RET_OLD_hst") arity }
 192 tickyReturnNewCon arity
 193   = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr")
 194                  ; bumpHistogram (sLit "RET_NEW_hst") arity }
 195
 196 tickyUnboxedTupleReturn :: Int -> Code
 197 tickyUnboxedTupleReturn arity
 198   = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr")
 199                  ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity }
 200
 201 tickyVectoredReturn :: Int -> Code
 202 tickyVectoredReturn family_size
 203   = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr")
 204                  ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size }
 205
 206 -- -----------------------------------------------------------------------------
 207 -- Ticky calls
 208
 209 -- Ticks at a *call site*:
 210 tickyKnownCallTooFewArgs, tickyKnownCallExact,
 211     tickyKnownCallExtraArgs, tickyUnknownCall :: Code
 212 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
 213 tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr")
 214 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr")
 215 tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr")
 216
 217 -- Tick for the call pattern at slow call site (i.e. in addition to
 218 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
 219 tickySlowCallPat :: [CgRep] -> Code
 220 tickySlowCallPat _args = return ()
 221 {- LATER: (introduces recursive module dependency now).
 222   case callPattern args of
 223     (str, True)  -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
 224     (str, False) -> bumpTickyCounter  (sLit "TICK_SLOW_CALL_OTHER")
 225
 226 callPattern :: [CgRep] -> (String,Bool)
 227 callPattern reps
 228   | match == length reps = (chars, True)
 229   | otherwise            = (chars, False)
 230   where (_,match) = findMatch reps
 231         chars     = map argChar reps
 232
 233 argChar VoidArg   = 'v'
 234 argChar PtrArg    = 'p'
 235 argChar NonPtrArg = 'n'
 236 argChar LongArg   = 'l'
 237 argChar FloatArg  = 'f'
 238 argChar DoubleArg = 'd'
 239 -}
 240
 241 -- -----------------------------------------------------------------------------
 242 -- Ticky allocation
 243
 244 tickyDynAlloc :: ClosureInfo -> Code
 245 -- Called when doing a dynamic heap allocation
 246 tickyDynAlloc cl_info
 247   = ifTicky $
 248     case smRepClosureType (closureSMRep cl_info) of
 249         Just Constr           -> tick_alloc_con
 250         Just ConstrNoCaf      -> tick_alloc_con
 251         Just Fun              -> tick_alloc_fun
 252         Just Thunk            -> tick_alloc_thk
 253         Just ThunkSelector    -> tick_alloc_thk
 254         -- black hole
 255         Nothing               -> return ()
 256   where
 257         -- will be needed when we fill in stubs
 258     _cl_size   =        closureSize cl_info
 259     _slop_size = slopSize cl_info
 260
 261     tick_alloc_thk
 262         | closureUpdReqd cl_info = tick_alloc_up_thk
 263         | otherwise              = tick_alloc_se_thk
 264
 265     -- krc: changed from panic to return ()
 266     -- just to get something working
 267     tick_alloc_con = return ()
 268     tick_alloc_fun = return ()
 269     tick_alloc_up_thk = return ()
 270     tick_alloc_se_thk = return ()
 271
 272
 273 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 274 tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
 275
 276 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
 277 tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
 278
 279 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
 280 tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
 281
 282 tickyAllocHeap :: VirtualHpOffset -> Code
 283 -- Called when doing a heap check [TICK_ALLOC_HEAP]
 284 tickyAllocHeap hp
 285   = ifTicky $
 286     do  { ticky_ctr <- getTickyCtrLabel
 287         ; stmtsC $
 288           if hp == 0 then []    -- Inside the stmtC to avoid control
 289           else [                -- dependency on the argument
 290                 -- Bump the allcoation count in the StgEntCounter
 291             addToMem (typeWidth REP_StgEntCounter_allocs)
 292                         (CmmLit (cmmLabelOffB ticky_ctr
 293                                 oFFSET_StgEntCounter_allocs)) hp,
 294                 -- Bump ALLOC_HEAP_ctr
 295             addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_ctr") 1,
 296                 -- Bump ALLOC_HEAP_tot
 297             addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_tot") hp] }
 298
 299 -- -----------------------------------------------------------------------------
 300 -- Ticky utils
 301
 302 ifTicky :: Code -> Code
 303 ifTicky code = do dflags <- getDynFlags
 304                   if doingTickyProfiling dflags then code
 305                                                 else nopC
 306
 307 addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
 308 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
 309
 310 -- All the ticky-ticky counters are declared "unsigned long" in C
 311 bumpTickyCounter :: LitString -> Code
 312 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
 313
 314 bumpTickyCounter' :: CmmLit -> Code
 315 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
 316 bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1)
 317
 318 bumpHistogram :: LitString -> Int -> Code
 319 bumpHistogram _lbl _n
 320 --  = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong))
 321     = return ()    -- TEMP SPJ Apr 07
 322
 323 {-
 324 bumpHistogramE :: LitString -> CmmExpr -> Code
 325 bumpHistogramE lbl n
 326   = do  t <- newTemp cLong
 327         stmtC (CmmAssign (CmmLocal t) n)
 328         emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $
 329                 stmtC (CmmAssign (CmmLocal t) eight)
 330         stmtC (addToMemLong (cmmIndexExpr cLongWidth
 331                                 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
 332                                 (CmmReg (CmmLocal t)))
 333                             1)
 334   where
 335    eight = CmmLit (CmmInt 8 cLongWidth)
 336 -}
 337
 338 ------------------------------------------------------------------
 339 addToMemLong :: CmmExpr -> Int -> CmmStmt
 340 addToMemLong = addToMem cLongWidth
 341
 342 ------------------------------------------------------------------
 343 -- Showing the "type category" for ticky-ticky profiling
 344
 345 showTypeCategory :: Type -> Char
 346   {-    {C,I,F,D}   char, int, float, double
 347         T           tuple
 348         S           other single-constructor type
 349         {c,i,f,d}   unboxed ditto
 350         t           *unpacked* tuple
 351         s           *unpacked" single-cons...
 352
 353         v           void#
 354         a           primitive array
 355
 356         E           enumeration type
 357         +           dictionary, unless it's a ...
 358         L           List
 359         >           function
 360         M           other (multi-constructor) data-con type
 361         .           other type
 362         -           reserved for others to mark as "uninteresting"
 363     -}
 364 showTypeCategory ty
 365   = if isDictTy ty
 366     then '+'
 367     else
 368       case tcSplitTyConApp_maybe ty of
 369         Nothing -> if isJust (tcSplitFunTy_maybe ty)
 370                    then '>'
 371                    else '.'
 372
 373         Just (tycon, _) ->
 374           let utc = getUnique tycon in
 375           if      utc == charDataConKey    then 'C'
 376           else if utc == intDataConKey     then 'I'
 377           else if utc == floatDataConKey   then 'F'
 378           else if utc == doubleDataConKey  then 'D'
 379           else if utc == charPrimTyConKey  then 'c'
 380           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 381                 || utc == addrPrimTyConKey)                then 'i'
 382           else if utc  == floatPrimTyConKey                then 'f'
 383           else if utc  == doublePrimTyConKey               then 'd'
 384           else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
 385           else if isEnumerationTyCon tycon                 then 'E'
 386           else if isTupleTyCon tycon                       then 'T'
 387           else if isJust (tyConSingleDataCon_maybe tycon)       then 'S'
 388           else if utc == listTyConKey                      then 'L'
 389           else 'M' -- oh, well...