Rough working implementation of #10613

The COUNTING_IND closure type is based on the (since removed) IND_PERM.

Some of the code is rather ad-hoc and likely in need of some refactoring
and clean-up before entering master (if it ever should), but it should
be good enough to play around with it and obtain some numbers.

35 files changed, 328 insertions, 88 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index df0020301f..83edc8d2fc 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -56,6 +56,7 @@ module CLabel (
         mkDirty_MUT_VAR_Label,
         mkUpdInfoLabel,
         mkBHUpdInfoLabel,
+        mkCountingIndInfoLabel,
         mkIndStaticInfoLabel,
         mkMainCapabilityLabel,
         mkMAP_FROZEN_infoLabel,
@@ -418,7 +419,8 @@ mkStaticConEntryLabel name  c     = IdLabel name c StaticConEntry
 
 -- Constructing Cmm Labels
 mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
-    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
+    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkCountingIndInfoLabel,
+    mkMainCapabilityLabel,
     mkMAP_FROZEN_infoLabel, mkMAP_FROZEN0_infoLabel, mkMAP_DIRTY_infoLabel,
     mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
     mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel,
@@ -428,6 +430,7 @@ mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing
 mkSplitMarkerLabel              = CmmLabel rtsUnitId (fsLit "__stg_split_marker")    CmmCode
 mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
 mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
+mkCountingIndInfoLabel          = CmmLabel rtsUnitId (fsLit "stg_COUNTING_IND")      CmmInfo
 mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo
 mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData
 mkMAP_FROZEN_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo
diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
index 4abbeaf0c1..c02471c6d5 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -17,6 +17,7 @@ module CmmType
     , rEP_CostCentreStack_scc_count
     , rEP_StgEntCounter_allocs
     , rEP_StgEntCounter_allocd
+    , rEP_StgEntCounter_allocd_count
 
     , ForeignHint(..)
 
@@ -352,6 +353,11 @@ rEP_StgEntCounter_allocd dflags
     = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc))
     where pc = sPlatformConstants (settings dflags)
 
+rEP_StgEntCounter_allocd_count :: DynFlags -> CmmType
+rEP_StgEntCounter_allocd_count dflags
+    = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd_count pc))
+    where pc = sPlatformConstants (settings dflags)
+
 -------------------------------------------------------------------------
 {-      Note [Signed vs unsigned]
         ~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs
index ecd8905cbb..6710e83e30 100644
--- a/compiler/cmm/SMRep.hs
+++ b/compiler/cmm/SMRep.hs
@@ -22,7 +22,7 @@ module SMRep (
         ConstrDescription,
 
         -- ** Construction
-        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,
+        mkHeapRep, blackHoleRep, indStaticRep, countingIndRep, mkStackRep, mkRTSRep, arrPtrsRep,
         smallArrPtrsRep, arrWordsRep,
 
         -- ** Predicates
@@ -189,6 +189,7 @@ data ClosureTypeInfo
   | Thunk
   | ThunkSelector SelectorOffset
   | BlackHole
+  | CountingInd
   | IndStatic
 
 type ConstrTag         = Int
@@ -249,6 +250,10 @@ blackHoleRep = HeapRep False 0 0 BlackHole
 indStaticRep :: SMRep
 indStaticRep = HeapRep True 1 0 IndStatic
 
+countingIndRep :: SMRep
+countingIndRep = HeapRep False 1 2 CountingInd
+
+
 arrPtrsRep :: DynFlags -> WordOff -> SMRep
 arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)
 
@@ -279,6 +284,7 @@ isThunkRep :: SMRep -> Bool
 isThunkRep (HeapRep _ _ _ Thunk{})         = True
 isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True
 isThunkRep (HeapRep _ _ _ BlackHole{})     = True
+isThunkRep (HeapRep _ _ _ CountingInd{})       = True
 isThunkRep (HeapRep _ _ _ IndStatic{})     = True
 isThunkRep _                               = False
 
@@ -386,6 +392,7 @@ closureTypeHdrSize dflags ty = case ty of
                   Thunk{}         -> thunkHdrSize dflags
                   ThunkSelector{} -> thunkHdrSize dflags
                   BlackHole{}     -> thunkHdrSize dflags
+                  CountingInd{}     -> thunkHdrSize dflags
                   IndStatic{}     -> thunkHdrSize dflags
                   _               -> fixedHdrSizeW dflags
         -- All thunks use thunkHdrSize, even if they are non-updatable.
@@ -459,6 +466,7 @@ rtsClosureType rep
       HeapRep True _ _ Thunk{}  -> THUNK_STATIC
 
       HeapRep False _ _ BlackHole{} -> BLACKHOLE
+      HeapRep False _ _ CountingInd{} -> COUNTING_IND
 
       HeapRep False _ _ IndStatic{} -> IND_STATIC
 
@@ -535,6 +543,7 @@ pprTypeInfo (ThunkSelector offset)
 
 pprTypeInfo Thunk     = text "Thunk"
 pprTypeInfo BlackHole = text "BlackHole"
+pprTypeInfo CountingInd   = text "CountingInd"
 pprTypeInfo IndStatic = text "IndStatic"
 
 -- XXX Does not belong here!!
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 8adf3b088e..59511758a0 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -46,6 +46,7 @@ import Module
 import ListSetOps
 import Util
 import BasicTypes
+import TyCon ( PrimRep )
 import Outputable
 import FastString
 import DynFlags
@@ -112,11 +113,12 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
                  -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
         ; emitDataLits closure_label closure_rep
         ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
-              (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                               (addIdReps [])
+              (_, _, fv_details, []) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
+                                               (addIdReps []) 0
         -- Don't drop the non-void args until the closure info has been made
-        ; forkClosureBody (closureCodeBody True id closure_info ccs
-                                (nonVoidIds args) (length args) body fv_details)
+        ; forkClosureBody $
+            closureCodeBody True id closure_info ccs (nonVoidIds args)
+                            (length args) body fv_details Nothing
 
         ; return () }
 
@@ -325,7 +327,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
         ; return (id_info, gen_code lf_info reg) }
  where
  gen_code lf_info reg
