X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmTicky.hs;h=e8642eb4e616664da3170df39d10deffb0bed918;hp=33fe104def563633eeed00699e61f62a4a440ec9;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=306fac3f65c2e68e6c320a9db221d126c989fad2 diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 33fe104..e8642eb 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -1,6 +1,3 @@ -{-# OPTIONS -w #-} --- Lots of missing type sigs etc - ----------------------------------------------------------------------------- -- -- Code generation for ticky-ticky profiling @@ -51,19 +48,21 @@ import StgCmmMonad import SMRep import StgSyn -import Cmm -import MkZipCfgCmm +import CmmExpr +import MkGraph import CmmUtils import CLabel +import Module import Name import Id -import StaticFlags import BasicTypes import FastString import Constants import Outputable +import DynFlags + -- Turgid imports for showTypeCategory import PrelNames import TcType @@ -113,6 +112,7 @@ emitTickyCounter cl_info args -- 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 :: Module -> Name -> String ppr_for_ticky_name mod_name name | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) | otherwise = showSDocDebug (ppr name) @@ -120,17 +120,20 @@ ppr_for_ticky_name mod_name name -- ----------------------------------------------------------------------------- -- Ticky stack frames -tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr") -tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr") +tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode () +tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") +tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "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") +tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon, + tickyEnterStaticThunk, tickyEnterViaNode :: FCode () +tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") +tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") +tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") +tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr") +tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") tickyEnterThunk :: ClosureInfo -> FCode () tickyEnterThunk cl_info @@ -141,14 +144,15 @@ tickyBlackHole :: Bool{-updatable-} -> FCode () tickyBlackHole updatable = ifTicky (bumpTickyCounter ctr) where - ctr | updatable = (sLit "UPD_BH_SINGLE_ENTRY_ctr") - | otherwise = (sLit "UPD_BH_UPDATABLE_ctr") + ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr") + | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr") +tickyUpdateBhCaf :: ClosureInfo -> FCode () 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") + ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr") + | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr") tickyEnterFun :: ClosureInfo -> FCode () tickyEnterFun cl_info @@ -159,8 +163,8 @@ tickyEnterFun cl_info ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) } where - ctr | isStaticClosure cl_info = (sLit "ENT_STATIC_FUN_DIRECT_ctr") - | otherwise = (sLit "ENT_DYN_FUN_DIRECT_ctr") + ctr | isStaticClosure cl_info = (fsLit "ENT_STATIC_FUN_DIRECT_ctr") + | otherwise = (fsLit "ENT_DYN_FUN_DIRECT_ctr") registerTickyCtr :: CLabel -> FCode () -- Register a ticky counter @@ -183,25 +187,25 @@ registerTickyCtr ctr_lbl , mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_registeredp)) (CmmLit (mkIntCLit 1)) ] - ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs")) + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode () tickyReturnOldCon arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr") - ; bumpHistogram (sLit "RET_OLD_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") + ; bumpHistogram (fsLit "RET_OLD_hst") arity } tickyReturnNewCon arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr") - ; bumpHistogram (sLit "RET_NEW_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") + ; bumpHistogram (fsLit "RET_NEW_hst") arity } tickyUnboxedTupleReturn :: Int -> FCode () tickyUnboxedTupleReturn arity - = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr") - ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity } + = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") + ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } tickyVectoredReturn :: Int -> FCode () tickyVectoredReturn family_size - = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr") - ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size } + = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr") + ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size } -- ----------------------------------------------------------------------------- -- Ticky calls @@ -213,15 +217,22 @@ tickyDirectCall arity args | otherwise = do tickyKnownCallExtraArgs tickySlowCallPat (map argPrimRep (drop arity args)) -tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") -tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr") -tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr") -tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr") +tickyKnownCallTooFewArgs :: FCode () +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") + +tickyKnownCallExact :: FCode () +tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") + +tickyKnownCallExtraArgs :: FCode () +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") + +tickyUnknownCall :: FCode () +tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") -- Tick for the call pattern at slow call site (i.e. in addition to -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode () -tickySlowCall lf_info [] +tickySlowCall _ [] = return () tickySlowCall lf_info args = do { if (isKnownFun lf_info) @@ -230,7 +241,7 @@ tickySlowCall lf_info args ; tickySlowCallPat (map argPrimRep args) } tickySlowCallPat :: [PrimRep] -> FCode () -tickySlowCallPat args = return () +tickySlowCallPat _args = return () {- LATER: (introduces recursive module dependency now). case callPattern args of (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat) @@ -268,8 +279,8 @@ tickyDynAlloc cl_info Nothing -> return () where -- will be needed when we fill in stubs - cl_size = closureSize cl_info - slop_size = slopSize cl_info + _cl_size = closureSize cl_info + _slop_size = slopSize cl_info tick_alloc_thk | closureUpdReqd cl_info = tick_alloc_up_thk @@ -284,13 +295,13 @@ tickyDynAlloc cl_info tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () -tickyAllocPrim hdr goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ()) +tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ()) tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode () -tickyAllocThunk goods slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ()) +tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ()) tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode () -tickyAllocPAP goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ()) +tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ()) tickyAllocHeap :: VirtualHpOffset -> FCode () -- Called when doing a heap check [TICK_ALLOC_HEAP] @@ -306,31 +317,32 @@ tickyAllocHeap hp (CmmLit (cmmLabelOffB ticky_ctr oFFSET_StgEntCounter_allocs)) hp, -- Bump ALLOC_HEAP_ctr - addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_ctr")) 1, + addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1, -- Bump ALLOC_HEAP_tot - addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_tot")) hp] } + addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] } -- ----------------------------------------------------------------------------- -- Ticky utils ifTicky :: FCode () -> FCode () -ifTicky code - | opt_DoTickyProfiling = code - | otherwise = nopC +ifTicky code = do dflags <- getDynFlags + if doingTickyProfiling dflags then code + else nopC -- All the ticky-ticky counters are declared "unsigned long" in C -bumpTickyCounter :: LitString -> FCode () -bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0) +bumpTickyCounter :: FastString -> FCode () +bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0) bumpTickyCounter' :: CmmLit -> FCode () -- krc: note that we're incrementing the _entry_count_ field of the ticky counter bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1) -bumpHistogram :: LitString -> Int -> FCode () -bumpHistogram lbl n +bumpHistogram :: FastString -> Int -> FCode () +bumpHistogram _lbl _n -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth)) = return () -- TEMP SPJ Apr 07 +{- bumpHistogramE :: LitString -> CmmExpr -> FCode () bumpHistogramE lbl n = do t <- newTemp cLong @@ -344,6 +356,7 @@ bumpHistogramE lbl n 1) where eight = CmmLit (CmmInt 8 cLongWidth) +-} ------------------------------------------------------------------ -- Showing the "type category" for ticky-ticky profiling