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 CmmExpr
  52 import MkGraph
  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 (fsLit "UPDF_PUSHED_ctr")
 125 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
 126
 127 -- -----------------------------------------------------------------------------
 128 -- Ticky entries
 129
 130 tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
 131     tickyEnterStaticThunk, tickyEnterViaNode :: FCode ()
 132 tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
 133 tickyEnterDynThunk    = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
 134 tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
 135 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
 136 tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "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 = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
 148         | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
 149
 150 tickyUpdateBhCaf :: ClosureInfo -> FCode ()
 151 tickyUpdateBhCaf cl_info
 152   = ifTicky (bumpTickyCounter ctr)
 153   where
 154     ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
 155         | otherwise              = (fsLit "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 = (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
 167         | otherwise               = (fsLit "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 (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
 191
 192 tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
 193 tickyReturnOldCon arity
 194   = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
 195                  ; bumpHistogram    (fsLit "RET_OLD_hst") arity }
 196 tickyReturnNewCon arity
 197   = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
 198                  ; bumpHistogram    (fsLit "RET_NEW_hst") arity }
 199
 200 tickyUnboxedTupleReturn :: Int -> FCode ()
 201 tickyUnboxedTupleReturn arity
 202   = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
 203                  ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }
 204
 205 tickyVectoredReturn :: Int -> FCode ()
 206 tickyVectoredReturn family_size
 207   = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
 208                  ; bumpHistogram    (fsLit "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 (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
 222
 223 tickyKnownCallExact :: FCode ()
 224 tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
 225
 226 tickyKnownCallExtraArgs :: FCode ()
 227 tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
 228
 229 tickyUnknownCall :: FCode ()
 230 tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
 231
 232 -- Tick for the call pattern at slow call site (i.e. in addition to
 233 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
 234 tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
 235 tickySlowCall _ []
 236   = return ()
 237 tickySlowCall lf_info args
 238   = do  { if (isKnownFun lf_info)
 239                 then tickyKnownCallTooFewArgs
 240                 else tickyUnknownCall
 241         ; tickySlowCallPat (map argPrimRep args) }
 242
 243 tickySlowCallPat :: [PrimRep] -> FCode ()
 244 tickySlowCallPat _args = return ()
 245 {- LATER: (introduces recursive module dependency now).
 246   case callPattern args of
 247     (str, True)  -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
 248     (str, False) -> bumpTickyCounter  (sLit "TICK_SLOW_CALL_OTHER")
 249
 250 callPattern :: [CgRep] -> (String,Bool)
 251 callPattern reps
 252   | match == length reps = (chars, True)
 253   | otherwise            = (chars, False)
 254   where (_,match) = findMatch reps
 255         chars     = map argChar reps
 256
 257 argChar VoidArg   = 'v'
 258 argChar PtrArg    = 'p'
 259 argChar NonPtrArg = 'n'
 260 argChar LongArg   = 'l'
 261 argChar FloatArg  = 'f'
 262 argChar DoubleArg = 'd'
 263 -}
 264
 265 -- -----------------------------------------------------------------------------
 266 -- Ticky allocation
 267
 268 tickyDynAlloc :: ClosureInfo -> FCode ()
 269 -- Called when doing a dynamic heap allocation
 270 tickyDynAlloc cl_info
 271   = ifTicky $
 272     case smRepClosureType (closureSMRep cl_info) of
 273         Just Constr           -> tick_alloc_con
 274         Just ConstrNoCaf      -> tick_alloc_con
 275         Just Fun              -> tick_alloc_fun
 276         Just Thunk            -> tick_alloc_thk
 277         Just ThunkSelector    -> tick_alloc_thk
 278         -- black hole
 279         Nothing               -> return ()
 280   where
 281         -- will be needed when we fill in stubs
 282     _cl_size   =        closureSize cl_info
 283     _slop_size = slopSize cl_info
 284
 285     tick_alloc_thk
 286         | closureUpdReqd cl_info = tick_alloc_up_thk
 287         | otherwise              = tick_alloc_se_thk
 288
 289     -- krc: changed from panic to return ()
 290     -- just to get something working
 291     tick_alloc_con = return ()
 292     tick_alloc_fun = return ()
 293     tick_alloc_up_thk = return ()
 294     tick_alloc_se_thk = return ()
 295
 296
 297 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 298 tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
 299
 300 tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
 301 tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
 302
 303 tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
 304 tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
 305
 306 tickyAllocHeap :: VirtualHpOffset -> FCode ()
 307 -- Called when doing a heap check [TICK_ALLOC_HEAP]
 308 -- Must be lazy in the amount of allocation!
 309 tickyAllocHeap hp
 310   = ifTicky $
 311     do  { ticky_ctr <- getTickyCtrLabel
 312         ; emit $ catAGraphs $
 313           if hp == 0 then []    -- Inside the emitMiddle to avoid control
 314           else [                -- dependency on the argument
 315                 -- Bump the allcoation count in the StgEntCounter
 316             addToMem REP_StgEntCounter_allocs
 317                         (CmmLit (cmmLabelOffB ticky_ctr
 318                                 oFFSET_StgEntCounter_allocs)) hp,
 319                 -- Bump ALLOC_HEAP_ctr
 320             addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1,
 321                 -- Bump ALLOC_HEAP_tot
 322             addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] }
 323
 324 -- -----------------------------------------------------------------------------
 325 -- Ticky utils
 326
 327 ifTicky :: FCode () -> FCode ()
 328 ifTicky code = do dflags <- getDynFlags
 329                   if doingTickyProfiling dflags then code
 330                                                 else nopC
 331
 332 -- All the ticky-ticky counters are declared "unsigned long" in C
 333 bumpTickyCounter :: FastString -> FCode ()
 334 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
 335
 336 bumpTickyCounter' :: CmmLit -> FCode ()
 337 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
 338 bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
 339
 340 bumpHistogram :: FastString -> Int -> FCode ()
 341 bumpHistogram _lbl _n
 342 --  = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
 343     = return ()    -- TEMP SPJ Apr 07
 344
 345 {-
 346 bumpHistogramE :: LitString -> CmmExpr -> FCode ()
 347 bumpHistogramE lbl n
 348   = do  t <- newTemp cLong
 349         emit (mkAssign (CmmLocal t) n)
 350         emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
 351                           (mkAssign (CmmLocal t) eight))
 352         emit (addToMem cLong
 353                        (cmmIndexExpr cLongWidth
 354                                 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
 355                                 (CmmReg (CmmLocal t)))
 356                        1)
 357   where
 358    eight = CmmLit (CmmInt 8 cLongWidth)
 359 -}
 360
 361 ------------------------------------------------------------------
 362 -- Showing the "type category" for ticky-ticky profiling
 363
 364 showTypeCategory :: Type -> Char
 365   {-    {C,I,F,D}   char, int, float, double
 366         T           tuple
 367         S           other single-constructor type
 368         {c,i,f,d}   unboxed ditto
 369         t           *unpacked* tuple
 370         s           *unpacked" single-cons...
 371
 372         v           void#
 373         a           primitive array
 374
 375         E           enumeration type
 376         +           dictionary, unless it's a ...
 377         L           List
 378         >           function
 379         M           other (multi-constructor) data-con type
 380         .           other type
 381         -           reserved for others to mark as "uninteresting"
 382     -}
 383 showTypeCategory ty
 384   = if isDictTy ty
 385     then '+'
 386     else
 387       case tcSplitTyConApp_maybe ty of
 388         Nothing -> if isJust (tcSplitFunTy_maybe ty)
 389                    then '>'
 390                    else '.'
 391
 392         Just (tycon, _) ->
 393           let utc = getUnique tycon in
 394           if      utc == charDataConKey    then 'C'
 395           else if utc == intDataConKey     then 'I'
 396           else if utc == floatDataConKey   then 'F'
 397           else if utc == doubleDataConKey  then 'D'
 398           else if utc == charPrimTyConKey  then 'c'
 399           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 400                 || utc == addrPrimTyConKey)                then 'i'
 401           else if utc  == floatPrimTyConKey                then 'f'
 402           else if utc  == doublePrimTyConKey               then 'd'
 403           else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
 404           else if isEnumerationTyCon tycon                 then 'E'
 405           else if isTupleTyCon tycon                       then 'T'
 406           else if isJust (tyConSingleDataCon_maybe tycon)       then 'S'
 407           else if utc == listTyConKey                      then 'L'
 408           else 'M' -- oh, well...