extended ticky to also track "let"s that are not closuresticky-for-all-lets

This includes selector, ap, and constructor thunks. They are still
guarded by the -ticky-dyn-thk flag.

6 files changed, 69 insertions, 47 deletions

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 1e5d6b9f4f..0ba99aed36 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -204,8 +204,9 @@ cgRhs :: Id
                                   -- (see above)
                )
 
-cgRhs name (StgRhsCon cc con args)
-  = buildDynCon name cc con args
+cgRhs id (StgRhsCon cc con args)
+  = withNewTickyCounterThunk (idName id) $
+    buildDynCon id True cc con args
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
   = do dflags <- getDynFlags
@@ -363,7 +364,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body
         ; emit (mkComment $ mkFastString "calling allocDynClosure")
         ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
         ; let info_tbl = mkCmmInfo closure_info
-        ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc
+        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
                                          (map toVarArg fv_details)
 
         -- RETURN
@@ -381,8 +382,9 @@ cgRhsStdThunk bndr lf_info payload
        ; return (id_info, gen_code reg)
        }
  where
- gen_code reg
-  = do  -- AHA!  A STANDARD-FORM THUNK
+ gen_code reg  -- AHA!  A STANDARD-FORM THUNK
+  = withNewTickyCounterStdThunk (idName bndr) $
+    do
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
   ; dflags <- getDynFlags
@@ -397,9 +399,11 @@ cgRhsStdThunk bndr lf_info payload
 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
   ; let use_cc = curCCS; blame_cc = curCCS
 
+  ; tickyEnterStdThunk
+
         -- BUILD THE OBJECT
   ; let info_tbl = mkCmmInfo closure_info
-  ; hp_plus_n <- allocDynClosure info_tbl lf_info
+  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
                                    use_cc blame_cc payload_w_offsets
 
         -- RETURN
@@ -448,7 +452,8 @@ 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 cl_info $
+  = ASSERT ( not (isStaticClosure cl_info) )
+    withNewTickyCounterThunk (closureName cl_info) $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
    where
@@ -552,7 +557,7 @@ thunkCode cl_info fv_details _cc node arity body
             -- that cc of enclosing scope will be recorded
             -- in update frame CAF/DICT functions will be
             -- subsumed by this enclosing cc
-            do { tickyEnterThunk cl_info
+            do { tickyEnterThunk
                ; enterCostCentreThunk (CmmReg nodeReg)
                ; let lf_info = closureLFInfo cl_info
                ; fv_bindings <- mapM bind_fv fv_details
@@ -717,7 +722,7 @@ link_caf node _is_upd = do
         blame_cc = use_cc
         tso      = CmmReg (CmmGlobal CurrentTSO)
 
-  ; hp_rel <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole
+  ; hp_rel <- allocDynClosureCmm Nothing cafBlackHoleInfoTable mkLFBlackHole
                                          use_cc blame_cc [(tso,fixedHdrSize dflags)]
         -- small optimisation: we duplicate the hp_rel expression in
         -- both the newCAF call and the value returned below.
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 3e95c59d12..d2a25ebd6c 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -109,19 +109,21 @@ cgTopRhsCon id con args
 
 buildDynCon :: Id                 -- Name of the thing to which this constr will
                                   -- be bound
+            -> Bool   -- is it genuinely bound to that name, or just for profiling?
             -> CostCentreStack    -- Where to grab cost centre from;
                                   -- current CCS if currentOrSubsumedCCS
             -> DataCon            -- The data constructor
             -> [StgArg]           -- Its args
             -> FCode (CgIdInfo, FCode CmmAGraph)
                -- Return details about how to find it and initialization code
-buildDynCon binder cc con args
+buildDynCon binder actually_bound cc con args
     = do dflags <- getDynFlags
-         buildDynCon' dflags (targetPlatform dflags) binder cc con args
+         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args
+
 
 buildDynCon' :: DynFlags
              -> Platform
-             -> Id
+             -> Id -> Bool
              -> CostCentreStack
              -> DataCon
              -> [StgArg]
@@ -148,7 +150,7 @@ premature looking at the args will cause the compiler to black-hole!
 -- which have exclusively size-zero (VoidRep) args, we generate no code
 -- at all.
 
-buildDynCon' dflags _ binder _cc con []
+buildDynCon' dflags _ binder _ _cc con []
   = return (litIdInfo dflags binder (mkConLFInfo con)
                 (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
             return mkNop)
@@ -179,7 +181,7 @@ We don't support this optimisation when compiling into Windows DLLs yet
 because they don't support cross package data references well.
 -}
 
-buildDynCon' dflags platform binder _cc con [arg]
+buildDynCon' dflags platform binder _ _cc con [arg]
   | maybeIntLikeCon con
   , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
   , StgLitArg (MachInt val) <- arg
@@ -193,7 +195,7 @@ buildDynCon' dflags platform binder _cc con [arg]
         ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
                  , return mkNop) }
 
