compiler/codeGen/CgTicky.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 -----------------------------------------------------------------------------
   9 --
  10 -- Code generation for ticky-ticky profiling
  11 --
  12 -- (c) The University of Glasgow 2004-2006
  13 --
  14 -----------------------------------------------------------------------------
  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 "../includes/DerivedConstants.h"
  47         -- For REP_xxx constants, which are MachReps
  48
  49 import ClosureInfo
  50 import CgUtils
  51 import CgMonad
  52 import SMRep
  53
  54 import Cmm
  55 import MachOp
  56 import CmmUtils
  57 import CLabel
  58
  59 import Name
  60 import Id
  61 import StaticFlags
  62 import BasicTypes
  63 import FastString
  64 import Constants
  65 import Outputable
  66
  67 -- Turgid imports for showTypeCategory
  68 import PrelNames
  69 import TcType
  70 import TyCon
  71
  72 import Data.Maybe
  73
  74 -----------------------------------------------------------------------------
  75 --
  76 --              Ticky-ticky profiling
  77 --
  78 -----------------------------------------------------------------------------
  79
  80 staticTickyHdr :: [CmmLit]
  81 -- krc: not using this right now --
  82 -- in the new version of ticky-ticky, we
  83 -- don't change the closure layout.
  84 -- leave it defined, though, to avoid breaking
  85 -- other things.
  86 staticTickyHdr = []
  87
  88 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
  89 emitTickyCounter cl_info args on_stk
  90   = ifTicky $
  91     do  { mod_name <- getModuleName
  92         ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
  93         ; arg_descr_lit <- mkStringCLit arg_descr
  94         ; emitDataLits ticky_ctr_label  -- Must match layout of StgEntCounter
  95 -- krc: note that all the fields are I32 now; some were I16 before,
  96 -- but the code generator wasn't handling that properly and it led to chaos,
  97 -- panic and disorder.
  98             [ mkIntCLit 0,
  99               mkIntCLit (length args),-- Arity
 100               mkIntCLit on_stk, -- Words passed on stack
 101               fun_descr_lit,
 102               arg_descr_lit,
 103               zeroCLit,                 -- Entry count
 104               zeroCLit,                 -- Allocs
 105               zeroCLit                  -- Link
 106             ] }
 107   where
 108     name = closureName cl_info
 109     ticky_ctr_label = mkRednCountsLabel name
 110     arg_descr = map (showTypeCategory . idType) args
 111     fun_descr mod_name = ppr_for_ticky_name mod_name name
 112
 113 -- When printing the name of a thing in a ticky file, we want to
 114 -- give the module name even for *local* things.   We print
 115 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
 116 ppr_for_ticky_name mod_name name
 117   | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
 118   | otherwise           = showSDocDebug (ppr name)
 119
 120 -- -----------------------------------------------------------------------------
 121 -- Ticky stack frames
 122
 123 tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr")
 124 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr")
 125
 126 -- -----------------------------------------------------------------------------
 127 -- Ticky entries
 128
 129 tickyEnterDynCon      = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr")
 130 tickyEnterDynThunk    = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr")
 131 tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr")
 132 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr")
 133 tickyEnterViaNode     = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr")
 134
 135 tickyEnterThunk :: ClosureInfo -> Code
 136 tickyEnterThunk cl_info
 137   | isStaticClosure cl_info = tickyEnterStaticThunk
 138   | otherwise               = tickyEnterDynThunk
 139
 140 tickyBlackHole :: Bool{-updatable-} -> Code
 141 tickyBlackHole updatable
 142   = ifTicky (bumpTickyCounter ctr)
 143   where
 144     ctr | updatable = sLit "UPD_BH_SINGLE_ENTRY_ctr"
 145         | otherwise = sLit "UPD_BH_UPDATABLE_ctr"
 146
 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 wordRep)
 176               [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
 177                                 oFFSET_StgEntCounter_registeredp)) wordRep,
 178                CmmLit (mkIntCLit 0)]
 179     register_stmts
 180       = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
 181                    (CmmLoad ticky_entry_ctrs wordRep)
 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   | not opt_DoTickyProfiling = nopC
 194   | otherwise
 195   = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr")
 196                  ; bumpHistogram (sLit "RET_NEW_hst") arity }
 197
 198 tickyUnboxedTupleReturn :: Int -> Code
 199 tickyUnboxedTupleReturn arity
 200   = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr")
 201                  ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity }
 202
 203 tickyVectoredReturn :: Int -> Code
 204 tickyVectoredReturn family_size
 205   = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr")
 206                  ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size }
 207
 208 -- -----------------------------------------------------------------------------
 209 -- Ticky calls
 210
 211 -- Ticks at a *call site*:
 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 REP_StgEntCounter_allocs
 292                         (CmmLit (cmmLabelOffB ticky_ctr
 293                                 oFFSET_StgEntCounter_allocs)) hp,
 294                 -- Bump ALLOC_HEAP_ctr
 295             addToMemLbl cLongRep (mkRtsDataLabel (sLit "ALLOC_HEAP_ctr")) 1,
 296                 -- Bump ALLOC_HEAP_tot
 297             addToMemLbl cLongRep (mkRtsDataLabel (sLit "ALLOC_HEAP_tot")) hp] }
 298
 299 -- -----------------------------------------------------------------------------
 300 -- Ticky utils
 301
 302 ifTicky :: Code -> Code
 303 ifTicky code
 304   | opt_DoTickyProfiling = code
 305   | otherwise            = nopC
 306
 307 addToMemLbl :: MachRep -> 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 (addToMem cLongRep (CmmLit lhs) 1)
 317
 318 addToMemLong = addToMem cLongRep
 319
 320 bumpHistogram :: LitString -> Int -> Code
 321 bumpHistogram lbl n
 322 --  = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep))
 323     = return ()    -- TEMP SPJ Apr 07
 324
 325 bumpHistogramE :: LitString -> CmmExpr -> Code
 326 bumpHistogramE lbl n
 327   = do  t <- newNonPtrTemp cLongRep
 328         stmtC (CmmAssign (CmmLocal t) n)
 329         emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg (CmmLocal t), eight]) $
 330                 stmtC (CmmAssign (CmmLocal t) eight)
 331         stmtC (addToMemLong (cmmIndexExpr cLongRep
 332                                 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
 333                                 (CmmReg (CmmLocal t)))
 334                             1)
 335   where
 336    eight = CmmLit (CmmInt 8 cLongRep)
 337
 338 ------------------------------------------------------------------
 339 -- Showing the "type category" for ticky-ticky profiling
 340
 341 showTypeCategory :: Type -> Char
 342   {-    {C,I,F,D}   char, int, float, double
 343         T           tuple
 344         S           other single-constructor type
 345         {c,i,f,d}   unboxed ditto
 346         t           *unpacked* tuple
 347         s           *unpacked" single-cons...
 348
 349         v           void#
 350         a           primitive array
 351
 352         E           enumeration type
 353         +           dictionary, unless it's a ...
 354         L           List
 355         >           function
 356         M           other (multi-constructor) data-con type
 357         .           other type
 358         -           reserved for others to mark as "uninteresting"
 359     -}
 360 showTypeCategory ty
 361   = if isDictTy ty
 362     then '+'
 363     else
 364       case tcSplitTyConApp_maybe ty of
 365         Nothing -> if isJust (tcSplitFunTy_maybe ty)
 366                    then '>'
 367                    else '.'
 368
 369         Just (tycon, _) ->
 370           let utc = getUnique tycon in
 371           if      utc == charDataConKey    then 'C'
 372           else if utc == intDataConKey     then 'I'
 373           else if utc == floatDataConKey   then 'F'
 374           else if utc == doubleDataConKey  then 'D'
 375           else if utc == charPrimTyConKey  then 'c'
 376           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 377                 || utc == addrPrimTyConKey)                then 'i'
 378           else if utc  == floatPrimTyConKey                then 'f'
 379           else if utc  == doublePrimTyConKey               then 'd'
 380           else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
 381           else if isEnumerationTyCon tycon                 then 'E'
 382           else if isTupleTyCon tycon                       then 'T'
 383           else if isJust (tyConSingleDataCon_maybe tycon)       then 'S'
 384           else if utc == listTyConKey                      then 'L'
 385           else 'M' -- oh, well...