--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Code generation for ticky-ticky profiling
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CgTicky (
+ emitTickyCounter,
+
+ tickyDynAlloc,
+ tickyAllocHeap,
+ tickyAllocPrim,
+ tickyAllocThunk,
+ tickyAllocPAP,
+
+ tickyPushUpdateFrame,
+ tickyUpdateFrameOmitted,
+
+ tickyEnterDynCon,
+ tickyEnterStaticCon,
+ tickyEnterViaNode,
+
+ tickyEnterFun,
+ tickyEnterThunk,
+
+ tickyUpdateBhCaf,
+ tickyBlackHole,
+ tickyUnboxedTupleReturn, tickyVectoredReturn,
+ tickyReturnOldCon, tickyReturnNewCon,
+
+ tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
+ tickyUnknownCall, tickySlowCallPat,
+
+ staticTickyHdr,
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/DerivedConstants.h"
+ -- For REP_xxx constants, which are MachReps
+
+import ClosureInfo ( ClosureInfo, closureSize, slopSize, closureSMRep,
+ closureUpdReqd, closureName, isStaticClosure )
+import CgUtils
+import CgMonad
+import SMRep ( ClosureType(..), smRepClosureType, CgRep )
+
+import Cmm
+import MachOp
+import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr, cmmIndexExpr )
+import CLabel ( CLabel, mkRtsDataLabel, mkRednCountsLabel )
+
+import Name ( isInternalName )
+import Id ( Id, idType )
+import StaticFlags ( opt_DoTickyProfiling )
+import BasicTypes ( Arity )
+import FastString ( FastString, mkFastString, LitString )
+import Constants -- Lots of field offsets
+import Outputable
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType ( Type, isDictTy, tcSplitTyConApp_maybe,
+ tcSplitFunTy_maybe )
+import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon,
+ maybeTyConSingleCon )
+import Maybe
+
+-----------------------------------------------------------------------------
+--
+-- Ticky-ticky profiling
+--
+-----------------------------------------------------------------------------
+
+staticTickyHdr :: [CmmLit]
+-- The ticky header words in a static closure
+-- Was SET_STATIC_TICKY_HDR
+staticTickyHdr
+ | not opt_DoTickyProfiling = []
+ | otherwise = [zeroCLit]
+
+emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
+emitTickyCounter cl_info args on_stk
+ = ifTicky $
+ do { mod_name <- moduleName
+ ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
+ ; arg_descr_lit <- mkStringCLit arg_descr
+ ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
+ [ CmmInt 0 I16,
+ CmmInt (fromIntegral (length args)) I16, -- Arity
+ CmmInt (fromIntegral on_stk) I16, -- Words passed on stack
+ CmmInt 0 I16, -- 2-byte gap
+ fun_descr_lit,
+ arg_descr_lit,
+ zeroCLit, -- Entry count
+ zeroCLit, -- Allocs
+ zeroCLit -- Link
+ ] }
+ where
+ name = closureName cl_info
+ ticky_ctr_label = mkRednCountsLabel name
+ arg_descr = map (showTypeCategory . idType) args
+ fun_descr mod_name = ppr_for_ticky_name mod_name name
+
+-- When printing the name of a thing in a ticky file, we want to
+-- give the module name even for *local* things. We print
+-- just "x (M)" rather that "M.x" to distinguish them from the global kind.
+ppr_for_ticky_name mod_name name
+ | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
+ | otherwise = showSDocDebug (ppr name)
+
+-- -----------------------------------------------------------------------------
+-- Ticky stack frames
+
+tickyPushUpdateFrame = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky entries
+
+tickyEnterDynCon = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr")
+tickyEnterDynThunk = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr")
+tickyEnterStaticCon = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr")
+tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr")
+tickyEnterViaNode = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr")
+
+tickyEnterThunk :: ClosureInfo -> Code
+tickyEnterThunk cl_info
+ | isStaticClosure cl_info = tickyEnterStaticThunk
+ | otherwise = tickyEnterDynThunk
+
+tickyBlackHole :: Bool{-updatable-} -> Code
+tickyBlackHole updatable
+ = ifTicky (bumpTickyCounter ctr)
+ where
+ ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr")
+ | otherwise = SLIT("UPD_BH_UPDATABLE_ctr")
+
+tickyUpdateBhCaf cl_info
+ = ifTicky (bumpTickyCounter ctr)
+ where
+ ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr")
+ | otherwise = SLIT("UPD_CAF_BH_UPDATABLE_ctr")
+
+tickyEnterFun :: ClosureInfo -> Code
+tickyEnterFun cl_info
+ = ifTicky $
+ do { bumpTickyCounter ctr
+ ; fun_ctr_lbl <- getTickyCtrLabel
+ ; registerTickyCtr fun_ctr_lbl
+ ; bumpTickyCounter' fun_ctr_lbl }
+ where
+ ctr | isStaticClosure cl_info = SLIT("TICK_ENT_STATIC_FUN_DIRECT")
+ | otherwise = SLIT("TICK_ENT_DYN_FUN_DIRECT")
+
+registerTickyCtr :: CLabel -> Code
+-- Register a ticky counter
+-- if ( ! f_ct.registeredp ) {
+-- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
+-- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
+-- f_ct.registeredp = 1 }
+registerTickyCtr ctr_lbl
+ = emitIf test (stmtsC register_stmts)
+ where
+ test = CmmMachOp (MO_Not I16)
+ [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
+ oFFSET_StgEntCounter_registeredp)) I16]
+ register_stmts
+ = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
+ (CmmLoad ticky_entry_ctrs wordRep)
+ , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
+ , CmmStore (CmmLit (cmmLabelOffB ctr_lbl
+ oFFSET_StgEntCounter_registeredp))
+ (CmmLit (mkIntCLit 1)) ]
+ ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel SLIT("ticky_entry_ctrs"))
+
+tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
+tickyReturnOldCon arity
+ = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr")
+ ; bumpHistogram SLIT("RET_OLD_hst") arity }
+tickyReturnNewCon arity
+ | not opt_DoTickyProfiling = nopC
+ | otherwise
+ = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr")
+ ; bumpHistogram SLIT("RET_NEW_hst") arity }
+
+tickyUnboxedTupleReturn :: Int -> Code
+tickyUnboxedTupleReturn arity
+ = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr")
+ ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity }
+
+tickyVectoredReturn :: Int -> Code
+tickyVectoredReturn family_size
+ = ifTicky $ do { bumpTickyCounter SLIT("VEC_RETURN_ctr")
+ ; bumpHistogram SLIT("RET_VEC_RETURN_hst") family_size }
+
+-- -----------------------------------------------------------------------------
+-- Ticky calls
+
+-- Ticks at a *call site*:
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr")
+tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr")
+tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ctr")
+tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr")
+
+-- Tick for the call pattern at slow call site (i.e. in addition to
+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
+tickySlowCallPat :: [CgRep] -> Code
+tickySlowCallPat args = return ()
+{- LATER: (introduces recursive module dependency now).
+ case callPattern args of
+ (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
+ (str, False) -> bumpTickyCounter SLIT("TICK_SLOW_CALL_OTHER")
+
+callPattern :: [CgRep] -> (String,Bool)
+callPattern reps
+ | match == length reps = (chars, True)
+ | otherwise = (chars, False)
+ where (_,match) = findMatch reps
+ chars = map argChar reps
+
+argChar VoidArg = 'v'
+argChar PtrArg = 'p'
+argChar NonPtrArg = 'n'
+argChar LongArg = 'l'
+argChar FloatArg = 'f'
+argChar DoubleArg = 'd'
+-}
+
+-- -----------------------------------------------------------------------------
+-- Ticky allocation
+
+tickyDynAlloc :: ClosureInfo -> Code
+-- Called when doing a dynamic heap allocation
+tickyDynAlloc cl_info
+ = ifTicky $
+ case smRepClosureType (closureSMRep cl_info) of
+ Constr -> tick_alloc_con
+ ConstrNoCaf -> tick_alloc_con
+ Fun -> tick_alloc_fun
+ Thunk -> tick_alloc_thk
+ ThunkSelector -> tick_alloc_thk
+ where
+ -- will be needed when we fill in stubs
+ cl_size = closureSize cl_info
+ slop_size = slopSize cl_info
+
+ tick_alloc_thk
+ | closureUpdReqd cl_info = tick_alloc_up_thk
+ | otherwise = tick_alloc_se_thk
+
+ tick_alloc_con = panic "ToDo: tick_alloc"
+ tick_alloc_fun = panic "ToDo: tick_alloc"
+ tick_alloc_up_thk = panic "ToDo: tick_alloc"
+ tick_alloc_se_thk = panic "ToDo: tick_alloc"
+
+tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
+tickyAllocPrim hdr goods slop = ifTicky $ panic "ToDo: tickyAllocPrim"
+
+tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
+tickyAllocThunk goods slop = ifTicky $ panic "ToDo: tickyAllocThunk"
+
+tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
+tickyAllocPAP goods slop = ifTicky $ panic "ToDo: tickyAllocPAP"
+
+tickyAllocHeap :: VirtualHpOffset -> Code
+-- Called when doing a heap check [TICK_ALLOC_HEAP]
+tickyAllocHeap hp
+ = ifTicky $
+ do { ticky_ctr <- getTickyCtrLabel
+ ; stmtsC $
+ if hp == 0 then [] -- Inside the stmtC to avoid control
+ else [ -- dependency on the argument
+ -- Bump the allcoation count in the StgEntCounter
+ addToMem REP_StgEntCounter_allocs
+ (CmmLit (cmmLabelOffB ticky_ctr
+ oFFSET_StgEntCounter_allocs)) hp,
+ -- Bump ALLOC_HEAP_ctr
+ addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1,
+ -- Bump ALLOC_HEAP_tot
+ addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] }
+
+-- -----------------------------------------------------------------------------
+-- Ticky utils
+
+ifTicky :: Code -> Code
+ifTicky code
+ | opt_DoTickyProfiling = code
+ | otherwise = nopC
+
+addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt
+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
+
+-- All the ticky-ticky counters are declared "unsigned long" in C
+bumpTickyCounter :: LitString -> Code
+bumpTickyCounter lbl = bumpTickyCounter' (mkRtsDataLabel lbl)
+
+bumpTickyCounter' :: CLabel -> Code
+bumpTickyCounter' lbl = stmtC (addToMemLbl cLongRep lbl 1)
+
+addToMemLong = addToMem cLongRep
+
+bumpHistogram :: LitString -> Int -> Code
+bumpHistogram lbl n
+ = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep))
+
+bumpHistogramE :: LitString -> CmmExpr -> Code
+bumpHistogramE lbl n
+ = do t <- newTemp cLongRep
+ stmtC (CmmAssign t n)
+ emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $
+ stmtC (CmmAssign t eight)
+ stmtC (addToMemLong (cmmIndexExpr cLongRep
+ (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
+ (CmmReg t))
+ 1)
+ where
+ eight = CmmLit (CmmInt 8 cLongRep)
+
+------------------------------------------------------------------
+-- Showing the "type category" for ticky-ticky profiling
+
+showTypeCategory :: Type -> Char
+ {- {C,I,F,D} char, int, float, double
+ T tuple
+ S other single-constructor type
+ {c,i,f,d} unboxed ditto
+ t *unpacked* tuple
+ s *unpacked" single-cons...
+
+ v void#
+ a primitive array
+
+ E enumeration type
+ + dictionary, unless it's a ...
+ L List
+ > function
+ M other (multi-constructor) data-con type
+ . other type
+ - reserved for others to mark as "uninteresting"
+ -}
+showTypeCategory ty
+ = if isDictTy ty
+ then '+'
+ else
+ case tcSplitTyConApp_maybe ty of
+ Nothing -> if isJust (tcSplitFunTy_maybe ty)
+ then '>'
+ else '.'
+
+ Just (tycon, _) ->
+ let utc = getUnique tycon in
+ if utc == charDataConKey then 'C'
+ else if utc == intDataConKey then 'I'
+ else if utc == floatDataConKey then 'F'
+ else if utc == doubleDataConKey then 'D'
+ else if utc == smallIntegerDataConKey ||
+ utc == largeIntegerDataConKey then 'J'
+ else if utc == charPrimTyConKey then 'c'
+ else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+ || utc == addrPrimTyConKey) then 'i'
+ else if utc == floatPrimTyConKey then 'f'
+ else if utc == doublePrimTyConKey then 'd'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
+ else if isEnumerationTyCon tycon then 'E'
+ else if isTupleTyCon tycon then 'T'
+ else if isJust (maybeTyConSingleCon tycon) then 'S'
+ else if utc == listTyConKey then 'L'
+ else 'M' -- oh, well...
projects / ghc-hetmet.git / blobdiff