-buildDynCon' dflags platform binder _cc con [arg]
+buildDynCon' dflags platform binder _ _cc con [arg]
   | maybeCharLikeCon con
   , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
   , StgLitArg (MachChar val) <- arg
@@ -208,7 +210,7 @@ buildDynCon' dflags platform binder _cc con [arg]
                  , return mkNop) }
 
 -------- buildDynCon': the general case -----------
-buildDynCon' dflags _ binder ccs con args
+buildDynCon' dflags _ binder actually_bound ccs con args
   = do  { (id_info, reg) <- rhsIdInfo binder lf_info
         ; return (id_info, gen_code reg)
         }
@@ -222,7 +224,10 @@ buildDynCon' dflags _ binder ccs con args
                 nonptr_wds = tot_wds - ptr_wds
                 info_tbl = mkDataConInfoTable dflags con False
                                 ptr_wds nonptr_wds
-          ; hp_plus_n <- allocDynClosure info_tbl lf_info
+          ; let ticky_name | actually_bound = Just binder
+                           | otherwise = Nothing
+
+          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
                                           use_cc blame_cc args_w_offsets
           ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
     where
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 78080218f8..d7edf8e193 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -610,10 +610,11 @@ cgConApp con stg_args
 
   | otherwise   --  Boxed constructors; allocate and return
   = ASSERT( stg_args `lengthIs` dataConRepRepArity con )
-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con)
+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False
                                      currentCCS con stg_args
-                -- The first "con" says that the name bound to this closure is
-                -- is "con", which is a bit of a fudge, but it only affects profiling
+                -- The first "con" says that the name bound to this
+                -- closure is is "con", which is a bit of a fudge, but
+                -- it only affects profiling (hence the False)
 
         ; emit =<< fcode_init
         ; emitReturn [idInfoToAmode idinfo] }
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 0a817030e5..b8962cedb4 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -42,6 +42,7 @@ import Cmm
 import CmmUtils
 import CostCentre
 import IdInfo( CafInfo(..), mayHaveCafRefs )
+import Id ( Id )
 import Module
 import DynFlags
 import FastString( mkFastString, fsLit )
@@ -54,7 +55,8 @@ import Data.Maybe (isJust)
 -----------------------------------------------------------
 
 allocDynClosure
-        :: CmmInfoTable
+        :: Maybe Id
+        -> CmmInfoTable
         -> LambdaFormInfo
         -> CmmExpr              -- Cost Centre to stick in the object
         -> CmmExpr              -- Cost Centre to blame for this alloc
@@ -66,7 +68,7 @@ allocDynClosure
         -> FCode CmmExpr -- returns Hp+n
 
 allocDynClosureCmm
-        :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
+        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
         -> [(CmmExpr, VirtualHpOffset)]
         -> FCode CmmExpr -- returns Hp+n
 
@@ -88,19 +90,19 @@ allocDynClosureCmm
 -- significant - see test T4801.
 
 
-allocDynClosure info_tbl lf_info use_cc _blame_cc args_w_offsets
+allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets
   = do  { let (args, offsets) = unzip args_w_offsets
         ; cmm_args <- mapM getArgAmode args     -- No void args
-        ; allocDynClosureCmm info_tbl lf_info
+        ; allocDynClosureCmm mb_id info_tbl lf_info
                              use_cc _blame_cc (zip cmm_args offsets)
         }
 
-allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets
+allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets
   = do  { virt_hp <- getVirtHp
 
         -- SAY WHAT WE ARE ABOUT TO DO
         ; let rep = cit_rep info_tbl
-        ; tickyDynAlloc (toRednCountsLbl $ cit_lbl info_tbl) rep lf_info
+        ; tickyDynAlloc mb_id rep lf_info
         ; profDynAlloc rep use_cc
 
         -- FIND THE OFFSET OF THE INFO-PTR WORD
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index dd7e95078f..1f3d5c4886 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -514,7 +514,7 @@ getTickyCtrLabel = do
         info <- getInfoDown
         return (cgd_ticky info)
 
-setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
+setTickyCtrLabel :: CLabel -> FCode a -> FCode a
 setTickyCtrLabel ticky code = do
         info <- getInfoDown
         withInfoDown code (info {cgd_ticky = ticky})
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 6427138639..79afe0b17e 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -65,8 +65,9 @@ the code generator as well as the RTS because:
 
 module StgCmmTicky (
   withNewTickyCounterFun,
-  withNewTickyCounterThunk,
   withNewTickyCounterLNE,
+  withNewTickyCounterThunk,
+  withNewTickyCounterStdThunk,
 
   tickyDynAlloc,
   tickyAllocHeap,
@@ -87,7 +88,8 @@ module StgCmmTicky (
   tickyEnterViaNode,
 
   tickyEnterFun,
-  tickyEnterThunk,
+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value
+                                              -- thunks only
   tickyEnterLNE,
 
   tickyUpdateBhCaf,
@@ -141,22 +143,22 @@ import Control.Monad ( when )
 
 data TickyClosureType = TickyFun | TickyThunk | TickyLNE
 
-withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode () -> FCode ()
+withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a
 withNewTickyCounterFun = withNewTickyCounter TickyFun
 
 withNewTickyCounterLNE nm args code = do
   b <- tickyLNEIsOn
   if not b then code else withNewTickyCounter TickyLNE nm args code
 
-withNewTickyCounterThunk :: ClosureInfo -> FCode () -> FCode ()
-withNewTickyCounterThunk cl_info code
-  | isStaticClosure cl_info = code -- static thunks are uninteresting
-  | otherwise = do
+withNewTickyCounterThunk,withNewTickyCounterStdThunk :: Name -> FCode a -> FCode a
+withNewTickyCounterThunk name code = do
     b <- tickyDynThunkIsOn
-    if not b then code else withNewTickyCounter TickyThunk (closureName cl_info) [] code
+    if not b then code else withNewTickyCounter TickyThunk name [] code
+
+withNewTickyCounterStdThunk = withNewTickyCounterThunk
 
 -- args does not include the void arguments
-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode () -> FCode ()
+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
 withNewTickyCounter cloType name args m = do
   lbl <- emitTickyCounter cloType name args
   setTickyCtrLabel lbl m
@@ -222,23 +224,28 @@ tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
 -- -----------------------------------------------------------------------------
 -- Ticky entries
 
-tickyEnterDynCon, tickyEnterStaticCon,
-    tickyEnterStaticThunk, tickyEnterViaNode :: FCode ()
+-- NB the name-specific entries are only available for names that have
+-- dedicated Cmm code. As far as I know, this just rules out
+-- constructor thunks. For them, there is no CMM code block to put the
+-- bump of name-specific ticky counter into. On the other hand, we can
+-- still track allocation their allocation.
+
+tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
 tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
 tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
-tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
 tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
 
-tickyEnterThunk :: ClosureInfo -> FCode ()
-tickyEnterThunk cl_info
-  | isStaticClosure cl_info = tickyEnterStaticThunk
-  | otherwise               = ifTicky $ do
+tickyEnterThunk :: FCode ()
+tickyEnterThunk = ifTicky $ do
  bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
  ifTickyDynThunk $ do
    ticky_ctr_lbl <- getTickyCtrLabel
    registerTickyCtrAtEntryDyn ticky_ctr_lbl
    bumpTickyEntryCount ticky_ctr_lbl
 
+tickyEnterStdThunk :: FCode ()
+tickyEnterStdThunk = tickyEnterThunk
+
 tickyBlackHole :: Bool{-updatable-} -> FCode ()
 tickyBlackHole updatable
   = ifTicky (bumpTickyCounter ctr)
@@ -390,20 +397,21 @@ bad for both space and time).
 -- -----------------------------------------------------------------------------
 -- Ticky allocation
 
-tickyDynAlloc :: Maybe CLabel -> SMRep -> LambdaFormInfo -> FCode ()
+tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
 -- Called when doing a dynamic heap allocation; the LambdaFormInfo
 -- used to distinguish between closure types
 --
 -- TODO what else to count while we're here?
-tickyDynAlloc mb_ctr_lbl rep lf = ifTicky $ getDynFlags >>= \dflags ->
+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->
   let bytes = wORD_SIZE dflags * heapClosureSize dflags rep
 
       countGlobal tot ctr = do
         bumpTickyCounterBy tot bytes
         bumpTickyCounter   ctr
-      countSpecific = ifTickyAllocd $ case mb_ctr_lbl of
+      countSpecific = ifTickyAllocd $ case mb_id of
         Nothing -> return ()
-        Just ctr_lbl -> do
+        Just id -> do
+          let ctr_lbl = mkRednCountsLabel (idName id)
           registerTickyCtr ctr_lbl
           bumpTickyAllocd ctr_lbl bytes
 
@@ -414,6 +422,7 @@ tickyDynAlloc mb_ctr_lbl rep lf = ifTicky $ getDynFlags >>= \dflags ->
 
   in case () of
     _ | isConRep rep   ->
+          ifTickyDynThunk countSpecific >>
           countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
       | isThunkRep rep ->
           ifTickyDynThunk countSpecific >>