compiler/codeGen/StgCmmTicky.hs

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