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