-  = do  {       -- LAY OUT THE OBJECT
+  = do  { dflags <- getDynFlags
+
+        -- LAY OUT THE OBJECT
         -- If the binder is itself a free variable, then don't store
         -- it in the closure.  Instead, just bind it to Node on entry.
         -- NB we can be sure that Node will point to it, because we
@@ -339,16 +343,27 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
                 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
                             | otherwise    = fvs
 
+        ; let count_entries_in_code =
+                gopt Opt_Ticky_Dyn_Thunk dflags && not (null args)
+        ; let count_entry_with_wrapper =
+                gopt Opt_Ticky_Dyn_Thunk dflags && null args
 
         -- MAKE CLOSURE INFO FOR THIS CLOSURE
         ; mod_name <- getModuleName
-        ; dflags <- getDynFlags
         ; let   name  = idName bndr
                 descr = closureDescription dflags mod_name name
+                fv_reps :: [(PrimRep, Id)]
+                fv_reps = addIdReps (map unsafe_stripNV reduced_fvs)
+
                 fv_details :: [(NonVoid Id, ByteOff)]
-                (tot_wds, ptr_wds, fv_details)
-                   = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                       (addIdReps (map unsafe_stripNV reduced_fvs))
+                (tot_wds, ptr_wds, fv_details, extra_word_offs)
+                   = mkVirtHeapOffsets dflags (isLFThunk lf_info) fv_reps 1
+
+                entry_ctr_offM
+                    | count_entries_in_code   = Just entry_ctr_off
+                    | otherwise = Nothing
+                        where [entry_ctr_off] = extra_word_offs
+
                 closure_info = mkClosureInfo dflags False       -- Not static
                                              bndr lf_info tot_wds ptr_wds
                                              descr
@@ -359,7 +374,7 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
                 --                  (b) ignore Sequel from context; use empty Sequel
                 -- And compile the body
                 closureCodeBody False bndr closure_info cc (nonVoidIds args)
-                                (length args) body fv_details
+                                (length args) body fv_details entry_ctr_offM
 
         -- BUILD THE OBJECT
 --      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
@@ -370,8 +385,18 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
         ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
                                          (map toVarArg fv_details)
 
+        ; -- Initialize dynamic entry counter to zero (where to do this properly?)
+        ; forM_ entry_ctr_offM $ \entry_ctr_off ->
+            emit (mkStore (cmmOffset dflags hp_plus_n entry_ctr_off) (zeroExpr dflags))
+
+        -- WRAP IT IN A COUNTING_IND
+        -- first and third arguments are only used for tickyDynAlloc
+        ; hp_plus_m <- if count_entry_with_wrapper
+                       then wrapInCountingInd dflags bndr use_cc hp_plus_n
+                       else return hp_plus_n
+
         -- RETURN
-        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+        ; return (mkRhsInit dflags reg lf_info hp_plus_m) }
 
 -------------------------
 cgRhsStdThunk
@@ -391,8 +416,8 @@ cgRhsStdThunk bndr lf_info payload
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
   ; dflags <- getDynFlags
-  ; let (tot_wds, ptr_wds, payload_w_offsets)
-            = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
+  ; let (tot_wds, ptr_wds, payload_w_offsets, [])
+            = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload) 0
 
         descr = closureDescription dflags mod_name (idName bndr)
         closure_info = mkClosureInfo dflags False       -- Not static
@@ -402,14 +427,21 @@ cgRhsStdThunk bndr lf_info payload
 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
   ; let use_cc = curCCS; blame_cc = curCCS
 
-
         -- BUILD THE OBJECT
   ; let info_tbl = mkCmmInfo closure_info
   ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
                                    use_cc blame_cc payload_w_offsets
 
+  -- WRAP IT IN A COUNTING_IND
+  -- first and third arguments are only used for tickyDynAlloc
+  ; let count_entry_with_wrapper = gopt Opt_Ticky_Dyn_Thunk dflags
+
+  ; hp_plus_m <- if count_entry_with_wrapper
+                 then wrapInCountingInd dflags bndr use_cc hp_plus_n
+                 else return hp_plus_n
+
         -- RETURN
-  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+  ; return (mkRhsInit dflags reg lf_info hp_plus_m) }
 
 
 mkClosureLFInfo :: DynFlags
@@ -438,6 +470,7 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
                 -> Int             -- arity, including void args
                 -> StgExpr
                 -> [(NonVoid Id, ByteOff)] -- the closure's free vars
+                -> Maybe ByteOff       -- Offset of the dynamic entry ticky counter
                 -> FCode ()
 
 {- There are two main cases for the code for closures.
@@ -450,7 +483,7 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
   normal form, so there is no need to set up an update frame.
 -}
 
-closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
+closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details _entry_ctr_off
   | arity == 0 -- No args i.e. thunk
   = withNewTickyCounterThunk
         (isStaticClosure cl_info)
@@ -462,7 +495,7 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
      lf_info  = closureLFInfo cl_info
      info_tbl = mkCmmInfo cl_info
 
-closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details entry_ctr_offM
   = -- Note: args may be [], if all args are Void
     withNewTickyCounterFun
         (closureSingleEntry cl_info)
