[commit: ghc] wip/T10613: Be more explicit about thunk types in ticky-ticky-report (440cd51)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T10613
Link       : http://ghc.haskell.org/trac/ghc/changeset/440cd51b184b3622129394e60a72e5d4563744e3/ghc

>---------------------------------------------------------------

commit 440cd51b184b3622129394e60a72e5d4563744e3
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Mar 17 16:33:18 2016 +0100

    Be more explicit about thunk types in ticky-ticky-report
    
    and also, 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.
    
    (The removed line was added in 11a85cc7ea50d4b7c12ea2cc3c0ce39734dc4217)


>---------------------------------------------------------------

440cd51b184b3622129394e60a72e5d4563744e3
 compiler/codeGen/StgCmmBind.hs  | 10 ++++---
 compiler/codeGen/StgCmmTicky.hs | 62 ++++++++++++++++++++++++++++++-----------
 2 files changed, 52 insertions(+), 20 deletions(-)

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index f34186a..b265153 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -206,7 +206,7 @@ cgRhs :: Id
                )
 
 cgRhs id (StgRhsCon cc con args)
-  = withNewTickyCounterThunk False (idName id) $ -- False for "not static"
+  = withNewTickyCounterCon (idName id) $
     buildDynCon id True cc con args
 
 {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
@@ -386,7 +386,7 @@ cgRhsStdThunk bndr lf_info payload
        }
  where
  gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static"
+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
     do
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
@@ -402,7 +402,6 @@ cgRhsStdThunk bndr lf_info payload
 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
   ; let use_cc = curCCS; blame_cc = curCCS
 
-  ; tickyEnterStdThunk closure_info
 
         -- BUILD THE OBJECT
   ; let info_tbl = mkCmmInfo closure_info
@@ -453,7 +452,10 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
 
 closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
   | arity == 0 -- No args i.e. thunk
-  = withNewTickyCounterThunk (isStaticClosure cl_info) (closureName cl_info) $
+  = withNewTickyCounterThunk
+        (isStaticClosure cl_info)
+        (closureUpdReqd cl_info)
+        (closureName cl_info) $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
    where
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 95dfa99..45b88da 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -70,6 +70,7 @@ module StgCmmTicky (
   withNewTickyCounterLNE,
   withNewTickyCounterThunk,
   withNewTickyCounterStdThunk,
+  withNewTickyCounterCon,
 
   tickyDynAlloc,
   tickyAllocHeap,
@@ -143,7 +144,13 @@ import Control.Monad ( unless, when )
 --
 -----------------------------------------------------------------------------
 
-data TickyClosureType = TickyFun | TickyThunk | TickyLNE
+data TickyClosureType
+    = TickyFun
+    | 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
@@ -152,15 +159,38 @@ 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 +214,21 @@ emitTickyCounter cloType name args
         ; let ppr_for_ticky_name :: SDoc
               ppr_for_ticky_name =
                 let n = ppr name
+                    ext = case cloType of
+                              TickyFun -> empty
+                              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