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