compiler/codeGen/CgTicky.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generation for ticky-ticky profiling
   4 --
   5 -- (c) The University of Glasgow 2004
   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 "HsVersions.h"
  40 #include "../includes/DerivedConstants.h"
  41         -- For REP_xxx constants, which are MachReps
  42
  43 import ClosureInfo      ( ClosureInfo, closureSize, slopSize, closureSMRep,
  44                           closureUpdReqd, closureName, isStaticClosure )
  45 import CgUtils
  46 import CgMonad
  47 import SMRep            ( ClosureType(..), smRepClosureType, CgRep )
  48
  49 import Cmm
  50 import MachOp
  51 import CmmUtils         ( zeroCLit, mkIntCLit, mkLblExpr, cmmIndexExpr )
  52 import CLabel           ( CLabel, mkRtsDataLabel, mkRednCountsLabel )
  53
  54 import Name             ( isInternalName )
  55 import Id               ( Id, idType )
  56 import StaticFlags      ( opt_DoTickyProfiling )
  57 import BasicTypes       ( Arity )
  58 import FastString       ( FastString, mkFastString, LitString )
  59 import Constants        -- Lots of field offsets
  60 import Outputable
  61
  62 -- Turgid imports for showTypeCategory
  63 import PrelNames
  64 import TcType           ( Type, isDictTy, tcSplitTyConApp_maybe,
  65                           tcSplitFunTy_maybe )
  66 import TyCon            ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon,
  67                           maybeTyConSingleCon )
  68 import Maybe
  69
  70 -----------------------------------------------------------------------------
  71 --
  72 --              Ticky-ticky profiling
  73 --
  74 -----------------------------------------------------------------------------
  75
  76 staticTickyHdr :: [CmmLit]
  77 -- The ticky header words in a static closure
  78 -- Was SET_STATIC_TICKY_HDR
  79 staticTickyHdr
  80   | not opt_DoTickyProfiling = []
  81   | otherwise                = [zeroCLit]
  82
  83 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
  84 emitTickyCounter cl_info args on_stk
  85   = ifTicky $
  86     do  { mod_name <- moduleName
  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             [ CmmInt 0 I16,
  91               CmmInt (fromIntegral (length args)) I16,  -- Arity
  92               CmmInt (fromIntegral on_stk) I16,         -- Words passed on stack
  93               CmmInt 0 I16,                             -- 2-byte gap
  94               fun_descr_lit,
  95               arg_descr_lit,
  96               zeroCLit,                 -- Entry count
  97               zeroCLit,                 -- Allocs
  98               zeroCLit                  -- Link
  99             ] }
 100   where
 101     name = closureName cl_info
 102     ticky_ctr_label = mkRednCountsLabel name
 103     arg_descr = map (showTypeCategory . idType) args
 104     fun_descr mod_name = ppr_for_ticky_name mod_name name
 105
 106 -- When printing the name of a thing in a ticky file, we want to
 107 -- give the module name even for *local* things.   We print
 108 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
 109 ppr_for_ticky_name mod_name name
 110   | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
 111   | otherwise           = showSDocDebug (ppr name)
 112
 113 -- -----------------------------------------------------------------------------
 114 -- Ticky stack frames
 115
 116 tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr")
 117 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr")
 118
 119 -- -----------------------------------------------------------------------------
 120 -- Ticky entries
 121
 122 tickyEnterDynCon      = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr")
 123 tickyEnterDynThunk    = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr")
 124 tickyEnterStaticCon   = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr")
 125 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr")
 126 tickyEnterViaNode     = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr")
 127
 128 tickyEnterThunk :: ClosureInfo -> Code
 129 tickyEnterThunk cl_info
 130   | isStaticClosure cl_info = tickyEnterStaticThunk
 131   | otherwise               = tickyEnterDynThunk
 132
 133 tickyBlackHole :: Bool{-updatable-} -> Code
 134 tickyBlackHole updatable
 135   = ifTicky (bumpTickyCounter ctr)
 136   where
 137     ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr")
 138         | otherwise = SLIT("UPD_BH_UPDATABLE_ctr")
 139
 140 tickyUpdateBhCaf cl_info
 141   = ifTicky (bumpTickyCounter ctr)
 142   where
 143     ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr")
 144         | otherwise              = SLIT("UPD_CAF_BH_UPDATABLE_ctr")
 145
 146 tickyEnterFun :: ClosureInfo -> Code
 147 tickyEnterFun cl_info
 148   = ifTicky $
 149     do  { bumpTickyCounter ctr
 150         ; fun_ctr_lbl <- getTickyCtrLabel
 151         ; registerTickyCtr fun_ctr_lbl
 152         ; bumpTickyCounter' fun_ctr_lbl }
 153   where
 154     ctr | isStaticClosure cl_info = SLIT("TICK_ENT_STATIC_FUN_DIRECT")
 155         | otherwise               = SLIT("TICK_ENT_DYN_FUN_DIRECT")
 156
 157 registerTickyCtr :: CLabel -> Code
 158 -- Register a ticky counter
 159 --   if ( ! f_ct.registeredp ) {
 160 --          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */
 161 --          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */
 162 --          f_ct.registeredp = 1 }
 163 registerTickyCtr ctr_lbl
 164   = emitIf test (stmtsC register_stmts)
 165   where
 166     test = CmmMachOp (MO_Not I16)
 167             [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
 168                                 oFFSET_StgEntCounter_registeredp)) I16]
 169     register_stmts
 170       = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
 171                    (CmmLoad ticky_entry_ctrs wordRep)
 172         , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
 173         , CmmStore (CmmLit (cmmLabelOffB ctr_lbl
 174                                 oFFSET_StgEntCounter_registeredp))
 175                    (CmmLit (mkIntCLit 1)) ]
 176     ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel SLIT("ticky_entry_ctrs"))
 177
 178 tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
 179 tickyReturnOldCon arity
 180   = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr")
 181                  ; bumpHistogram SLIT("RET_OLD_hst") arity }
 182 tickyReturnNewCon arity
 183   | not opt_DoTickyProfiling = nopC
 184   | otherwise
 185   = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr")
 186                  ; bumpHistogram SLIT("RET_NEW_hst") arity }
 187
 188 tickyUnboxedTupleReturn :: Int -> Code
 189 tickyUnboxedTupleReturn arity
 190   = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr")
 191                  ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity }
 192
 193 tickyVectoredReturn :: Int -> Code
 194 tickyVectoredReturn family_size
 195   = ifTicky $ do { bumpTickyCounter SLIT("VEC_RETURN_ctr")
 196                  ; bumpHistogram SLIT("RET_VEC_RETURN_hst") family_size }
 197
 198 -- -----------------------------------------------------------------------------
 199 -- Ticky calls
 200
 201 -- Ticks at a *call site*:
 202 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr")
 203 tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr")
 204 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ctr")
 205 tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr")
 206
 207 -- Tick for the call pattern at slow call site (i.e. in addition to
 208 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
 209 tickySlowCallPat :: [CgRep] -> Code
 210 tickySlowCallPat args = return ()
 211 {- LATER: (introduces recursive module dependency now).
 212   case callPattern args of
 213     (str, True)  -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
 214     (str, False) -> bumpTickyCounter  SLIT("TICK_SLOW_CALL_OTHER")
 215
 216 callPattern :: [CgRep] -> (String,Bool)
 217 callPattern reps
 218   | match == length reps = (chars, True)
 219   | otherwise            = (chars, False)
 220   where (_,match) = findMatch reps
 221         chars     = map argChar reps
 222
 223 argChar VoidArg   = 'v'
 224 argChar PtrArg    = 'p'
 225 argChar NonPtrArg = 'n'
 226 argChar LongArg   = 'l'
 227 argChar FloatArg  = 'f'
 228 argChar DoubleArg = 'd'
 229 -}
 230
 231 -- -----------------------------------------------------------------------------
 232 -- Ticky allocation
 233
 234 tickyDynAlloc :: ClosureInfo -> Code
 235 -- Called when doing a dynamic heap allocation
 236 tickyDynAlloc cl_info
 237   = ifTicky $
 238     case smRepClosureType (closureSMRep cl_info) of
 239         Constr        -> tick_alloc_con
 240         ConstrNoCaf   -> tick_alloc_con
 241         Fun           -> tick_alloc_fun
 242         Thunk         -> tick_alloc_thk
 243         ThunkSelector -> tick_alloc_thk
 244   where
 245         -- will be needed when we fill in stubs
 246     cl_size   = closureSize cl_info
 247     slop_size = slopSize cl_info
 248
 249     tick_alloc_thk
 250         | closureUpdReqd cl_info = tick_alloc_up_thk
 251         | otherwise              = tick_alloc_se_thk
 252
 253     tick_alloc_con = panic "ToDo: tick_alloc"
 254     tick_alloc_fun = panic "ToDo: tick_alloc"
 255     tick_alloc_up_thk = panic "ToDo: tick_alloc"
 256     tick_alloc_se_thk = panic "ToDo: tick_alloc"
 257
 258 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 259 tickyAllocPrim hdr goods slop = ifTicky $ panic "ToDo: tickyAllocPrim"
 260
 261 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
 262 tickyAllocThunk goods slop = ifTicky $ panic "ToDo: tickyAllocThunk"
 263
 264 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
 265 tickyAllocPAP goods slop = ifTicky $ panic "ToDo: tickyAllocPAP"
 266
 267 tickyAllocHeap :: VirtualHpOffset -> Code
 268 -- Called when doing a heap check [TICK_ALLOC_HEAP]
 269 tickyAllocHeap hp
 270   = ifTicky $
 271     do  { ticky_ctr <- getTickyCtrLabel
 272         ; stmtsC $
 273           if hp == 0 then []    -- Inside the stmtC to avoid control
 274           else [                -- dependency on the argument
 275                 -- Bump the allcoation count in the StgEntCounter
 276             addToMem REP_StgEntCounter_allocs
 277                         (CmmLit (cmmLabelOffB ticky_ctr
 278                                 oFFSET_StgEntCounter_allocs)) hp,
 279                 -- Bump ALLOC_HEAP_ctr
 280             addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1,
 281                 -- Bump ALLOC_HEAP_tot
 282             addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] }
 283
 284 -- -----------------------------------------------------------------------------
 285 -- Ticky utils
 286
 287 ifTicky :: Code -> Code
 288 ifTicky code
 289   | opt_DoTickyProfiling = code
 290   | otherwise            = nopC
 291
 292 addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt
 293 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
 294
 295 -- All the ticky-ticky counters are declared "unsigned long" in C
 296 bumpTickyCounter :: LitString -> Code
 297 bumpTickyCounter lbl = bumpTickyCounter' (mkRtsDataLabel lbl)
 298
 299 bumpTickyCounter' :: CLabel -> Code
 300 bumpTickyCounter' lbl = stmtC (addToMemLbl cLongRep lbl 1)
 301
 302 addToMemLong = addToMem cLongRep
 303
 304 bumpHistogram :: LitString -> Int -> Code
 305 bumpHistogram lbl n
 306   = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep))
 307
 308 bumpHistogramE :: LitString -> CmmExpr -> Code
 309 bumpHistogramE lbl n
 310   = do  t <- newTemp cLongRep
 311         stmtC (CmmAssign t n)
 312         emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $
 313                 stmtC (CmmAssign t eight)
 314         stmtC (addToMemLong (cmmIndexExpr cLongRep
 315                                 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
 316                                 (CmmReg t))
 317                             1)
 318   where
 319    eight = CmmLit (CmmInt 8 cLongRep)
 320
 321 ------------------------------------------------------------------
 322 -- Showing the "type category" for ticky-ticky profiling
 323
 324 showTypeCategory :: Type -> Char
 325   {-    {C,I,F,D}   char, int, float, double
 326         T           tuple
 327         S           other single-constructor type
 328         {c,i,f,d}   unboxed ditto
 329         t           *unpacked* tuple
 330         s           *unpacked" single-cons...
 331
 332         v           void#
 333         a           primitive array
 334
 335         E           enumeration type
 336         +           dictionary, unless it's a ...
 337         L           List
 338         >           function
 339         M           other (multi-constructor) data-con type
 340         .           other type
 341         -           reserved for others to mark as "uninteresting"
 342     -}
 343 showTypeCategory ty
 344   = if isDictTy ty
 345     then '+'
 346     else
 347       case tcSplitTyConApp_maybe ty of
 348         Nothing -> if isJust (tcSplitFunTy_maybe ty)
 349                    then '>'
 350                    else '.'
 351
 352         Just (tycon, _) ->
 353           let utc = getUnique tycon in
 354           if      utc == charDataConKey    then 'C'
 355           else if utc == intDataConKey     then 'I'
 356           else if utc == floatDataConKey   then 'F'
 357           else if utc == doubleDataConKey  then 'D'
 358           else if utc == smallIntegerDataConKey ||
 359                   utc == largeIntegerDataConKey   then 'J'
 360           else if utc == charPrimTyConKey  then 'c'
 361           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 362                 || utc == addrPrimTyConKey)                then 'i'
 363           else if utc  == floatPrimTyConKey                then 'f'
 364           else if utc  == doublePrimTyConKey               then 'd'
 365           else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
 366           else if isEnumerationTyCon tycon                 then 'E'
 367           else if isTupleTyCon tycon                       then 'T'
 368           else if isJust (maybeTyConSingleCon tycon)       then 'S'
 369           else if utc == listTyConKey                      then 'L'
 370           else 'M' -- oh, well...