Revert "extended ticky to also track "let"s that are not closures"

This reverts commit 024df664b600a622cb8189ccf31789688505fc1c.

Of course I gaff on my last day...

6 files changed, 47 insertions, 69 deletions

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 0ba99aed36..1e5d6b9f4f 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -204,9 +204,8 @@ cgRhs :: Id
                                   -- (see above)
                )
 
-cgRhs id (StgRhsCon cc con args)
-  = withNewTickyCounterThunk (idName id) $
-    buildDynCon id True cc con args
+cgRhs name (StgRhsCon cc con args)
+  = buildDynCon name cc con args
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
   = do dflags <- getDynFlags
@@ -364,7 +363,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 (Just bndr) info_tbl lf_info use_cc blame_cc
+        ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc
                                          (map toVarArg fv_details)
 
         -- RETURN
@@ -382,9 +381,8 @@ cgRhsStdThunk bndr lf_info payload
        ; return (id_info, gen_code reg)
        }
  where
- gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk (idName bndr) $
-    do
+ gen_code reg
+  = do  -- AHA!  A STANDARD-FORM THUNK
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
   ; dflags <- getDynFlags
@@ -399,11 +397,9 @@ 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 (Just bndr) info_tbl lf_info
+  ; hp_plus_n <- allocDynClosure info_tbl lf_info
                                    use_cc blame_cc payload_w_offsets
 
         -- RETURN
@@ -452,8 +448,7 @@ 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
-  = ASSERT ( not (isStaticClosure cl_info) )
-    withNewTickyCounterThunk (closureName cl_info) $
+  = withNewTickyCounterThunk cl_info $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
    where
@@ -557,7 +552,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
+            do { tickyEnterThunk cl_info
                ; enterCostCentreThunk (CmmReg nodeReg)
                ; let lf_info = closureLFInfo cl_info
                ; fv_bindings <- mapM bind_fv fv_details
@@ -722,7 +717,7 @@ link_caf node _is_upd = do
         blame_cc = use_cc
         tso      = CmmReg (CmmGlobal CurrentTSO)
 
-  ; hp_rel <- allocDynClosureCmm Nothing cafBlackHoleInfoTable mkLFBlackHole
+  ; hp_rel <- allocDynClosureCmm 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 d2a25ebd6c..3e95c59d12 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -109,21 +109,19 @@ 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 actually_bound cc con args
+buildDynCon binder cc con args
     = do dflags <- getDynFlags
-         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args
-
+         buildDynCon' dflags (targetPlatform dflags) binder cc con args
 
 buildDynCon' :: DynFlags
              -> Platform
-             -> Id -> Bool
+             -> Id
              -> CostCentreStack
              -> DataCon
              -> [StgArg]
@@ -150,7 +148,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)
@@ -181,7 +179,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
@@ -195,7 +193,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
@@ -210,7 +208,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
                  , return mkNop) }
 
 -------- buildDynCon': the general case -----------
-buildDynCon' dflags _ binder actually_bound ccs con args
+buildDynCon' dflags _ binder ccs con args
   = do  { (id_info, reg) <- rhsIdInfo binder lf_info
         ; return (id_info, gen_code reg)
         }
@@ -224,10 +222,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args
                 nonptr_wds = tot_wds - ptr_wds
                 info_tbl = mkDataConInfoTable dflags con False
                                 ptr_wds nonptr_wds
-          ; let ticky_name | actually_bound = Just binder
-                           | otherwise = Nothing
-
-          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
+          ; hp_plus_n <- allocDynClosure 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 d7edf8e193..78080218f8 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -610,11 +610,10 @@ cgConApp con stg_args
 
   | otherwise   --  Boxed constructors; allocate and return
   = ASSERT( stg_args `lengthIs` dataConRepRepArity con )
-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False
+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con)
                                      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 (hence the False)
+                -- 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
 
         ; emit =<< fcode_init
         ; emitReturn [idInfoToAmode idinfo] }
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index b8962cedb4..0a817030e5 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -42,7 +42,6 @@ import Cmm
 import CmmUtils
 import CostCentre
 import IdInfo( CafInfo(..), mayHaveCafRefs )
-import Id ( Id )
 import Module
 import DynFlags
 import FastString( mkFastString, fsLit )
@@ -55,8 +54,7 @@ import Data.Maybe (isJust)
 -----------------------------------------------------------
 
 allocDynClosure
