Add ticky thunk 'args'

3 files changed, 39 insertions, 18 deletions

diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 41b1ad6b9e..766da57069 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -369,7 +369,7 @@ tidyProgram hsc_env  (ModGuts { mg_module           = mod
 
   = Err.withTiming logger
                    (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 f931cdf81e..990b76d272 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -400,7 +400,7 @@ cgRhsStdThunk bndr lf_info payload
        }
  where
  gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) $
+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) [] $ -- TODO
     do
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
@@ -472,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
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index d366745fb9..de2bc84394 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -143,6 +143,7 @@ import Control.Monad ( when )
 import GHC.Types.Id.Info
 import GHC.Utils.Trace
 import GHC.StgToCmm.Env (getCgInfo_maybe)
+import Data.Coerce (coerce)
 
 -----------------------------------------------------------------------------
 --
@@ -150,6 +151,23 @@ import GHC.StgToCmm.Env (getCgInfo_maybe)
 --
 -----------------------------------------------------------------------------
 
+-- | Ticky "arg" info. Describes args for functions and fvs for thunks.
+data TickyArgs = FunArgs [NonVoid Id] | ThunkFvs [StgArg] | NoArgs
+
+-- | "Arguments" for a ticky counter. FVs for thunks, actual arguments for functions.
+tickyArgArity :: TickyArgs -> Int
+tickyArgArity (FunArgs args) = length args
+tickyArgArity (ThunkFvs fvs) = length fvs
+tickyArgArity (NoArgs) = 0
+
+
+tickyArgDesc :: TickyArgs -> String
+tickyArgDesc arg_info =
+  case arg_info of
+    NoArgs -> ""
+    ThunkFvs fvs -> map (showTypeCategory . stgArgType) fvs
+    FunArgs args -> map (showTypeCategory . idType . fromNonVoid) args
+
 data TickyClosureType
     = TickyFun
         Bool -- True <-> single entry
@@ -161,13 +179,13 @@ data TickyClosureType
         Bool -- True <-> standard thunk (AP or selector), has no entry counter
     | TickyLNE
 
-withNewTickyCounterFun :: Bool -> Id ->  [NonVoid Id] -> FCode a -> FCode a
-withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)
+withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun single_entry f args = withNewTickyCounter (TickyFun single_entry) f (FunArgs args)
 
 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 nm (FunArgs args) code
 
 thunkHasCounter :: Bool -> FCode Bool
 thunkHasCounter isStatic = do
@@ -178,24 +196,26 @@ withNewTickyCounterThunk
   :: Bool -- ^ static
   -> Bool -- ^ updateable
   -> Id
+  -> [NonVoid Id]
   -> 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) name (ThunkFvs $ map StgVarArg $ coerce fvs) code
 
 withNewTickyCounterStdThunk
   :: Bool -- ^ updateable
   -> Id
+  -> [StgArg]
   -> 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) name (ThunkFvs fvs) code
 
 withNewTickyCounterCon
   :: Id
@@ -207,16 +227,16 @@ withNewTickyCounterCon name datacon info code = do
     has_ctr <- thunkHasCounter False
     if not has_ctr
       then code
-      else withNewTickyCounter (TickyCon datacon info) name [] code
+      else withNewTickyCounter (TickyCon datacon info) name NoArgs code
 
 -- args does not include the void arguments
-withNewTickyCounter :: TickyClosureType -> Id -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounter :: TickyClosureType -> Id -> TickyArgs -> FCode a -> FCode a
 withNewTickyCounter cloType name args m = do
   lbl <- emitTickyCounter cloType name args
   setTickyCtrLabel lbl m
 
-emitTickyCounter :: TickyClosureType -> Id ->  [NonVoid Id] -> FCode CLabel
-emitTickyCounter cloType tickee args
+emitTickyCounter :: TickyClosureType -> Id -> TickyArgs -> FCode CLabel
+emitTickyCounter cloType tickee arg_info
   = let name = idName tickee in
     let ctr_lbl = mkRednCountsLabel name in
     (>> return ctr_lbl) $
@@ -273,10 +293,10 @@ emitTickyCounter cloType tickee args
                                     lf_info <- getCgInfo_maybe name
                                     profile <- getProfile
                                     case lf_info of
-                                      Just (CgIdInfo { cg_lf = cg_lf@(LFThunk _top _ _ std_form _)})
+                                      Just (CgIdInfo { cg_lf = cg_lf@(LFThunk {})})
                                           -> pprTrace "tickyThunkStd" empty $ return $
                                              CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf -- zeroCLit platform
-                                      _   -> pprTrace "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs))
+                                      _   -> 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)) $
@@ -287,7 +307,7 @@ emitTickyCounter cloType tickee args
         ; let ctx = (initSDocContext dflags defaultDumpStyle)
                       { sdocPprDebug = True }
         ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name
-        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
+        ; arg_descr_lit <- newStringCLit $ tickyArgDesc arg_info
         ; emitDataLits ctr_lbl
         -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter
         --
@@ -295,7 +315,7 @@ emitTickyCounter cloType tickee 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 arg_info),   -- Arity
               mkIntCLit platform 0,               -- Heap allocated for this thing
               fun_descr_lit,
               arg_descr_lit,