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