-        :: Maybe Id
-        -> CmmInfoTable
+        :: CmmInfoTable
         -> LambdaFormInfo
         -> CmmExpr              -- Cost Centre to stick in the object
         -> CmmExpr              -- Cost Centre to blame for this alloc
@@ -68,7 +66,7 @@ allocDynClosure
         -> FCode CmmExpr -- returns Hp+n
 
 allocDynClosureCmm
-        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
+        :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
         -> [(CmmExpr, VirtualHpOffset)]
         -> FCode CmmExpr -- returns Hp+n
 
@@ -90,19 +88,19 @@ allocDynClosureCmm
 -- significant - see test T4801.
 
 
-allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets
+allocDynClosure 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 mb_id info_tbl lf_info
+        ; allocDynClosureCmm info_tbl lf_info
                              use_cc _blame_cc (zip cmm_args offsets)
         }
 
-allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets
+allocDynClosureCmm 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 mb_id rep lf_info
+        ; tickyDynAlloc (toRednCountsLbl $ cit_lbl info_tbl) 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 1f3d5c4886..dd7e95078f 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 a -> FCode a
+setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
 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 79afe0b17e..6427138639 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -65,9 +65,8 @@ the code generator as well as the RTS because:
 
 module StgCmmTicky (
   withNewTickyCounterFun,
-  withNewTickyCounterLNE,
   withNewTickyCounterThunk,
-  withNewTickyCounterStdThunk,
+  withNewTickyCounterLNE,
 
   tickyDynAlloc,
   tickyAllocHeap,
@@ -88,8 +87,7 @@ module StgCmmTicky (
   tickyEnterViaNode,
 
   tickyEnterFun,
-  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value
-                                              -- thunks only
+  tickyEnterThunk,
   tickyEnterLNE,
 
   tickyUpdateBhCaf,
@@ -143,22 +141,22 @@ import Control.Monad ( when )
 
 data TickyClosureType = TickyFun | TickyThunk | TickyLNE
 
-withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode () -> FCode ()
 withNewTickyCounterFun = withNewTickyCounter TickyFun
 
 withNewTickyCounterLNE nm args code = do
   b <- tickyLNEIsOn
   if not b then code else withNewTickyCounter TickyLNE nm args code
 
-withNewTickyCounterThunk,withNewTickyCounterStdThunk :: Name -> FCode a -> FCode a
-withNewTickyCounterThunk name code = do
+withNewTickyCounterThunk :: ClosureInfo -> FCode () -> FCode ()
+withNewTickyCounterThunk cl_info code
+  | isStaticClosure cl_info = code -- static thunks are uninteresting
+  | otherwise = do
     b <- tickyDynThunkIsOn
-    if not b then code else withNewTickyCounter TickyThunk name [] code
-
-withNewTickyCounterStdThunk = withNewTickyCounterThunk
+    if not b then code else withNewTickyCounter TickyThunk (closureName cl_info) [] code
 
 -- args does not include the void arguments
-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode () -> FCode ()
 withNewTickyCounter cloType name args m = do
   lbl <- emitTickyCounter cloType name args
   setTickyCtrLabel lbl m
@@ -224,28 +222,23 @@ tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
 -- -----------------------------------------------------------------------------
 -- Ticky entries
 
--- 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, tickyEnterStaticCon,
+    tickyEnterStaticThunk, 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 :: FCode ()
-tickyEnterThunk = ifTicky $ do
+tickyEnterThunk :: ClosureInfo -> FCode ()
+tickyEnterThunk cl_info
+  | isStaticClosure cl_info = tickyEnterStaticThunk
+  | otherwise               = 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)
@@ -397,21 +390,20 @@ bad for both space and time).
 -- -----------------------------------------------------------------------------
 -- Ticky allocation
 
-tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
+tickyDynAlloc :: Maybe CLabel -> 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_id rep lf = ifTicky $ getDynFlags >>= \dflags ->
+tickyDynAlloc mb_ctr_lbl 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_id of
+      countSpecific = ifTickyAllocd $ case mb_ctr_lbl of
         Nothing -> return ()
-        Just id -> do
-          let ctr_lbl = mkRednCountsLabel (idName id)
+        Just ctr_lbl -> do
           registerTickyCtr ctr_lbl
           bumpTickyAllocd ctr_lbl bytes
 
@@ -422,7 +414,6 @@ tickyDynAlloc mb_id 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 >>