compiler/codeGen/CgTicky.hs

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