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