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