@@ -491,8 +524,15 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                 ; entryHeapCheck cl_info node' arity arg_regs $ do
                 { -- emit LDV code when profiling
                   when node_points (ldvEnterClosure cl_info (CmmLocal node))
+
                 -- ticky after heap check to avoid double counting
-                ; tickyEnterFun cl_info
+                ; let tag = lfDynTag dflags lf_info
+                ; let entry_ctr_expM = case entry_ctr_offM of
+                        { Just entry_ctr_off -> Just $ mkTaggedObjectExpr dflags node entry_ctr_off tag
+                        ; Nothing -> Nothing
+                        }
+                ; tickyEnterFun cl_info entry_ctr_expM
+
                 ; enterCostCentreFun cc
                     (CmmMachOp (mo_wordSub dflags)
                          [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index c612366904..7aa90ae28a 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -55,6 +55,7 @@ module StgCmmClosure (
         -- * InfoTables
         mkDataConInfoTable,
         cafBlackHoleInfoTable,
+        countingIndInfoTable,
         indStaticInfoTable,
         staticClosureNeedsLink,
     ) where
@@ -1029,6 +1030,13 @@ indStaticInfoTable
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
+countingIndInfoTable :: CmmInfoTable
+countingIndInfoTable
+  = CmmInfoTable { cit_lbl  = mkCountingIndInfoLabel
+                 , cit_rep  = countingIndRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = NoC_SRT }
+
 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- A static closure needs a link field to aid the GC when traversing
 -- the static closure graph.  But it only needs such a field if either
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index ebff4402d0..98c8c58ff9 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -19,7 +19,9 @@ module StgCmmHeap (
         mkStaticClosureFields, mkStaticClosure,
 
         allocDynClosure, allocDynClosureCmm, allocHeapClosure,
-        emitSetDynHdr
+        emitSetDynHdr,
+
+        wrapInCountingInd
     ) where
 
 #include "HsVersions.h"
@@ -42,7 +44,7 @@ import Cmm
 import CmmUtils
 import CostCentre
 import IdInfo( CafInfo(..), mayHaveCafRefs )
-import Id ( Id )
+import Id ( Id, idName )
 import Module
 import DynFlags
 import FastString( mkFastString, fsLit )
@@ -65,7 +67,7 @@ allocDynClosure
         -> CmmExpr              -- Cost Centre to blame for this alloc
                                 -- (usually the same; sometimes "OVERHEAD")
 
-        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
+        -> [(NonVoid StgArg, ByteOff)]  -- Offsets from start of object
                                                 -- ie Info ptr has offset zero.
                                                 -- No void args in here
         -> FCode CmmExpr -- returns Hp+n
@@ -108,6 +110,18 @@ allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do
   allocHeapClosure rep info_ptr use_cc amodes_w_offsets
 
 
+wrapInCountingInd :: DynFlags -> Id -> CmmExpr -> CmmExpr -> FCode CmmExpr
+wrapInCountingInd dflags id use_cc arg
+    = -- pprTrace "wrapInCountingInd" (ppr id <+> ppIdInfo id (idInfo id) <+> ppr (idRepArity id)) $
+      allocHeapClosure countingIndRep (CmmLit (CmmLabel mkCountingIndInfoLabel)) use_cc $
+            [ (arg,               hdr_size + oFFSET_StgCountingInd_indirectee dflags)
+            , (mkLblExpr ctr_lbl, hdr_size + oFFSET_StgCountingInd_ent_counter dflags)
+            , (zeroExpr dflags,   hdr_size + oFFSET_StgCountingInd_entries dflags)
+            ]
+  where
+    ctr_lbl = mkRednCountsLabel (idName id)
+    hdr_size = fixedHdrSize dflags
+
 -- | Low-level heap object allocation.
 allocHeapClosure
   :: SMRep                            -- ^ representation of the object
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 47ee370212..5dcf535af1 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -388,11 +388,13 @@ getHpRelOffset virtual_offset
 
 mkVirtHeapOffsets
   :: DynFlags
-  -> Bool                -- True <=> is a thunk
-  -> [(PrimRep,a)]        -- Things to make offsets for
+  -> Bool                     -- True <=> is a thunk
+  -> [(PrimRep,a)]            -- Things to make offsets for
+  -> Int                      -- Extra words to include
   -> (WordOff,                -- _Total_ number of words allocated
       WordOff,                -- Number of words allocated for *pointers*
-      [(NonVoid a, ByteOff)])
+      [(NonVoid a, ByteOff)], -- Offsets for things
+      [ByteOff])              -- Offsets for extra words
 
 -- Things with their offsets from start of object in order of
 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
@@ -404,10 +406,11 @@ mkVirtHeapOffsets
 -- mkVirtHeapOffsets always returns boxed things with smaller offsets
 -- than the unboxed things
 
-mkVirtHeapOffsets dflags is_thunk things
+mkVirtHeapOffsets dflags is_thunk things extra_words
   = ( bytesToWordsRoundUp dflags tot_bytes
     , bytesToWordsRoundUp dflags bytes_of_ptrs
     , ptrs_w_offsets ++ non_ptrs_w_offsets
+    , extra_w_offsets
     )
   where
     hdr_words | is_thunk   = thunkHdrSize dflags
@@ -419,18 +422,26 @@ mkVirtHeapOffsets dflags is_thunk things
 
     (bytes_of_ptrs, ptrs_w_offsets) =
        mapAccumL computeOffset 0 ptrs
-    (tot_bytes, non_ptrs_w_offsets) =
+    (bytes_of_ptrs_non_ptrs, non_ptrs_w_offsets) =
        mapAccumL computeOffset bytes_of_ptrs non_ptrs
+    (tot_bytes, extra_w_offsets) =
+       mapAccumL computeOffset' bytes_of_ptrs_non_ptrs [1..extra_words]
 
     computeOffset bytes_so_far (rep, thing)
       = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)),
          (NonVoid thing, hdr_bytes + bytes_so_far))
 
