From 982884c5a0f697a866374f8f9767986570a87100 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Thu, 25 Nov 2021 17:03:08 +0000 Subject: Add info table to ticky counter Fix ticky counter info stuff Support non-std thunk entry counters Hacky way to get std info tables into ticky Add ticky thunk 'args' Args for std thunks Add flag to omit ap thunk usage. A bit of cleanup A fix Collapse TickyArgDesc and TickyClosureTy, jsonify Jsonify args + expand with in text output Add closure type to args json --- compiler/GHC/Cmm/Parser.y | 1 + compiler/GHC/Driver/Flags.hs | 1 + compiler/GHC/Driver/Session.hs | 2 + compiler/GHC/Iface/Tidy.hs | 2 +- compiler/GHC/StgToCmm/Bind.hs | 30 ++++---- compiler/GHC/StgToCmm/Closure.hs | 6 +- compiler/GHC/StgToCmm/Env.hs | 10 ++- compiler/GHC/StgToCmm/Expr.hs | 2 +- compiler/GHC/StgToCmm/Ticky.hs | 148 ++++++++++++++++++++++++++++++++------- compiler/GHC/Types/Var/Env.hs | 3 + compiler/GHC/Utils/Json.hs | 10 ++- docs/users_guide/profiling.rst | 10 +++ includes/rts/Ticky.h | 1 + rts/Ticky.c | 6 +- rts/eventlog/EventLog.c | 3 +- 15 files changed, 186 insertions(+), 49 deletions(-) diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index ec2cec2afd..bf81216f84 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -1504,6 +1504,7 @@ parseCmmFile dflags this_mod home_unit filename = do st <- initC let fcode = do ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () + -- See Note [Mapping Info Tables to Source Positions] (IPE Maps) let used_info = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm) ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 0b5b1a44bc..b0e805fbe3 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -264,6 +264,7 @@ data GeneralFlag | Opt_Ticky_Allocd | Opt_Ticky_LNE | Opt_Ticky_Dyn_Thunk + | Opt_Ticky_AP -- ^ Use regular thunks even when we could use std ap thunks in order to get entry counts | Opt_RPath | Opt_RelativeDynlibPaths | Opt_Hpc diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index e9088029f8..a592824676 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2316,6 +2316,8 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_Ticky_Allocd)) , make_ord_flag defGhcFlag "ticky-LNE" (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , make_ord_flag defGhcFlag "ticky-ap-thunk" + (NoArg (setGeneralFlag Opt_Ticky_AP)) , make_ord_flag defGhcFlag "ticky-dyn-thunk" (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) ------- recompilation checker -------------------------------------- diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 76ad3c2a79..2ac5d9929d 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -373,7 +373,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod = Err.withTiming logger dflags (text "CoreTidy"<+>brackets (ppr mod)) - (const ()) $ + (const ()) $! do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index f1346d2846..305e63913d 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -207,21 +207,25 @@ cgRhs :: Id ) cgRhs id (StgRhsCon cc con mn _ts args) - = withNewTickyCounterCon (idName id) con $ + = withNewTickyCounterCon id con mn $ buildDynCon id mn True cc con (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body) - = do profile <- getProfile - mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body + = do df <- getDynFlags + let use_std_ap_thunk = gopt Opt_Ticky_AP df + profile <- getProfile + mkRhsClosure profile use_std_ap_thunk id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: Profile -> Id -> CostCentreStack +mkRhsClosure :: Profile + -> Bool -- Omit AP Thunks to improve profiling + -> Id -> CostCentreStack -> [NonVoid Id] -- Free vars -> UpdateFlag -> [Id] -- Args @@ -264,8 +268,8 @@ for semi-obvious reasons. -} ---------- Note [Selectors] ------------------ -mkRhsClosure profile bndr _cc - [NonVoid the_fv] -- Just one free var +mkRhsClosure profile _ bndr _cc + [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk expr @@ -297,7 +301,7 @@ mkRhsClosure profile bndr _cc in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ---------- Note [Ap thunks] ------------------ -mkRhsClosure profile bndr _cc +mkRhsClosure profile use_std_ap bndr _cc fvs upd_flag [] -- No args; a thunk @@ -306,7 +310,8 @@ mkRhsClosure profile bndr _cc -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure -- of form (x1 x2 .... xn), where all the xi are locals (not top-level) -- So the xi will all be free variables - | args `lengthIs` (n_fvs-1) -- This happens only if the fun_id and + | use_std_ap + , args `lengthIs` (n_fvs-1) -- This happens only if the fun_id and -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected @@ -330,7 +335,7 @@ mkRhsClosure profile bndr _cc payload = StgVarArg fun_id : args ---------- Default case ------------------ -mkRhsClosure profile bndr cc fvs upd_flag args body +mkRhsClosure profile _use_ap bndr cc fvs upd_flag args body = do { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } @@ -395,7 +400,7 @@ cgRhsStdThunk bndr lf_info payload } where gen_code reg -- AHA! A STANDARD-FORM THUNK - = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $ + = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) payload $ -- TODO do { -- LAY OUT THE OBJECT mod_name <- getModuleName @@ -467,7 +472,8 @@ closureCodeBody top_lvl bndr cl_info cc [] body fv_details = withNewTickyCounterThunk (isStaticClosure cl_info) (closureUpdReqd cl_info) - (closureName cl_info) $ + (closureName cl_info) + (map fst fv_details) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node body where @@ -479,7 +485,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details arity = length args in -- See Note [OneShotInfo overview] in GHC.Types.Basic. - withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) + withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) (map fst fv_details) nv_args $ do { ; let diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 5d53d52291..69a663143c 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -66,6 +66,7 @@ module GHC.StgToCmm.Closure ( cafBlackHoleInfoTable, indStaticInfoTable, staticClosureNeedsLink, + mkClosureInfoTableLabel ) where #include "HsVersions.h" @@ -613,7 +614,7 @@ getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" data ClosureInfo = ClosureInfo { - closureName :: !Name, -- The thing bound to this closure + closureName :: !Id, -- The thing bound to this closure -- we don't really need this field: it's only used in generating -- code for ticky and profiling, and we could pass the information -- around separately, but it doesn't do much harm to keep it here. @@ -650,7 +651,7 @@ mkClosureInfo :: Profile -> String -- String descriptor -> ClosureInfo mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr - = ClosureInfo { closureName = name + = ClosureInfo { closureName = id , closureLFInfo = lf_info , closureInfoLabel = info_lbl -- These three fields are , closureSMRep = sm_rep -- (almost) an info table @@ -810,6 +811,7 @@ closureLocalEntryLabel platform | platformTablesNextToCode platform = toInfoLbl platform . closureInfoLabel | otherwise = toEntryLbl platform . closureInfoLabel +-- | Get the info table label for a *thunk*. mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel platform id lf_info = case lf_info of diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index ebfff0185f..6f383c34c6 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -18,7 +18,7 @@ module GHC.StgToCmm.Env ( bindArgsToRegs, bindToReg, rebindToReg, bindArgToReg, idToReg, getArgAmode, getNonVoidArgAmodes, - getCgIdInfo, + getCgIdInfo, getCgInfo_maybe, maybeLetNoEscape, ) where @@ -51,6 +51,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Driver.Session +import GHC.Builtin.Names (getUnique) ------------------------------------- @@ -151,6 +152,13 @@ getCgIdInfo id cgLookupPanic id -- Bug }}} +-- | Retrieve cg info for a name if it already exists. +getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo) +getCgInfo_maybe name + = do { platform <- targetPlatform <$> getDynFlags + ; local_binds <- getBinds -- Try local bindings first + ; return $ lookupVarEnv_Directly local_binds (getUnique name) } + cgLookupPanic :: Id -> FCode a cgLookupPanic id = do local_binds <- getBinds diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 1b57fc3813..73b54701e3 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -210,7 +210,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body = do platform <- getPlatform return ( lneIdInfo platform bndr args, code ) where - code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do + code = forkLneBody $ withNewTickyCounterLNE bndr args $ do { restoreCurrentCostCentre cc_slot ; arg_regs <- bindArgsToRegs args ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 44a99a0cae..0f4cc88acf 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -117,6 +117,7 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout + import GHC.Types.Name import GHC.Types.Id import GHC.Types.Basic @@ -138,6 +139,11 @@ import GHC.Core.Predicate import Data.Maybe import qualified Data.Char import Control.Monad ( when ) +import GHC.Types.Id.Info +import GHC.Utils.Trace +import GHC.StgToCmm.Env (getCgInfo_maybe) +import Data.Coerce (coerce) +import GHC.Utils.Json ----------------------------------------------------------------------------- -- @@ -145,23 +151,72 @@ import Control.Monad ( when ) -- ----------------------------------------------------------------------------- +-- | "Arguments" for a ticky counter. FVs for thunks, actual arguments for functions. +tickyArgArity :: TickyClosureType -> Int +tickyArgArity (TickyFun _ _fvs args) = length args +tickyArgArity (TickyLNE args) = length args +tickyArgArity (TickyCon{}) = 0 +tickyArgArity (TickyThunk{}) = 0 + +tickyArgDesc :: TickyClosureType -> String +tickyArgDesc arg_info = + case arg_info of + TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args + TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args + TickyThunk{} -> "" + TickyCon{} -> "" + +tickyFvDesc :: TickyClosureType -> String +tickyFvDesc arg_info = + case arg_info of + TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs + TickyLNE{} -> "" + TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs + TickyCon{} -> "" + +instance ToJson TickyClosureType where + json info = case info of + (TickyFun {}) -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun" + (TickyLNE {}) -> mkInfo [] (tickyArgDesc info) "lne" + (TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) [] ("thk" ++ if uf then "_u" else "") + (TickyCon{}) -> mkInfo [] [] "con" + where + mkInfo :: String -> String -> String -> JsonDoc + mkInfo fvs args ty = + JSObject + [("type", json "entCntr") + ,("subTy", json ty) + ,("fvs_c", json (length fvs)) + ,("fvs" , json fvs) + ,("args", json args) + ] + +tickyEntryDesc :: (SDocContext -> TickyClosureType -> String) +tickyEntryDesc ctxt = renderWithContext ctxt . renderJSON . json +-- tickyEntryDesc ctxt info = tickyFvDesc info ++ ";" ++ tickyArgDesc info + data TickyClosureType = TickyFun Bool -- True <-> single entry + [NonVoid Id] -- ^ FVs + [NonVoid Id] -- ^ Args | TickyCon DataCon -- the allocated constructor + ConstructorNumber | TickyThunk Bool -- True <-> updateable Bool -- True <-> standard thunk (AP or selector), has no entry counter + [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals. | TickyLNE + [NonVoid Id] -- ^ Args -withNewTickyCounterFun :: Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a -withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry) +withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f -withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a -withNewTickyCounterLNE nm args code = do +withNewTickyCounterLNE :: Id -> [NonVoid Id] -> FCode a -> FCode a +withNewTickyCounterLNE nm args code = do b <- tickyLNEIsOn - if not b then code else withNewTickyCounter TickyLNE nm args code + if not b then code else withNewTickyCounter (TickyLNE args) nm code thunkHasCounter :: Bool -> FCode Bool thunkHasCounter isStatic = do @@ -171,46 +226,50 @@ thunkHasCounter isStatic = do withNewTickyCounterThunk :: Bool -- ^ static -> Bool -- ^ updateable - -> Name + -> Id + -> [NonVoid Id] -- ^ Free vars -> FCode a -> FCode a -withNewTickyCounterThunk isStatic isUpdatable name code = do +withNewTickyCounterThunk isStatic isUpdatable name fvs code = do has_ctr <- thunkHasCounter isStatic if not has_ctr then code - else withNewTickyCounter (TickyThunk isUpdatable False) name [] code + else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code withNewTickyCounterStdThunk :: Bool -- ^ updateable - -> Name + -> Id + -> [StgArg] -- ^ Free vars + function -> FCode a -> FCode a -withNewTickyCounterStdThunk isUpdatable name code = do +withNewTickyCounterStdThunk isUpdatable name fvs code = do has_ctr <- thunkHasCounter False if not has_ctr then code - else withNewTickyCounter (TickyThunk isUpdatable True) name [] code + else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code withNewTickyCounterCon - :: Name + :: Id -> DataCon + -> ConstructorNumber -> FCode a -> FCode a -withNewTickyCounterCon name datacon code = do +withNewTickyCounterCon name datacon info code = do has_ctr <- thunkHasCounter False if not has_ctr then code - else withNewTickyCounter (TickyCon datacon) name [] code + else withNewTickyCounter (TickyCon datacon info) name code -- args does not include the void arguments -withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a -withNewTickyCounter cloType name args m = do - lbl <- emitTickyCounter cloType name args +withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a +withNewTickyCounter cloType name m = do + lbl <- emitTickyCounter cloType name setTickyCtrLabel lbl m -emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel -emitTickyCounter cloType name args - = let ctr_lbl = mkRednCountsLabel name in +emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel +emitTickyCounter cloType tickee + = let name = idName tickee in + let ctr_lbl = mkRednCountsLabel name in (>> return ctr_lbl) $ ifTicky $ do { dflags <- getDynFlags @@ -226,13 +285,13 @@ emitTickyCounter cloType name args ppr_for_ticky_name = let n = ppr name ext = case cloType of - TickyFun single_entry -> parens $ hcat $ punctuate comma $ + TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $ [text "fun"] ++ [text "se"|single_entry] - TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon)) - TickyThunk upd std -> parens $ hcat $ punctuate comma $ + TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon)) + TickyThunk upd std _-> parens $ hcat $ punctuate comma $ [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std] - TickyLNE | isInternalName name -> parens (text "LNE") - | otherwise -> panic "emitTickyCounter: how is this an external LNE?" + TickyLNE _ | isInternalName name -> parens (text "LNE") + | otherwise -> panic "emitTickyCounter: how is this an external LNE?" p = case hasHaskellName parent of -- NB the default "top" ticky ctr does not -- have a Haskell name @@ -241,9 +300,43 @@ emitTickyCounter cloType name args in if isInternalName name then n <+> parens (ppr mod_name) <+> ext <+> p else n <+> ext <+> p + ; this_mod <- getModuleName + ; let t = case cloType of + TickyCon {} -> "C" + TickyFun {} -> "F" + TickyThunk {} -> "T" + TickyLNE {} -> "L" + ; info_lbl <- case cloType of + TickyCon dc mn -> case mn of + NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite + (Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n) + TickyFun {} -> + -- pprTrace "tickyF" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs) $$ ppr mod_name) $ + return $! CmmLabel $ mkInfoTableLabel name NoCafRefs + + TickyThunk _ std_thunk fvs + | not std_thunk + -> -- pprTrace "tickyThunk" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs)) + return $! CmmLabel $ mkInfoTableLabel name NoCafRefs + -- IPE Maps have no entry for std thunks. + | otherwise + -> do + lf_info <- getCgInfo_maybe name + profile <- getProfile + case lf_info of + Just (CgIdInfo { cg_lf = cg_lf@(LFThunk {})}) + -> -- pprTrace "tickyThunkStd" empty $ return $ + return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf -- zeroCLit platform + _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs)) + return $! zeroCLit platform + + TickyLNE {} -> -- pprTrace "tickyLNE" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs)) $ + return $! zeroCLit platform + -- _ -> CmmLabel $ mkInfoTableLabel name NoCafRefs + ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name - ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args + ; arg_descr_lit <- newStringCLit $ tickyEntryDesc ctx cloType ; emitDataLits ctr_lbl -- Must match layout of includes/rts/Ticky.h's StgEntCounter -- @@ -251,10 +344,11 @@ emitTickyCounter cloType name args -- before, but the code generator wasn't handling that -- properly and it led to chaos, panic and disorder. [ mkIntCLit platform 0, -- registered? - mkIntCLit platform (length args), -- Arity + mkIntCLit platform (tickyArgArity cloType), -- Arity mkIntCLit platform 0, -- Heap allocated for this thing fun_descr_lit, arg_descr_lit, + info_lbl, zeroCLit platform, -- Entries into this thing zeroCLit platform, -- Heap allocated by this thing zeroCLit platform -- Link to next StgEntCounter diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs index ed58c413f4..56b3bc8ce4 100644 --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -17,6 +17,7 @@ module GHC.Types.Var.Env ( delVarEnvList, delVarEnv, minusVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + lookupVarEnv_Directly, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, isEmptyVarEnv, @@ -485,6 +486,7 @@ modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a isEmptyVarEnv :: VarEnv a -> Bool lookupVarEnv :: VarEnv a -> Var -> Maybe a +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a @@ -509,6 +511,7 @@ minusVarEnv = minusUFM plusVarEnv = plusUFM plusVarEnvList = plusUFMList lookupVarEnv = lookupUFM +lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv = filterUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM diff --git a/compiler/GHC/Utils/Json.hs b/compiler/GHC/Utils/Json.hs index 21358847c0..db0dd8dbd3 100644 --- a/compiler/GHC/Utils/Json.hs +++ b/compiler/GHC/Utils/Json.hs @@ -1,4 +1,6 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module GHC.Utils.Json where import GHC.Prelude @@ -29,7 +31,7 @@ renderJSON d = JSObject fs -> braces $ pprList renderField fs where renderField :: (String, JsonDoc) -> SDoc - renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j + renderField (s, j) = doubleQuotes (text s) <> colon <> renderJSON j pprList pp xs = hcat (punctuate comma (map pp xs)) @@ -54,3 +56,9 @@ escapeJsonString = concatMap escapeChar class ToJson a where json :: a -> JsonDoc + +instance ToJson String where + json = JSString . escapeJsonString + +instance ToJson Int where + json = JSInt \ No newline at end of file diff --git a/docs/users_guide/profiling.rst b/docs/users_guide/profiling.rst index 78f96ae8cb..095317e18d 100644 --- a/docs/users_guide/profiling.rst +++ b/docs/users_guide/profiling.rst @@ -1701,6 +1701,16 @@ Using “ticky-ticky” profiling (for implementors) Track allocations of dynamic thunks. +.. ghc-flag:: -ticky-ap-thunk + :shortdesc: Don't use standard AP thunks on order to get more reliable entry counters. + :type: dynamic + :category: + + This basically allows us to get accurate entry counters for code like `f x y` at the cost of code size. + We do this but not using the precomputed standard AP thunk code. + +GHC's ticky-ticky profiler provides a low-level facility for tracking +entry and allocation counts of particular individual closures. Because ticky-ticky profiling requires a certain familiarity with GHC internals, we have moved the documentation to the GHC developers wiki. Take a look at its diff --git a/includes/rts/Ticky.h b/includes/rts/Ticky.h index 93043d8514..7658e3c08a 100644 --- a/includes/rts/Ticky.h +++ b/includes/rts/Ticky.h @@ -26,6 +26,7 @@ typedef struct _StgEntCounter { /* (rest of args are in registers) */ char *str; /* name of the thing */ char *arg_kinds; /* info about the args types */ + StgInfoTable *info; /* Info table corresponding to this closure */ StgInt entry_count; /* Trips to fast entry code */ StgInt allocs; /* number of allocations by this fun */ struct _StgEntCounter *link;/* link to chain them all together */ diff --git a/rts/Ticky.c b/rts/Ticky.c index 83ba70887c..3aa53cdad8 100644 --- a/rts/Ticky.c +++ b/rts/Ticky.c @@ -17,7 +17,7 @@ */ StgEntCounter top_ct = { 0, 0, 0, - "TOP", "", + "TOP", "", NULL, 0, 0, NULL }; /* Data structure used in ``registering'' one of these counters. */ @@ -362,13 +362,13 @@ printRegisteredCounterInfo (FILE *tf) fprintf(tf,"\nThe following table is explained by https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky\nAll allocation numbers are in bytes.\n"); fprintf(tf,"\n**************************************************\n\n"); } - fprintf(tf, "%11s%11s%11s %-23s %s\n", + fprintf(tf, "%11s%12s%12s %-63s %s\n", "Entries", "Alloc", "Alloc'd", "Non-void Arguments", "STG Name"); fprintf(tf, "--------------------------------------------------------------------------------\n"); /* Function name at the end so it doesn't mess up the tabulation */ for (p = ticky_entry_ctrs; p != NULL; p = p->link) { - fprintf(tf, "%11" FMT_Int "%11" FMT_Int "%11" FMT_Int " %3lu %-20.20s %s", + fprintf(tf, "%11" FMT_Int "%12" FMT_Int "%12" FMT_Int " %3lu %-60.60s %s", p->entry_count, p->allocs, p->allocd, diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index b8a80a0d4d..102f2cc777 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -1677,7 +1677,7 @@ void postProfBegin(void) #if defined(TICKY_TICKY) static void postTickyCounterDef(EventsBuf *eb, StgEntCounter *p) { - StgWord len = 8 + 2 + strlen(p->arg_kinds)+1 + strlen(p->str)+1; + StgWord len = 8 + 2 + strlen(p->arg_kinds)+1 + strlen(p->str)+1 + 8; ensureRoomForVariableEvent(eb, len); postEventHeader(eb, EVENT_TICKY_COUNTER_DEF); postPayloadSize(eb, len); @@ -1686,6 +1686,7 @@ static void postTickyCounterDef(EventsBuf *eb, StgEntCounter *p) postWord16(eb, (uint16_t) p->arity); postString(eb, p->arg_kinds); postString(eb, p->str); + postWord64(eb, (W_) (INFO_PTR_TO_STRUCT(p->info))); } void postTickyCounterDefs(StgEntCounter *counters) -- cgit v1.2.1