Add info table to ticky counterwip/ticky-eventlog-info-backport

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

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)