+    computeOffset' bytes_so_far _
+      = (bytes_so_far + wordsToBytes dflags 1,
+         (hdr_bytes + bytes_so_far))
+
 -- | Just like mkVirtHeapOffsets, but for constructors
 mkVirtConstrOffsets
   :: DynFlags -> [(PrimRep,a)]
   -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
+mkVirtConstrOffsets dflags things =
+    let (tot_rds, ptr_wds, payload_w_offsets, []) = mkVirtHeapOffsets dflags False things 0
+    in  (tot_rds, ptr_wds, payload_w_offsets)
 
 
 -------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 8df2dcac28..020d76900a 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -137,6 +137,7 @@ import TyCon
 import Data.Maybe
 import qualified Data.Char
 import Control.Monad ( unless, when )
+import Data.Foldable ( forM_ )
 
 -----------------------------------------------------------------------------
 --
@@ -243,11 +244,14 @@ emitTickyCounter cloType name args
         -- properly and it led to chaos, panic and disorder.
             [ mkIntCLit dflags 0,               -- registered?
               mkIntCLit dflags (length args),   -- Arity
+              mkIntCLit dflags 0,               -- Allocation count for this thing
               mkIntCLit dflags 0,               -- Heap allocated for this thing
               fun_descr_lit,
               arg_descr_lit,
-              zeroCLit dflags,          -- Entries into this thing
-              zeroCLit dflags,          -- Heap allocated by this thing
+              zeroCLit dflags,          -- entry_count
+              zeroCLit dflags,          -- single_entry_count
+              zeroCLit dflags,          -- multi_entry_count
+              zeroCLit dflags,          -- allocs
               zeroCLit dflags                   -- Link to next StgEntCounter
             ]
         }
@@ -307,8 +311,8 @@ tickyUpdateBhCaf cl_info
     ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
         | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
 
-tickyEnterFun :: ClosureInfo -> FCode ()
-tickyEnterFun cl_info = ifTicky $ do
+tickyEnterFun :: ClosureInfo -> Maybe CmmExpr -> FCode ()
+tickyEnterFun cl_info entry_ctr_expM = ifTicky $ do
   ctr_lbl <- getTickyCtrLabel
 
   if isStaticClosure cl_info
@@ -319,6 +323,30 @@ tickyEnterFun cl_info = ifTicky $ do
 
   bumpTickyEntryCount ctr_lbl
 
+  emitComment $ mkFastString "Foo"
+  forM_ entry_ctr_expM $ \entry_ctr_exp -> do
+      dflags <- getDynFlags
+      emitComment $ mkFastString "Dynamic entry counting code"
+
+      -- This code replicates the code of COUNTING_IND in StgMiscClosures.cmm. How
+      -- to de-duplicate that?
+      let test0 = cmmEqWord dflags (CmmLoad entry_ctr_exp (bWord dflags))
+                                   (zeroExpr dflags)
+          tick0 = catAGraphs $
+            [ addToMem (bWord dflags) (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_single_entry_count dflags))) 1
+            ]
+          test1 = cmmEqWord dflags (CmmLoad entry_ctr_exp (bWord dflags))
+                                   (mkIntExpr dflags 1)
+          tick1 = catAGraphs $
+            [ addToMem (bWord dflags) (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_single_entry_count dflags))) (-1)
+            , addToMem (bWord dflags) (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_multi_entry_count dflags))) 1
+            ]
+      emit =<< mkCmmIfThen test0 tick0
+      emit =<< mkCmmIfThen test1 tick1
+      emit (addToMem (bWord dflags) entry_ctr_exp 1)
+
+
+
 tickyEnterLNE :: FCode ()
 tickyEnterLNE = ifTicky $ do
   bumpTickyCounter (fsLit "ENT_LNE_ctr")
@@ -585,6 +613,7 @@ bumpTickyEntryCount lbl = do
 bumpTickyAllocd :: CLabel -> Int -> FCode ()
 bumpTickyAllocd lbl bytes = do
   dflags <- getDynFlags
+  bumpTickyLit   (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd_count dflags))
   bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
 
 bumpTickyLbl :: CLabel -> FCode ()
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 86c03ac2c4..a490f8fa6c 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -19,7 +19,7 @@ module StgCmmUtils (
 
         emitMultiAssign, emitCmmLitSwitch, emitSwitch,
 
-        tagToClosure, mkTaggedObjectLoad,
+        tagToClosure, mkTaggedObjectExpr, mkTaggedObjectLoad,
 
         callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
 
@@ -137,6 +137,11 @@ addToMemE rep ptr n
 --
 -------------------------------------------------------------------------
 
+mkTaggedObjectExpr
+  :: DynFlags -> LocalReg -> ByteOff -> DynTag -> CmmExpr
+mkTaggedObjectExpr dflags base offset tag
+  = cmmOffsetB dflags (CmmReg (CmmLocal base)) (offset - tag)
+
 mkTaggedObjectLoad
   :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
 -- (loadTaggedObjectField reg base off tag) generates assignment
@@ -144,10 +149,7 @@ mkTaggedObjectLoad
 -- where K is fixed by 'reg'
 mkTaggedObjectLoad dflags reg base offset tag
   = mkAssign (CmmLocal reg)
-             (CmmLoad (cmmOffsetB dflags
-                                  (CmmReg (CmmLocal base))
-                                  (offset - tag))
-                      (localRegType reg))
+             (CmmLoad (mkTaggedObjectExpr dflags base offset tag) (localRegType reg))
 
 -------------------------------------------------------------------------
 --
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 75e91a4408..4ea2934ad7 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -11,7 +11,7 @@ module PprCore (
         pprCoreExpr, pprParendExpr,
         pprCoreBinding, pprCoreBindings, pprCoreAlt,
         pprCoreBindingWithSize, pprCoreBindingsWithSize,
-        pprRules
+        pprRules, ppIdInfo
     ) where
 
 import CoreSyn
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 4e1c828a4d..c1dbc2998c 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -57,8 +57,8 @@ make_constr_itbls hsc_env cons =
                     | arg <- dataConRepArgTys dcon
                     , rep_arg <- flattenRepType (repType arg) ]
 
