X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgTicky.hs;h=45cede5ca9791cf9d5831a7e7f4c4543adb3e4fd;hp=b23b34caa4983c6734624cc28dae4a94d888a94b;hb=cbd7463c986d54422de15cb3b56184de116ef7ba;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index b23b34c..45cede5 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -1,10 +1,3 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - ----------------------------------------------------------------------------- -- -- Code generation for ticky-ticky profiling @@ -51,24 +44,26 @@ import CgUtils import CgMonad import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Name import Id import IdInfo -import StaticFlags import BasicTypes import FastString import Constants import Outputable +import Module -- Turgid imports for showTypeCategory import PrelNames import TcType import TyCon +import DynFlags + import Data.Maybe ----------------------------------------------------------------------------- @@ -113,6 +108,7 @@ emitTickyCounter cl_info args on_stk -- 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 +116,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 :: Code +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 :: Code +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 -> Code tickyEnterThunk cl_info @@ -141,14 +140,15 @@ tickyBlackHole :: Bool{-updatable-} -> Code 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 -> Code 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 -> Code tickyEnterFun cl_info @@ -159,8 +159,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 -> Code -- Register a ticky counter @@ -183,41 +183,41 @@ registerTickyCtr ctr_lbl , CmmStore (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 -> Code 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 - | not opt_DoTickyProfiling = nopC - | otherwise - = 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 -> Code 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 -> Code 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 -- 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_ARGS_ctr") -tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr") +tickyKnownCallTooFewArgs, tickyKnownCallExact, + tickyKnownCallExtraArgs, tickyUnknownCall :: Code +tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") +tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") +tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") +tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "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 () +tickySlowCallPat _args = return () {- LATER: (introduces recursive module dependency now). case callPattern args of (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat) @@ -255,8 +255,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 @@ -271,13 +271,13 @@ tickyDynAlloc cl_info tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code -tickyAllocPrim hdr goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ()) +tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ()) tickyAllocThunk :: CmmExpr -> CmmExpr -> Code -tickyAllocThunk goods slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ()) +tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ()) tickyAllocPAP :: CmmExpr -> CmmExpr -> Code -tickyAllocPAP goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ()) +tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ()) tickyAllocHeap :: VirtualHpOffset -> Code -- Called when doing a heap check [TICK_ALLOC_HEAP] @@ -292,34 +292,35 @@ tickyAllocHeap hp (CmmLit (cmmLabelOffB ticky_ctr oFFSET_StgEntCounter_allocs)) hp, -- Bump ALLOC_HEAP_ctr - addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_ctr") 1, + addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, -- Bump ALLOC_HEAP_tot - addToMemLbl cLongWidth (mkRtsDataLabel $ sLit "ALLOC_HEAP_tot") hp] } + addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] } -- ----------------------------------------------------------------------------- -- Ticky utils ifTicky :: Code -> Code -ifTicky code - | opt_DoTickyProfiling = code - | otherwise = nopC +ifTicky code = do dflags <- getDynFlags + if doingTickyProfiling dflags then code + else nopC addToMemLbl :: Width -> 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' (cmmLabelOffB (mkRtsDataLabel lbl) 0) +bumpTickyCounter :: FastString -> Code +bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0) bumpTickyCounter' :: CmmLit -> Code -- krc: note that we're incrementing the _entry_count_ field of the ticky counter bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1) -bumpHistogram :: LitString -> Int -> Code -bumpHistogram lbl n +bumpHistogram :: FastString -> Int -> Code +bumpHistogram _lbl _n -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong)) = return () -- TEMP SPJ Apr 07 +{- bumpHistogramE :: LitString -> CmmExpr -> Code bumpHistogramE lbl n = do t <- newTemp cLong @@ -332,8 +333,10 @@ bumpHistogramE lbl n 1) where eight = CmmLit (CmmInt 8 cLongWidth) +-} ------------------------------------------------------------------ +addToMemLong :: CmmExpr -> Int -> CmmStmt addToMemLong = addToMem cLongWidth ------------------------------------------------------------------