Be more explicit about closure types in ticky-ticky-report

The report now distinguishes thunks (in the variants single-entry and
standard thunks), constructors and functions (possibly single-entry).

Forthermore, for standard thunks (AP and selector), do not count an
entry when they are allocated. It is not possible to count their
entries, as their code is shared, but better count nothing than count
the wrong thing.

1 files changed, 51 insertions, 18 deletions

diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 95dfa99389..d4f352c7d8 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -70,6 +70,7 @@ module StgCmmTicky (
   withNewTickyCounterLNE,
   withNewTickyCounterThunk,
   withNewTickyCounterStdThunk,
+  withNewTickyCounterCon,
 
   tickyDynAlloc,
   tickyAllocHeap,
@@ -143,24 +144,55 @@ import Control.Monad ( unless, when )
 --
 -----------------------------------------------------------------------------
 
-data TickyClosureType = TickyFun | TickyThunk | TickyLNE
+data TickyClosureType
+    = TickyFun
+        Bool -- True <-> single entry
+    | TickyCon
+    | TickyThunk
+        Bool -- True <-> updateable
+        Bool -- True <-> standard thunk (AP or selector), has no entry counter
+    | TickyLNE
 
-withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a
-withNewTickyCounterFun = withNewTickyCounter TickyFun
+withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)
 
+withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a
 withNewTickyCounterLNE nm args code = do
   b <- tickyLNEIsOn
   if not b then code else withNewTickyCounter TickyLNE nm args code
 
-withNewTickyCounterThunk,withNewTickyCounterStdThunk ::
-  Bool -> Name -> FCode a -> FCode a
-withNewTickyCounterThunk isStatic name code = do
+withNewTickyCounterThunk
+  :: Bool -- ^ static
+  -> Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterThunk isStatic isUpdatable name code = do
     b <- tickyDynThunkIsOn
     if isStatic || not b -- ignore static thunks
       then code
-      else withNewTickyCounter TickyThunk name [] code
+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+
+withNewTickyCounterStdThunk
+  :: Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterStdThunk isUpdatable name code = do
+    b <- tickyDynThunkIsOn
+    if not b
+      then code
+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
 
-withNewTickyCounterStdThunk = withNewTickyCounterThunk
+withNewTickyCounterCon
+  :: Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterCon name code = do
+    b <- tickyDynThunkIsOn
+    if not b
+      then code
+      else withNewTickyCounter TickyCon name [] code
 
 -- args does not include the void arguments
 withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
@@ -184,21 +216,22 @@ emitTickyCounter cloType name args
         ; let ppr_for_ticky_name :: SDoc
               ppr_for_ticky_name =
                 let n = ppr name
+                    ext = case cloType of
+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $
+                                  [text "fun"] ++ [text "se"|single_entry]
+                              TickyCon -> parens (text "con")
+                              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?"
                     p = case hasHaskellName parent of
                             -- NB the default "top" ticky ctr does not
                             -- have a Haskell name
                           Just pname -> text "in" <+> ppr (nameUnique pname)
                           _ -> empty
-                in (<+> p) $ if isInternalName name
-                   then let s = n <+> (parens (ppr mod_name))
-                        in case cloType of
-                          TickyFun -> s
-                          TickyThunk -> s <+> parens (text "thk")
-                          TickyLNE -> s <+> parens (text "LNE")
-                  else case cloType of
-                         TickyFun -> n
-                         TickyThunk -> n <+> parens (text "thk")
-                         TickyLNE -> panic "emitTickyCounter: how is this an external LNE?"
+                in if isInternalName name
+                   then n <+> parens (ppr mod_name) <+> ext <+> p
+                   else n <+> ext <+> p
 
         ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
         ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . unsafe_stripNV) args