-         (tot_wds, ptr_wds, _) =
-             mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
+         (tot_wds, ptr_wds, _, []) =
+             mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args 0
 
          ptrs'  = ptr_wds
          nptrs' = tot_wds - ptr_wds
diff --git a/includes/Cmm.h b/includes/Cmm.h
index 3b9a5a6794..4fd5910d1f 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -288,6 +288,7 @@
          (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {       \
   case                                                  \
     IND,                                                \
+    COUNTING_IND,                                           \
     IND_STATIC:                                         \
    {                                                    \
       x = StgInd_indirectee(x);                         \
diff --git a/includes/rts/Ticky.h b/includes/rts/Ticky.h
index ff4d44a0d0..03729222e2 100644
--- a/includes/rts/Ticky.h
+++ b/includes/rts/Ticky.h
@@ -18,16 +18,23 @@
    The StgEntCounter type - needed regardless of TICKY_TICKY
    -------------------------------------------------------------------------- */
 
+/*
+ * Changes here must be reflected in emitTickyCounter in StgCmmTicky.hs.
+ */
+
 typedef struct _StgEntCounter {
   /* Using StgWord for everything, because both the C and asm code
      generators make trouble if you try to pack things tighter */
     StgWord     registeredp;    /* 0 == no, 1 == yes */
     StgInt      arity;          /* arity (static info) */
-    StgInt      allocd;         /* # allocation of this closure */
+    StgInt      allocd_count;   /* instances allocated of this closure */
+    StgInt      allocd;         /* bytes allocates for this closure */
                                 /* (rest of args are in registers) */
     char        *str;           /* name of the thing */
     char        *arg_kinds;     /* info about the args types */
     StgInt      entry_count;    /* Trips to fast entry code */
+    StgInt      single_entry_count;  /* How many instance with a single entry */
+    StgInt      multi_entry_count;  /* How many instance with multiple entries */
     StgInt      allocs;         /* number of allocations by this fun */
     struct _StgEntCounter *link;/* link to chain them all together */
 } StgEntCounter;
diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h
index 4ebec0f45f..eb22afe7d0 100644
--- a/includes/rts/storage/ClosureMacros.h
+++ b/includes/rts/storage/ClosureMacros.h
@@ -396,6 +396,7 @@ closure_sizeW_ (const StgClosure *p, const StgInfoTable *info)
     case PAP:
         return pap_sizeW((StgPAP *)p);
     case IND:
+    case COUNTING_IND:
         return sizeofW(StgInd);
     case ARR_WORDS:
         return arr_words_sizeW((StgArrBytes *)p);
diff --git a/includes/rts/storage/ClosureTypes.h b/includes/rts/storage/ClosureTypes.h
index 4f66de318b..ad58e56f45 100644
--- a/includes/rts/storage/ClosureTypes.h
+++ b/includes/rts/storage/ClosureTypes.h
@@ -47,41 +47,42 @@
 #define PAP                     26
 #define AP_STACK                27
 #define IND                     28
-#define IND_STATIC              29
-#define RET_BCO                 30
-#define RET_SMALL               31
-#define RET_BIG                 32
-#define RET_FUN                 33
-#define UPDATE_FRAME            34
-#define CATCH_FRAME             35
-#define UNDERFLOW_FRAME         36
-#define STOP_FRAME              37
-#define BLOCKING_QUEUE          38
-#define BLACKHOLE               39
-#define MVAR_CLEAN              40
-#define MVAR_DIRTY              41
-#define TVAR                    42
-#define ARR_WORDS               43
-#define MUT_ARR_PTRS_CLEAN      44
-#define MUT_ARR_PTRS_DIRTY      45
-#define MUT_ARR_PTRS_FROZEN0    46
-#define MUT_ARR_PTRS_FROZEN     47
-#define MUT_VAR_CLEAN           48
-#define MUT_VAR_DIRTY           49
-#define WEAK                    50
-#define PRIM                    51
-#define MUT_PRIM                52
-#define TSO                     53
-#define STACK                   54
-#define TREC_CHUNK              55
-#define ATOMICALLY_FRAME        56
-#define CATCH_RETRY_FRAME       57
-#define CATCH_STM_FRAME         58
-#define WHITEHOLE               59
-#define SMALL_MUT_ARR_PTRS_CLEAN      60
-#define SMALL_MUT_ARR_PTRS_DIRTY      61
-#define SMALL_MUT_ARR_PTRS_FROZEN0    62
-#define SMALL_MUT_ARR_PTRS_FROZEN     63
-#define N_CLOSURE_TYPES         64
+#define COUNTING_IND            29
+#define IND_STATIC              30
+#define RET_BCO                 31
+#define RET_SMALL               32
+#define RET_BIG                 33
+#define RET_FUN                 34
+#define UPDATE_FRAME            35
+#define CATCH_FRAME             36
+#define UNDERFLOW_FRAME         37
+#define STOP_FRAME              38
+#define BLOCKING_QUEUE          39
+#define BLACKHOLE               40
+#define MVAR_CLEAN              41
+#define MVAR_DIRTY              42
+#define TVAR                    43
+#define ARR_WORDS               44
+#define MUT_ARR_PTRS_CLEAN      45
+#define MUT_ARR_PTRS_DIRTY      46
+#define MUT_ARR_PTRS_FROZEN0    47
+#define MUT_ARR_PTRS_FROZEN     48
+#define MUT_VAR_CLEAN           49
+#define MUT_VAR_DIRTY           50
+#define WEAK                    51
+#define PRIM                    52
+#define MUT_PRIM                53
+#define TSO                     54
+#define STACK                   55
+#define TREC_CHUNK              56
+#define ATOMICALLY_FRAME        57
+#define CATCH_RETRY_FRAME       58
+#define CATCH_STM_FRAME         59
+#define WHITEHOLE               60
+#define SMALL_MUT_ARR_PTRS_CLEAN      61
+#define SMALL_MUT_ARR_PTRS_DIRTY      62
+#define SMALL_MUT_ARR_PTRS_FROZEN0    63
+#define SMALL_MUT_ARR_PTRS_FROZEN     64
+#define N_CLOSURE_TYPES         65
 
 #endif /* RTS_STORAGE_CLOSURETYPES_H */
diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h
index f880b5c876..88e083117a 100644
--- a/includes/rts/storage/Closures.h
+++ b/includes/rts/storage/Closures.h
@@ -121,6 +121,13 @@ typedef struct {
 } StgInd;
 
 typedef struct {
+    StgHeader   header;
+    StgClosure *indirectee;
+    const void *ent_counter; // A StgEntCounter
+    StgWord     entries;
+} StgCountingInd;
+
+typedef struct {
     StgHeader     header;
     StgClosure   *indirectee;
     StgClosure   *static_link;
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 731893efd0..570d8be40f 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -86,6 +86,7 @@ RTS_RET(stg_apply_interp);
 RTS_ENTRY(stg_IND);
 RTS_ENTRY(stg_IND_direct);
 RTS_ENTRY(stg_IND_STATIC);
+RTS_ENTRY(stg_COUNTING_IND);
 RTS_ENTRY(stg_BLACKHOLE);
 RTS_ENTRY(stg_CAF_BLACKHOLE);
 RTS_ENTRY(__stg_EAGER_BLACKHOLE);
diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c
index d303315981..b80e3571da 100644
--- a/rts/CheckUnload.c
+++ b/rts/CheckUnload.c
@@ -137,6 +137,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
                 size = sizeW_fromITBL(info);
                 break;
 
+            case COUNTING_IND:
             case BLACKHOLE:
             case BLOCKING_QUEUE:
                 prim = rtsTrue;
diff --git a/rts/ClosureFlags.c b/rts/ClosureFlags.c
index cd2c7e1435..337c82a368 100644
--- a/rts/ClosureFlags.c
+++ b/rts/ClosureFlags.c
@@ -50,6 +50,7 @@ StgWord16 closure_flags[] = {
  [PAP]                  =  (_HNF|     _NS                                ),
  [AP_STACK]             =  (                   _THU                      ),
  [IND]                  =  (          _NS|                        _IND ),
+ [COUNTING_IND]         =  (          _NS|                        _IND ),
  [IND_STATIC]           =  (          _NS|_STA|                   _IND ),
  [RET_BCO]              =  ( 0                                         ),
  [RET_SMALL]            =  (     _BTM|                       _SRT      ),
@@ -87,6 +88,6 @@ StgWord16 closure_flags[] = {
  [SMALL_MUT_ARR_PTRS_FROZEN]  =  (_HNF|     _NS|              _UPT           )
 };
 
-#if N_CLOSURE_TYPES != 64
+#if N_CLOSURE_TYPES != 65
 #error Closure types changed: update ClosureFlags.c!
 #endif
diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index f88e47493c..e0af19b722 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -330,6 +330,7 @@ eval_obj:
     switch ( get_itbl(obj)->type ) {
 
     case IND:
+    case COUNTING_IND:
     case IND_STATIC:
     {
         tagged_obj = ((StgInd*)obj)->indirectee;
diff --git a/rts/LdvProfile.c b/rts/LdvProfile.c
index 428078bb40..415cd72d34 100644
--- a/rts/LdvProfile.c
+++ b/rts/LdvProfile.c
@@ -109,6 +109,7 @@ processHeapClosureForDead( const StgClosure *c )
     case FUN_0_2:
     case BLACKHOLE:
     case BLOCKING_QUEUE:
+    case COUNTING_IND:
         /*
           'Ingore' cases
         */
diff --git a/rts/Printer.c b/rts/Printer.c
index 1ee1c6c4b3..a1b0ff0256 100644
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -232,6 +232,12 @@ printClosure( const StgClosure *obj )
             debugBelch(")\n");
             break;
 
+    case COUNTING_IND:
+            debugBelch("COUNTING_IND(");
+            printPtr((StgPtr)((StgInd*)obj)->indirectee);
+            debugBelch(")\n");
+            break;
+
     case IND_STATIC:
             debugBelch("IND_STATIC(");
             printPtr((StgPtr)((StgInd*)obj)->indirectee);
@@ -843,6 +849,7 @@ const char *closure_type_names[] = {
  [PAP]                   = "PAP",
  [AP_STACK]              = "AP_STACK",
  [IND]                   = "IND",
+ [COUNTING_IND]          = "COUNTING_IND",
  [IND_STATIC]            = "IND_STATIC",
  [RET_BCO]               = "RET_BCO",
  [RET_SMALL]             = "RET_SMALL",
diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c
index 18c3e41a32..88ac63ef6c 100644
--- a/rts/ProfHeap.c
+++ b/rts/ProfHeap.c
@@ -977,6 +977,7 @@ heapCensusChain( Census *census, bdescr *bd )
 
             case CONSTR:
             case FUN:
+            case COUNTING_IND:
             case BLACKHOLE:
             case BLOCKING_QUEUE:
             case FUN_1_0:
diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c
index 3fe0f8bf9a..83b4beb392 100644
--- a/rts/RetainerProfile.c
+++ b/rts/RetainerProfile.c
@@ -462,6 +462,7 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
     case THUNK_SELECTOR:
         *first_child = ((StgSelector *)c)->selectee;
         return;
+    case COUNTING_IND:
     case BLACKHOLE:
         *first_child = ((StgInd *)c)->indirectee;
         return;
@@ -929,6 +930,7 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
         case MUT_VAR_CLEAN:
         case MUT_VAR_DIRTY:
         case THUNK_SELECTOR:
+        case COUNTING_IND:
         case CONSTR_1_1:
             // cannot appear
         case PAP:
@@ -1064,9 +1066,7 @@ isRetainer( StgClosure *c )
         // partial applications
     case PAP:
         // indirection
-    // IND_STATIC used to be an error, but at the moment it can happen
-    // as isAlive doesn't look through IND_STATIC as it ignores static
-    // closures. See trac #3956 for a program that hit this error.
+    case COUNTING_IND:
     case IND_STATIC:
     case BLACKHOLE:
         // static objects
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index e66b4d81cb..32c652859b 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -603,6 +603,7 @@
       SymI_HasProto(stg_MVAR_DIRTY_info)                                \
       SymI_HasProto(stg_TVAR_CLEAN_info)                                \
       SymI_HasProto(stg_TVAR_DIRTY_info)                                \
+      SymI_HasProto(stg_COUNTING_IND_info)                                  \
       SymI_HasProto(stg_IND_STATIC_info)                                \
       SymI_HasProto(stg_ARR_WORDS_info)                                 \
       SymI_HasProto(stg_MUT_ARR_PTRS_DIRTY_info)                        \
diff --git a/rts/Stable.c b/rts/Stable.c
index 9f34072e61..ffe69ba169 100644
--- a/rts/Stable.c
+++ b/rts/Stable.c
@@ -355,6 +355,7 @@ removeIndirections (StgClosure* p)
         switch (get_itbl(q)->type) {
         case IND:
         case IND_STATIC:
+        case COUNTING_IND:
             p = ((StgInd *)q)->indirectee;
             continue;
 
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 905f81ec2e..96b95aabfe 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -258,6 +258,49 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC")
     jump %GET_ENTRY(R1) [R1];
 }
 
+INFO_TABLE(stg_COUNTING_IND,1,2,COUNTING_IND,"COUNTING_IND","COUNTING_IND")
+    /* explicit stack */
+{
+    W_ tag, clos, entries, ent_ctr;
+    /* Don't add INDs to granularity cost */
+
+    /* Don't: TICK_ENT_STATIC_IND(Node); for ticky-ticky; this ind is
+       here only to help profiling */
+
+    // Preserve tag
+    clos = UNTAG(R1);
+    tag = GETTAG(R1);
+
+    // ccall debugBelch("COUNTING_IND %p %p %d\n", StgInd_indirectee(clos), StgCountingInd_ent_counter(clos), StgCountingInd_entries(clos));
+
+    ent_ctr = StgCountingInd_ent_counter(clos);
+    entries = StgCountingInd_entries(clos);
+    if (entries == 0) {
+        StgEntCounter_single_entry_count(ent_ctr) = StgEntCounter_single_entry_count(ent_ctr) +1;
+    }
+    if (entries == 1) {
+        StgEntCounter_single_entry_count(ent_ctr) = StgEntCounter_single_entry_count(ent_ctr) - 1;
+        StgEntCounter_multi_entry_count(ent_ctr)  = StgEntCounter_multi_entry_count(ent_ctr) + 1;
+    }
+    StgCountingInd_entries(clos) = entries + 1;
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+    /* TICKY_TICKY && !PROFILING means PERM_IND *replaces* an IND, rather than
+       being extra  */
+    TICK_ENT_PERM_IND();
+#endif
+
+    LDV_ENTER(R1);
+
+    R1 = UNTAG(StgCountingInd_indirectee(clos))+tag;
+
+#if defined(TICKY_TICKY) && !defined(PROFILING)
+    TICK_ENT_VIA_NODE();
+#endif
+
+    jump %GET_ENTRY(UNTAG(R1)) [R1];
+}
+
 /* ----------------------------------------------------------------------------
    Black holes.
 
diff --git a/rts/Ticky.c b/rts/Ticky.c
index 44d49b6551..ffc3941472 100644
--- a/rts/Ticky.c
+++ b/rts/Ticky.c
@@ -14,9 +14,10 @@
  * here.
  */
 StgEntCounter top_ct
-        = { 0, 0, 0,
+        = { 0, 0, 0, 0,
             "TOP", "",
-            0, 0, NULL };
+            0, 0, 0, 0,
+	    NULL };
 
 /* Data structure used in ``registering'' one of these counters. */
 
@@ -356,16 +357,26 @@ printRegisteredCounterInfo (FILE *tf)
       fprintf(tf,"\nThe following table is explained by http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky\nAll allocation numbers are in bytes.\n");
       fprintf(tf,"\n**************************************************\n\n");
     }
-    fprintf(tf, "%11s%11s%11s  %-23s %s\n",
-            "Entries", "Alloc", "Alloc'd", "Non-void Arguments", "STG Name");
+    fprintf(tf, "%11s%11s%11s%11s%11s%11s  %-23s %s\n",
+            "Entries", "Alloc", "Alloc'd", "#Alloc", "Single", "Multiple", "Non-void Arguments", "STG Name");
     fprintf(tf, "--------------------------------------------------------------------------------\n");
     /* Function name at the end so it doesn't mess up the tabulation */
 
     for (p = ticky_entry_ctrs; p != NULL; p = p->link) {
-        fprintf(tf, "%11" FMT_Int "%11" FMT_Int "%11" FMT_Int " %3lu %-20.20s %s",
+        fprintf(tf,
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            "%11" FMT_Int
+            " %3lu %-20.20s %s",
                 p->entry_count,
                 p->allocs,
                 p->allocd,
+                p->allocd_count,
+                p->single_entry_count,
+                p->multi_entry_count,
                 (unsigned long)p->arity,
                 p->arg_kinds,
                 p->str);
diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c
index ec178e91ef..c391fc11d6 100644
--- a/rts/sm/Compact.c
+++ b/rts/sm/Compact.c
@@ -650,6 +650,7 @@ thread_obj (const StgInfoTable *info, StgPtr p)
     }
 
     case IND:
+    case COUNTING_IND:
         thread(&((StgInd *)p)->indirectee);
         return p + sizeofW(StgInd);
 
diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index e53461de63..a115269942 100644
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -601,6 +601,7 @@ loop:
       return;
 
   case FUN:
+  case COUNTING_IND:
   case CONSTR:
       copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag);
       return;
@@ -964,6 +965,7 @@ selector_loop:
                   info = INFO_PTR_TO_STRUCT((StgInfoTable *)info_ptr);
                   switch (info->type) {
                   case IND:
+                  case COUNTING_IND:
                   case IND_STATIC:
                       val = ((StgInd *)val)->indirectee;
                       goto val_loop;
@@ -1001,6 +1003,12 @@ selector_loop:
           selectee = UNTAG_CLOSURE( ((StgInd *)selectee)->indirectee );
           goto selector_loop;
 
+      case COUNTING_IND:
+          // do not short cut a COUNTING_IND, as we would miss a the count
+	  // Can we simply tick the counter here? Not really: If this selector
+	  // thunk is not going to be used, we counted more than we wanted!
+          goto bale_out;
+
       case BLACKHOLE:
       {
           StgClosure *r;
diff --git a/rts/sm/GCAux.c b/rts/sm/GCAux.c
index 6265bf9ca1..524225581b 100644
--- a/rts/sm/GCAux.c
+++ b/rts/sm/GCAux.c
@@ -88,6 +88,7 @@ isAlive(StgClosure *p)
 
     case IND:
     case IND_STATIC:
+    case COUNTING_IND:
       // follow indirections
       p = ((StgInd *)q)->indirectee;
       continue;
diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c
index 62d53e046d..60a9f27f18 100644
--- a/rts/sm/Sanity.c
+++ b/rts/sm/Sanity.c
@@ -276,6 +276,7 @@ checkClosure( const StgClosure* p )
     case CONSTR_1_1:
     case CONSTR_0_2:
     case CONSTR_2_0:
+    case COUNTING_IND:
     case BLACKHOLE:
     case PRIM:
     case MUT_PRIM:
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index 18a30d3bdf..a49b85d909 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -582,6 +582,11 @@ scavenge_block (bdescr *bd)
         break;
     }
 
+    case COUNTING_IND:
+        evacuate(&((StgCountingInd *)p)->indirectee);
+        p += sizeofW(StgCountingInd);
+        break;
+
     case BLACKHOLE:
         evacuate(&((StgInd *)p)->indirectee);
         p += sizeofW(StgInd);
@@ -981,6 +986,12 @@ scavenge_mark_stack(void)
             break;
         }
 
+        case COUNTING_IND:
+            // don't need to do anything here: the only possible case
+            // is that we're in a 1-space compacting collector, with
+            // no "old" generation.
+            break;
+
         case IND:
         case BLACKHOLE:
             evacuate(&((StgInd *)p)->indirectee);
@@ -1289,6 +1300,7 @@ scavenge_one(StgPtr p)
     case CONSTR_0_2:
     case CONSTR_2_0:
     case PRIM:
+    case COUNTING_IND:
     {
         StgPtr q, end;
 
diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index 63e2233f8b..27948429e7 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -415,10 +415,13 @@ wanteds os = concat
           ,closurePayload C "StgClosure" "payload"
 
           ,structFieldH Both "StgEntCounter" "allocs"
+          ,structFieldH Both "StgEntCounter" "allocd_count"
           ,structFieldH Both "StgEntCounter" "allocd"
           ,structField  Both "StgEntCounter" "registeredp"
           ,structField  Both "StgEntCounter" "link"
           ,structField  Both "StgEntCounter" "entry_count"
+          ,structField  Both "StgEntCounter" "single_entry_count"
+          ,structField  Both "StgEntCounter" "multi_entry_count"
 
           ,closureSize Both "StgUpdateFrame"
           ,closureSize C    "StgCatchFrame"
@@ -484,6 +487,10 @@ wanteds os = concat
 
           ,closureFieldGcptr C "StgInd" "indirectee"
 
+          ,closureFieldGcptr Both "StgCountingInd" "indirectee"
+          ,closureField Both "StgCountingInd" "ent_counter"
+          ,closureField Both "StgCountingInd" "entries"
+
           ,closureSize  C "StgMutVar"
           ,closureField C "StgMutVar" "var"
 
diff --git a/utils/genapply/Main.hs b/utils/genapply/Main.hs
index b8208aeb0d..9f9ad4b4d6 100644
--- a/utils/genapply/Main.hs
+++ b/utils/genapply/Main.hs
@@ -655,6 +655,7 @@ genApply regstatus args =
 --        print "    [THUNK_SELECTOR]  &&thunk_lbl,"
 --        print "    [IND]            &&ind_lbl,"
 --        print "    [IND_STATIC]      &&ind_lbl,"
+--        print "    [COUNTING_IND]       &&ind_lbl,"
 --        print "  };"
 
        tickForArity (length args),
@@ -773,7 +774,8 @@ genApply regstatus args =
 --        print "    ind_lbl:"
 --    else:
         text "case IND,",
-        text "     IND_STATIC: {",
+        text "     IND_STATIC,",
+        text "     COUNTING_IND: {",
         nest 4 (vcat [
           text "R1 = StgInd_indirectee(R1);",
             -- An indirection node might contain a tagged pointer