compiler/codeGen/StgCmmTicky.hs

   1 {-# OPTIONS -w #-}
   2 -- Lots of missing type sigs etc
   3
   4 -----------------------------------------------------------------------------
   5 --
   6 -- Code generation for ticky-ticky profiling
   7 --
   8 -- (c) The University of Glasgow 2004-2006
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module StgCmmTicky (
  13         emitTickyCounter,
  14
  15         tickyDynAlloc,
  16         tickyAllocHeap,
  17         tickyAllocPrim,
  18         tickyAllocThunk,
  19         tickyAllocPAP,
  20
  21         tickySlowCall, tickyDirectCall,
  22
  23         tickyPushUpdateFrame,
  24         tickyUpdateFrameOmitted,
  25
  26         tickyEnterDynCon,
  27         tickyEnterStaticCon,
  28         tickyEnterViaNode,
  29
  30         tickyEnterFun,
  31         tickyEnterThunk,
  32
  33         tickyUpdateBhCaf,
  34         tickyBlackHole,
  35         tickyUnboxedTupleReturn, tickyVectoredReturn,
  36         tickyReturnOldCon, tickyReturnNewCon,
  37
  38         tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
  39         tickyUnknownCall, tickySlowCallPat,
  40
  41        staticTickyHdr,
  42   ) where
  43
  44 #include "HsVersions.h"
  45 #include "../includes/DerivedConstants.h"
  46         -- For REP_xxx constants, which are MachReps
  47
  48 import StgCmmClosure
  49 import StgCmmUtils
  50 import StgCmmMonad
  51 import SMRep
  52
  53 import StgSyn
  54 import Cmm
  55 import MkZipCfgCmm
  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] -> FCode ()
  89 emitTickyCounter cl_info args
  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 0,              -- XXX: we no longer know this!  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 $ clHasCafRefs cl_info
 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 -> FCode ()
 136 tickyEnterThunk cl_info
 137   | isStaticClosure cl_info = tickyEnterStaticThunk
 138   | otherwise               = tickyEnterDynThunk
 139
 140 tickyBlackHole :: Bool{-updatable-} -> FCode ()
 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 -> FCode ()
 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 -> FCode ()
 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   = emit (mkCmmIfThen test (catAGraphs register_stmts))
 173   where
 174     -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
 175     test = CmmMachOp (MO_Eq wordWidth)
 176               [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
 177                                 oFFSET_StgEntCounter_registeredp)) bWord,
 178                CmmLit (mkIntCLit 0)]
 179     register_stmts
 180       = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
 181                    (CmmLoad ticky_entry_ctrs bWord)
 182         , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
 183         , mkStore (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 -> FCode ()
 189 tickyReturnOldCon arity
 190   = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr")
 191                  ; bumpHistogram (sLit "RET_OLD_hst") arity }
 192 tickyReturnNewCon arity
 193   = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr")
 194                  ; bumpHistogram (sLit "RET_NEW_hst") arity }
 195
 196 tickyUnboxedTupleReturn :: Int -> FCode ()
 197 tickyUnboxedTupleReturn arity
 198   = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr")
 199                  ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity }
 200
 201 tickyVectoredReturn :: Int -> FCode ()
 202 tickyVectoredReturn family_size
 203   = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr")
 204                  ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size }
 205
 206 -- -----------------------------------------------------------------------------
 207 -- Ticky calls
 208
 209 -- Ticks at a *call site*:
 210 tickyDirectCall :: Arity -> [StgArg] -> FCode ()
 211 tickyDirectCall arity args
 212   | arity == length args = tickyKnownCallExact
 213   | otherwise = do tickyKnownCallExtraArgs
 214                    tickySlowCallPat (map argPrimRep (drop arity args))
 215
 216 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
 217 tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr")
 218 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr")
 219 tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr")
 220
 221 -- Tick for the call pattern at slow call site (i.e. in addition to
 222 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
 223 tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
 224 tickySlowCall lf_info []
 225   = return ()
 226 tickySlowCall lf_info args
 227   = do  { if (isKnownFun lf_info)
 228                 then tickyKnownCallTooFewArgs
 229                 else tickyUnknownCall
 230         ; tickySlowCallPat (map argPrimRep args) }
 231
 232 tickySlowCallPat :: [PrimRep] -> FCode ()
 233 tickySlowCallPat args = return ()
 234 {- LATER: (introduces recursive module dependency now).
 235   case callPattern args of
 236     (str, True)  -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
 237     (str, False) -> bumpTickyCounter  (sLit "TICK_SLOW_CALL_OTHER")
 238
 239 callPattern :: [CgRep] -> (String,Bool)
 240 callPattern reps
 241   | match == length reps = (chars, True)
 242   | otherwise            = (chars, False)
 243   where (_,match) = findMatch reps
 244         chars     = map argChar reps
 245
 246 argChar VoidArg   = 'v'
 247 argChar PtrArg    = 'p'
 248 argChar NonPtrArg = 'n'
 249 argChar LongArg   = 'l'
 250 argChar FloatArg  = 'f'
 251 argChar DoubleArg = 'd'
 252 -}
 253
 254 -- -----------------------------------------------------------------------------
 255 -- Ticky allocation
 256
 257 tickyDynAlloc :: ClosureInfo -> FCode ()
 258 -- Called when doing a dynamic heap allocation
 259 tickyDynAlloc cl_info
 260   = ifTicky $
 261     case smRepClosureType (closureSMRep cl_info) of
 262         Just Constr           -> tick_alloc_con
 263         Just ConstrNoCaf      -> tick_alloc_con
 264         Just Fun              -> tick_alloc_fun
 265         Just Thunk            -> tick_alloc_thk
 266         Just ThunkSelector    -> tick_alloc_thk
 267         -- black hole
 268         Nothing               -> return ()
 269   where
 270         -- will be needed when we fill in stubs
 271     cl_size   = closureSize cl_info
 272     slop_size = slopSize cl_info
 273
 274     tick_alloc_thk
 275         | closureUpdReqd cl_info = tick_alloc_up_thk
 276         | otherwise              = tick_alloc_se_thk
 277
 278     -- krc: changed from panic to return ()
 279     -- just to get something working
 280     tick_alloc_con = return ()
 281     tick_alloc_fun = return ()
 282     tick_alloc_up_thk = return ()
 283     tick_alloc_se_thk = return ()
 284
 285
 286 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 287 tickyAllocPrim hdr goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
 288
 289 tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
 290 tickyAllocThunk goods slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
 291
 292 tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
 293 tickyAllocPAP goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
 294
 295 tickyAllocHeap :: VirtualHpOffset -> FCode ()
 296 -- Called when doing a heap check [TICK_ALLOC_HEAP]
 297 -- Must be lazy in the amount of allocation!
 298 tickyAllocHeap hp
 299   = ifTicky $
 300     do  { ticky_ctr <- getTickyCtrLabel
 301         ; emit $ catAGraphs $
 302           if hp == 0 then []    -- Inside the emitMiddle to avoid control
 303           else [                -- dependency on the argument
 304                 -- Bump the allcoation count in the StgEntCounter
 305             addToMem REP_StgEntCounter_allocs
 306                         (CmmLit (cmmLabelOffB ticky_ctr
 307                                 oFFSET_StgEntCounter_allocs)) hp,
 308                 -- Bump ALLOC_HEAP_ctr
 309             addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_ctr")) 1,
 310                 -- Bump ALLOC_HEAP_tot
 311             addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_tot")) hp] }
 312
 313 -- -----------------------------------------------------------------------------
 314 -- Ticky utils
 315
 316 ifTicky :: FCode () -> FCode ()
 317 ifTicky code
 318   | opt_DoTickyProfiling = code
 319   | otherwise            = nopC
 320
 321 -- All the ticky-ticky counters are declared "unsigned long" in C
 322 bumpTickyCounter :: LitString -> FCode ()
 323 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
 324
 325 bumpTickyCounter' :: CmmLit -> FCode ()
 326 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
 327 bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
 328
 329 bumpHistogram :: LitString -> Int -> FCode ()
 330 bumpHistogram lbl n
 331 --  = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
 332     = return ()    -- TEMP SPJ Apr 07
 333
 334 bumpHistogramE :: LitString -> CmmExpr -> FCode ()
 335 bumpHistogramE lbl n
 336   = do  t <- newTemp cLong
 337         emit (mkAssign (CmmLocal t) n)
 338         emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
 339                           (mkAssign (CmmLocal t) eight))
 340         emit (addToMem cLong
 341                        (cmmIndexExpr cLongWidth
 342                                 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
 343                                 (CmmReg (CmmLocal t)))
 344                        1)
 345   where
 346    eight = CmmLit (CmmInt 8 cLongWidth)
 347
 348 ------------------------------------------------------------------
 349 -- Showing the "type category" for ticky-ticky profiling
 350
 351 showTypeCategory :: Type -> Char
 352   {-    {C,I,F,D}   char, int, float, double
 353         T           tuple
 354         S           other single-constructor type
 355         {c,i,f,d}   unboxed ditto
 356         t           *unpacked* tuple
 357         s           *unpacked" single-cons...
 358
 359         v           void#
 360         a           primitive array
 361
 362         E           enumeration type
 363         +           dictionary, unless it's a ...
 364         L           List
 365         >           function
 366         M           other (multi-constructor) data-con type
 367         .           other type
 368         -           reserved for others to mark as "uninteresting"
 369     -}
 370 showTypeCategory ty
 371   = if isDictTy ty
 372     then '+'
 373     else
 374       case tcSplitTyConApp_maybe ty of
 375         Nothing -> if isJust (tcSplitFunTy_maybe ty)
 376                    then '>'
 377                    else '.'
 378
 379         Just (tycon, _) ->
 380           let utc = getUnique tycon in
 381           if      utc == charDataConKey    then 'C'
 382           else if utc == intDataConKey     then 'I'
 383           else if utc == floatDataConKey   then 'F'
 384           else if utc == doubleDataConKey  then 'D'
 385           else if utc == charPrimTyConKey  then 'c'
 386           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 387                 || utc == addrPrimTyConKey)                then 'i'
 388           else if utc  == floatPrimTyConKey                then 'f'
 389           else if utc  == doublePrimTyConKey               then 'd'
 390           else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus
 391           else if isEnumerationTyCon tycon                 then 'E'
 392           else if isTupleTyCon tycon                       then 'T'
 393           else if isJust (tyConSingleDataCon_maybe tycon)       then 'S'
 394           else if utc == listTyConKey                      then 'L'
 395           else 'M' -- oh, well...