diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,11 @@
 # Revision history for ghc-debug-client
 
+## 0.6.0.0 -- 2024-04-10
+
+* Properly handle exceptions in parralel traversals
+* Fix snapshotting when extra blocks are requested by RequestBlock
+* Support for profiling RTS
+
 ## 0.5.0.0 -- 2023-06-06
 
 * Remove eventlog2html dependency and hence `profile` function. These can be
diff --git a/ghc-debug-client.cabal b/ghc-debug-client.cabal
--- a/ghc-debug-client.cabal
+++ b/ghc-debug-client.cabal
@@ -1,6 +1,6 @@
 cabal-version:       3.0
 name:                ghc-debug-client
-version:             0.5.0.0
+version:             0.6.0.0
 synopsis:            Useful functions for writing heap analysis tools which use
                      ghc-debug.
 description:         Useful functions for writing heap analysis tools which use
@@ -17,6 +17,7 @@
 
 library
   exposed-modules:     GHC.Debug.Client,
+                       GHC.Debug.CostCentres,
                        GHC.Debug.Retainers,
                        GHC.Debug.GML,
                        GHC.Debug.Fragmentation,
@@ -31,6 +32,7 @@
                        GHC.Debug.TypePointsFrom,
                        GHC.Debug.Snapshot,
                        GHC.Debug.Dominators,
+                       GHC.Debug.Thunks,
                        GHC.Debug.Client.Query,
                        GHC.Debug.Client.Monad,
                        GHC.Debug.Client.BlockCache,
@@ -38,17 +40,17 @@
                        GHC.Debug.Client.Monad.Class,
                        GHC.Debug.Client.Monad.Simple
 
-  build-depends:       base >=4.16 && < 4.19,
+  build-depends:       base >=4.16 && < 4.20,
                        network >= 2.6 ,
                        containers ^>= 0.6,
                        unordered-containers ^>= 0.2.13,
-                       ghc-debug-common == 0.5.0.0,
-                       ghc-debug-convention == 0.5.0.0,
-                       text >= 1.2.4 && < 3,
+                       ghc-debug-common == 0.6.0.0,
+                       ghc-debug-convention == 0.6.0.0,
+                       text >= 2.1 && < 3,
                        process ^>= 1.6,
-                       filepath ^>= 1.4,
+                       filepath >= 1.4 && < 1.6,
                        directory ^>= 1.3,
-                       bitwise ^>= 1.0,
+                       bitwise >= 1.0,
                        hashable >= 1.3 && < 1.5,
                        mtl >= 2.2 && <2.4,
                        binary ^>= 0.8,
@@ -57,10 +59,11 @@
                        async ^>= 2.2,
                        monoidal-containers >= 0.6,
                        language-dot ^>= 0.1,
-                       ghc-prim >= 0.8 && <0.11,
+                       ghc-prim >= 0.8 && <0.12,
                        stm ^>= 2.5,
-                       bytestring,
-                       contra-tracer
+                       vector ^>= 0.13.1 ,
+                       bytestring >= 0.11,
+                       contra-tracer ^>= 0.2.0
 
   hs-source-dirs:      src
   default-language:    Haskell2010
diff --git a/src/GHC/Debug/Client.hs b/src/GHC/Debug/Client.hs
--- a/src/GHC/Debug/Client.hs
+++ b/src/GHC/Debug/Client.hs
@@ -51,14 +51,18 @@
   , dereferenceClosure
   , dereferenceToClosurePtr
   , addConstrDesc
+  , requestCCSMain
   , dereferenceClosures
   , dereferenceStack
   , dereferencePapPayload
   , dereferenceConDesc
   , dereferenceInfoTable
+  , dereferenceIndexTable
   , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCC
 
-  , Quintraversable(..)
+  , Hextraversable(..)
 
   -- * Building a Heap Graph
   , buildHeapGraph
@@ -85,6 +89,9 @@
   , StackPtr
   , ClosurePtr
   , InfoTablePtr
+  , CCPtr
+  , CCSPtr
+  , IndexTablePtr
   , HG.StackHI
   , HG.PapHI
   , HG.HeapGraphIndex
@@ -103,7 +110,7 @@
 derefFuncM :: HG.DerefFunction DebugM Size
 derefFuncM c = do
   c' <- dereferenceClosure c
-  quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure c'
+  hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure c'
 
 -- | Build a heap graph starting from the given root. The first argument
 -- controls how many levels to recurse. You nearly always want to set this
diff --git a/src/GHC/Debug/Client/Monad/Simple.hs b/src/GHC/Debug/Client/Monad/Simple.hs
--- a/src/GHC/Debug/Client/Monad/Simple.hs
+++ b/src/GHC/Debug/Client/Monad/Simple.hs
@@ -123,9 +123,7 @@
 
 initBlockCacheFromReqCache :: RequestCache -> BlockCache
 initBlockCacheFromReqCache new_req_cache  =
-  case lookupReq RequestAllBlocks new_req_cache of
-        Just bs -> addBlocks bs emptyBlockCache
-        Nothing -> emptyBlockCache
+  addBlocks (lookupBlocks new_req_cache) emptyBlockCache
 
 
 
diff --git a/src/GHC/Debug/Client/Query.hs b/src/GHC/Debug/Client/Query.hs
--- a/src/GHC/Debug/Client/Query.hs
+++ b/src/GHC/Debug/Client/Query.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DerivingVia #-}
 module GHC.Debug.Client.Query
   ( -- * Pause/Resume
@@ -18,6 +19,7 @@
   , allBlocks
   , getSourceInfo
   , savedObjects
+  , requestCCSMain
   , version
 
   -- * Dereferencing functions
@@ -32,6 +34,11 @@
   , dereferenceConDesc
   , dereferenceInfoTable
   , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCCSDirect
+  , dereferenceCC
+  , dereferenceIndexTable
+  , dereferenceIndexTableDirect
   ) where
 
 import           Control.Exception
@@ -71,8 +78,10 @@
 lookupInfoTable :: RawClosure -> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure)
 lookupInfoTable rc = do
     let ptr = getInfoTblPtr rc
-    (itbl, rit) <- request (RequestInfoTable ptr)
-    return (itbl,rit, rc)
+    rit <- request (RequestInfoTable ptr)
+    ver <- version
+    let !it = D.decodeInfoTable ver rit
+    return (StgInfoTableWithPtr ptr it,rit, rc)
 
 pauseThen :: Debuggee -> DebugM b -> IO b
 pauseThen e d =
@@ -84,12 +93,12 @@
 
 addConstrDesc :: SizedClosure -> DebugM SizedClosureC
 addConstrDesc c =
-  quintraverse pure pure dereferenceConDesc pure pure c
+  hextraverse pure pure pure dereferenceConDesc pure pure c
 
 -- Derefence other structures so we just have 'ClosurePtr' at leaves.
 dereferenceToClosurePtr :: SizedClosure -> DebugM SizedClosureP
 dereferenceToClosurePtr c = do
-  quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc pure pure c
+  hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc pure pure c
 
 
 -- | Decode a closure corresponding to the given 'ClosurePtr'
@@ -100,14 +109,15 @@
     raw_c <- request (RequestClosure c)
     let it = getInfoTblPtr raw_c
     raw_it <- request (RequestInfoTable it)
-    decodeClosure raw_it (c, raw_c)
+    decodeClosure (it, raw_it) (c, raw_c)
 
-decodeClosure :: (StgInfoTableWithPtr, RawInfoTable)
+decodeClosure :: (InfoTablePtr, RawInfoTable)
               -> (ClosurePtr, RawClosure)
               -> DebugM SizedClosure
-decodeClosure it c = do
+decodeClosure (itp, raw_it) c = do
   ver <- version
-  return $ D.decodeClosure ver it c
+  let !it = D.decodeInfoTable ver raw_it
+  return $ D.decodeClosure ver (StgInfoTableWithPtr itp it, raw_it) c
 
 dereferenceClosures  :: [ClosurePtr] -> DebugM [SizedClosure]
 dereferenceClosures cs = mapM dereferenceClosure cs
@@ -175,7 +185,7 @@
         else do
           let it = getInfoTblPtr rc
           st_it <- request (RequestInfoTable it)
-          decodeClosure st_it (cp, rc)
+          decodeClosure (it, st_it) (cp, rc)
 
 -- | Fetch all the blocks from the debuggee and add them to the block cache
 precacheBlocks :: DebugM [RawBlock]
@@ -198,12 +208,56 @@
 savedObjects :: DebugM [ClosurePtr]
 savedObjects = request RequestSavedObjects
 
+requestCCSMain :: DebugM CCSPtr
+requestCCSMain = request RequestCCSMainPtr
+
 -- | Query the debuggee for the protocol version
 version :: DebugM Version
 version = request RequestVersion
 
 dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable
-dereferenceInfoTable it = decodedTable . fst <$> request (RequestInfoTable it)
+dereferenceInfoTable it = do
+  rit <- request (RequestInfoTable it)
+  ver <- version
+  let !decoded_it = D.decodeInfoTable ver rit
+  pure decoded_it
 
 dereferenceSRT :: InfoTablePtr -> DebugM SrtPayload
 dereferenceSRT it = GenSrtPayload <$> request (RequestSRT it)
+
+dereferenceCCSDirect :: CCSPtr -> DebugM CCSPayload
+dereferenceCCSDirect it = request (RequestCCS it)
+
+dereferenceCCS :: CCSPtr -> DebugM CCSPayload
+dereferenceCCS ccsPtr@(CCSPtr w)
+  | not (heapAlloced $ mkClosurePtr w) = dereferenceCCSDirect ccsPtr
+  | otherwise = do
+      rc <- requestBlock (LookupClosure $ mkClosurePtr w)
+      if rawClosureSize rc < 8
+        then do
+          res <- dereferenceCCSDirect ccsPtr
+          traceShowM ("Warning!!: block decoding failed, report this as a bug:" ++ show (ccsPtr, res))
+          return res
+        else do
+          v <- version
+          pure $ D.decodeCCS v rc
+
+dereferenceCC :: CCPtr -> DebugM CCPayload
+dereferenceCC it = request (RequestCC it)
+
+dereferenceIndexTableDirect :: IndexTablePtr -> DebugM IndexTable
+dereferenceIndexTableDirect it = request (RequestIndexTable it)
+
+dereferenceIndexTable :: IndexTablePtr -> DebugM IndexTable
+dereferenceIndexTable idxTablePtr@(IndexTablePtr w)
+  | not (heapAlloced $ mkClosurePtr w) = dereferenceIndexTableDirect idxTablePtr
+  | otherwise = do
+      rc <- requestBlock (LookupClosure $ mkClosurePtr w)
+      if rawClosureSize rc < 8
+        then do
+          res <- dereferenceIndexTableDirect idxTablePtr
+          traceShowM ("Warning!!: block decoding failed, report this as a bug:" ++ show (idxTablePtr, res))
+          return res
+        else do
+          v <- version
+          pure $ D.decodeIndexTable v rc
diff --git a/src/GHC/Debug/Client/RequestCache.hs b/src/GHC/Debug/Client/RequestCache.hs
--- a/src/GHC/Debug/Client/RequestCache.hs
+++ b/src/GHC/Debug/Client/RequestCache.hs
@@ -4,6 +4,7 @@
 module GHC.Debug.Client.RequestCache(RequestCache
                                     , cacheReq
                                     , lookupReq
+                                    , lookupBlocks
                                     , emptyRequestCache
                                     , clearMovableRequests
                                     , putCache
@@ -33,6 +34,21 @@
     coerceResult :: AnyResp -> resp
     coerceResult (AnyResp a _) = unsafeCoerce a
 
+lookupBlocks :: RequestCache -> [RawBlock]
+lookupBlocks c@(RequestCache rc) =
+  let all_blocks = case lookupReq RequestAllBlocks c of
+                        Just bs -> bs
+                        Nothing -> []
+
+      get_block :: AnyReq -> AnyResp -> [RawBlock] -> [RawBlock]
+      get_block (AnyReq (RequestBlock {})) (AnyResp resp _) bs = unsafeCoerce resp : bs
+      get_block _ _ bs = bs
+
+      individual_blocks = HM.foldrWithKey get_block [] rc
+
+  in (all_blocks ++ individual_blocks)
+
+
 emptyRequestCache :: RequestCache
 emptyRequestCache = RequestCache HM.empty
 
@@ -41,13 +57,12 @@
 -- amount of input.
 
 getResponseBinary :: Request a -> Get a
-getResponseBinary RequestVersion       = Version <$> get <*> get
+getResponseBinary RequestVersion       = Version <$> get <*> get <*> getProfilingMode <*> get
 getResponseBinary (RequestPause {})    = get
 getResponseBinary RequestResume        = get
 getResponseBinary RequestRoots         = get
 getResponseBinary (RequestClosure {}) = get
-getResponseBinary (RequestInfoTable itps) =
-      (\(it, r) -> (StgInfoTableWithPtr itps it, r)) <$> getInfoTable
+getResponseBinary (RequestInfoTable{}) = getInfoTable
 getResponseBinary (RequestSRT {}) = get
 getResponseBinary (RequestStackBitmap {}) = get
 getResponseBinary (RequestFunBitmap {}) = get
@@ -57,14 +72,18 @@
 getResponseBinary (RequestSourceInfo _c) = getIPE
 getResponseBinary RequestAllBlocks = get
 getResponseBinary RequestBlock {}  = get
+getResponseBinary RequestCCS {}  = getCCS
+getResponseBinary RequestCC {}  = getCC
+getResponseBinary RequestIndexTable {}  = getIndexTable
+getResponseBinary RequestCCSMainPtr {}  = getCCSMainPtr
 
 putResponseBinary :: Request a -> a -> Put
-putResponseBinary RequestVersion (Version w1 w2) = put w1 >> put w2
+putResponseBinary RequestVersion (Version w1 w2 vprof tntc) = put w1 >> put w2 >> putProfilingMode vprof >> put tntc
 putResponseBinary (RequestPause {}) w  = put w
 putResponseBinary RequestResume w      = put w
 putResponseBinary RequestRoots  rs     = put rs
 putResponseBinary (RequestClosure {}) rcs = put rcs
-putResponseBinary (RequestInfoTable {}) (_, r) = putInfoTable r
+putResponseBinary (RequestInfoTable {}) r = putInfoTable r
 putResponseBinary (RequestSRT {}) rcs = put rcs
 putResponseBinary (RequestStackBitmap {}) pbm = put pbm
 putResponseBinary (RequestFunBitmap {}) pbm = put pbm
@@ -74,6 +93,10 @@
 putResponseBinary (RequestSourceInfo _c) ipe = putIPE ipe
 putResponseBinary RequestAllBlocks rs = put rs
 putResponseBinary RequestBlock {} r = put r
+putResponseBinary RequestCCS{} r = putCCS r
+putResponseBinary RequestCC{} r = putCC r
+putResponseBinary RequestIndexTable{} r = putIndexTable r
+putResponseBinary RequestCCSMainPtr{} r = putCCSMainPtr r
 
 putConstrDescCache :: ConstrDesc -> Put
 putConstrDescCache (ConstrDesc a b c) = do
diff --git a/src/GHC/Debug/Client/Search.hs b/src/GHC/Debug/Client/Search.hs
--- a/src/GHC/Debug/Client/Search.hs
+++ b/src/GHC/Debug/Client/Search.hs
@@ -16,7 +16,7 @@
     where
       predicate h = checkConstrTable (hgeClosure h)
 
-      checkConstrTable (ConstrClosure _ _ _ (ConstrDesc _ _ n)) = n == con_name
+      checkConstrTable (ConstrClosure _ _ _ _ (ConstrDesc _ _ n)) = n == con_name
       checkConstrTable _ = False
 
 findWithInfoTable :: InfoTablePtr -> HeapGraph a -> [HeapGraphEntry a]
diff --git a/src/GHC/Debug/CostCentres.hs b/src/GHC/Debug/CostCentres.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Debug/CostCentres.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE BangPatterns #-}
+module GHC.Debug.CostCentres
+  ( findAllChildrenOfCC
+  , findExactlyByCC
+  , findAllCCSPayloads
+  , traverseCCSPayloads
+  -- * Helper functions for working with `IndexTable`'s
+  , flattenIndexTable
+  , traverseIndexTable
+  , foldIndexTable
+  -- * Efficient representation of CCSPtr sets
+  , CCSSet(..)
+  , memberCCSSet
+  ) where
+
+import qualified Data.Set as Set
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+
+import GHC.Debug.Client
+import GHC.Debug.Types.Ptr (CCSPtr(..))
+import Data.Coerce (coerce)
+
+newtype CCSSet = CCSSet IntSet
+
+memberCCSSet :: CCSPtr -> CCSSet -> Bool
+memberCCSSet (CCSPtr k) set = IntSet.member (fromIntegral k) (coerce set)
+
+-- | Find all Cost Centre Stacks that reference precisely the cost centre with the given id.
+findExactlyByCC :: (CCPayload -> Bool) -> DebugM (Set.Set CCSPtr)
+findExactlyByCC isRelevantCC = do
+  ccsMain <- requestCCSMain
+  collectNode Set.empty ccsMain
+  where
+    collectNode :: Set.Set CCSPtr -> CCSPtr -> DebugM (Set.Set CCSPtr)
+    collectNode !seen !ccsPtr = do
+      ccsPl <- dereferenceCCS ccsPtr
+      ccPl <- dereferenceCC (ccsCc ccsPl)
+      let newSeen = if isRelevantCC ccPl
+            then ccsPtr `Set.insert` seen
+            else seen
+      foldIndexTable (\_ ptr backEdge !seen' -> do
+        if backEdge
+          then pure seen'
+          else collectNode seen' ptr)
+        newSeen
+        (ccsIndexTable ccsPl)
+
+-- | Find all cost centre stack parts that are transitively children of the cost
+-- centre with the given id.
+findAllChildrenOfCC :: (CCPayload -> Bool) -> DebugM (Set.Set CCSPtr)
+findAllChildrenOfCC isRelevantCC = do
+  ccsMain <- requestCCSMain
+  findCostCentre Set.empty ccsMain
+  where
+    findCostCentre :: Set.Set CCSPtr -> CCSPtr -> DebugM (Set.Set CCSPtr)
+    findCostCentre !seen !ccsPtr = do
+      ccsPl <- dereferenceCCS ccsPtr
+      ccPl <- dereferenceCC (ccsCc ccsPl)
+      if isRelevantCC ccPl
+        then collectNodes seen ccsPtr
+        else
+          foldIndexTable  (\_ ptr backEdge !seen' -> do
+            if backEdge
+              then pure seen'
+              else findCostCentre seen' ptr)
+            seen
+            (ccsIndexTable ccsPl)
+
+    collectNodes :: Set.Set CCSPtr -> CCSPtr -> DebugM (Set.Set CCSPtr)
+    collectNodes !seen !ccsPtr = do
+      ccsPl <- dereferenceCCS ccsPtr
+      foldIndexTable  (\_ ptr backEdge !seen' -> do
+        let seen'' = ptr `Set.insert` seen'
+        if backEdge
+          then pure seen''
+          else collectNodes seen'' ptr)
+        (ccsPtr `Set.insert` seen)
+        (ccsIndexTable ccsPl)
+
+findAllCCSPayloads :: DebugM CCSSet
+findAllCCSPayloads = do
+  ccsMain <- requestCCSMain
+  CCSSet <$> collectNodes IntSet.empty ccsMain
+  where
+    collectNodes :: IntSet.IntSet -> CCSPtr -> DebugM (IntSet.IntSet)
+    collectNodes !seen ccsPtr@(CCSPtr w_) = do
+      ccsPl <- dereferenceCCS ccsPtr
+      foldIndexTable  (\_ ptr@(CCSPtr w) backEdge !seen' -> do
+        let seen'' = fromIntegral w `IntSet.insert` seen'
+        if backEdge
+          then pure seen''
+          else collectNodes seen'' ptr)
+        (fromIntegral w_ `IntSet.insert` seen)
+        (ccsIndexTable ccsPl)
+
+traverseCCSPayloads :: DebugM ()
+traverseCCSPayloads = do
+  ccsMain <- requestCCSMain
+  collectNodes ccsMain
+  where
+    collectNodes :: CCSPtr -> DebugM ()
+    collectNodes ccsPtr = do
+      ccsPl <- dereferenceCCS ccsPtr
+      foldIndexTable  (\_ ptr backEdge () -> do
+        if backEdge
+          then pure ()
+          else collectNodes ptr)
+        ()
+        (ccsIndexTable ccsPl)
+
+traverseIndexTable :: Maybe IndexTablePtr -> (CCPtr -> CCSPtr -> Bool -> DebugM a) -> DebugM [a]
+traverseIndexTable Nothing _ = pure []
+traverseIndexTable (Just ptr) f = do
+  idxTable <- dereferenceIndexTable ptr
+  x <- f (itCostCentre idxTable) (itCostCentreStack idxTable) (itBackEdge idxTable)
+  rest <- traverseIndexTable (itNext idxTable) f
+  pure $ x:rest
+
+foldIndexTable :: (CCPtr -> CCSPtr -> Bool -> a -> DebugM a) -> a -> Maybe IndexTablePtr -> DebugM a
+foldIndexTable _f acc Nothing = pure acc
+foldIndexTable f acc (Just ptr) = do
+  idxTable <- dereferenceIndexTable ptr
+  acc' <- f (itCostCentre idxTable) (itCostCentreStack idxTable) (itBackEdge idxTable) acc
+  foldIndexTable f acc' (itNext idxTable)
+
+-- | Flatten an optional index table pointer into a list of CCS Payloads.
+flattenIndexTable :: Maybe IndexTablePtr -> DebugM [CCSPayload]
+flattenIndexTable root = traverseIndexTable root (\_ ccsPtr _ -> dereferenceCCS ccsPtr)
diff --git a/src/GHC/Debug/Count.hs b/src/GHC/Debug/Count.hs
--- a/src/GHC/Debug/Count.hs
+++ b/src/GHC/Debug/Count.hs
@@ -12,36 +12,29 @@
 parCount :: [ClosurePtr] -> DebugM CensusStats
 parCount = traceParFromM funcs . map (ClosurePtrWithInfo ())
   where
-    nop = const (return ())
-    funcs = TraceFunctionsIO nop nop nop clos (const (const (return mempty))) nop
+    nop = const (return mempty)
+    nop2 = const (return mempty)
+    funcs = TraceFunctionsIO nop nop nop clos (const (const (return mempty))) nop2 nop (const nop2)
 
     clos :: ClosurePtr -> SizedClosure -> ()
               -> DebugM ((), CensusStats, DebugM () -> DebugM ())
-    clos _cp sc _ = do
-      return ((), mkCS (dcSize sc), id)
+    clos cp sc _ = do
+      return ((), mkCS cp (dcSize sc), id)
 
 -- | Simple statistics about a heap, total objects, size and maximum object
 -- size
 count :: [ClosurePtr] -> DebugM CensusStats
-count cps = snd <$> runStateT (traceFromM funcs cps) (CS 0 0 0)
+count cps = snd <$> runStateT (traceFromM funcs cps) mempty
   where
-    funcs = TraceFunctions {
-               papTrace = const (return ())
-              , srtTrace = const (return ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (return ())
-              , conDescTrace = const (return ())
-
-            }
+    funcs = justClosures closAccum
 
     closAccum  :: ClosurePtr
                -> SizedClosure
                ->  (StateT CensusStats DebugM) ()
                ->  (StateT CensusStats DebugM) ()
-    closAccum _cp s k = do
-      modify' (go s)
+    closAccum cp s k = do
+      modify' (go cp s)
       k
 
-    go :: SizedClosure -> CensusStats -> CensusStats
-    go sc cs = mkCS (dcSize sc) <> cs
+    go :: ClosurePtr -> SizedClosure -> CensusStats -> CensusStats
+    go cp sc cs = mkCS cp (dcSize sc) <> cs
diff --git a/src/GHC/Debug/Fragmentation.hs b/src/GHC/Debug/Fragmentation.hs
--- a/src/GHC/Debug/Fragmentation.hs
+++ b/src/GHC/Debug/Fragmentation.hs
@@ -47,7 +47,7 @@
     go cp d =
       let s :: Size
           s = dcSize d
-          v =  mkCS s
+          v =  mkCS cp s
 
           k :: BlockPtr
           k = applyMBlockMask cp
@@ -63,7 +63,7 @@
     go cp d =
       let s :: Size
           s = dcSize d
-          v =  mkCS s
+          v =  mkCS cp s
 
           k = applyBlockMask cp
       in if heapAlloced cp
@@ -86,7 +86,7 @@
           -> DebugM (Maybe (BlockPtr, PinnedCensusStats))
     go cp d =
       let v :: CensusStats
-          v = mkCS (dcSize d)
+          v = mkCS cp (dcSize d)
 
           bp = applyBlockMask cp
 
@@ -102,7 +102,7 @@
 findBadPtrs :: Map.Map k PinnedCensusStats
             -> [((Count, [ClosurePtr]), String)]
 findBadPtrs mb_census  =
-      let fragged_blocks = Map.filter (\(PinnedCensusStats (CS _ (Size s) _, _)) -> fromIntegral s / fromIntegral blockMaxSize <= (0.1 :: Double))  mb_census
+      let fragged_blocks = Map.filter (\(PinnedCensusStats (CS _ (Size s) _ _, _)) -> fromIntegral s / fromIntegral blockMaxSize <= (0.1 :: Double))  mb_census
           all_arr_words :: [(String, (Count, [ClosurePtr]))]
           all_arr_words = concatMap (\(PinnedCensusStats (_, i)) -> map (\(c,d) -> (displayArrWords d, (Count 1, [c]))) i) (Map.elems fragged_blocks)
           swap (a, b) = (b, a)
@@ -125,7 +125,7 @@
 histogram maxSize m =
   mapM_ (putStrLn . displayLine) (bin 0 (map calcPercentage (sortBy (comparing cssize) m )))
   where
-    calcPercentage (CS _ (Size tot) _) =
+    calcPercentage (CS _ (Size tot) _ _) =
       ((fromIntegral tot/ fromIntegral maxSize) * 100 :: Double)
 
     displayLine (l, h, n) = show l ++ "%-" ++ show h ++ "%: " ++ show n
diff --git a/src/GHC/Debug/GML.hs b/src/GHC/Debug/GML.hs
--- a/src/GHC/Debug/GML.hs
+++ b/src/GHC/Debug/GML.hs
@@ -101,7 +101,7 @@
             <> "]\n"
 
         gmlShowCensus :: CensusStats -> String
-        gmlShowCensus (CS (Count c) (Size s) (Max (Size m))) =
+        gmlShowCensus (CS (Count c) (Size s) (Max (Size m)) _) =
           "count " <> show c <> "\n"
           <> "size " <> show s <> "\n"
           <> "max " <> show m <> "\n"
diff --git a/src/GHC/Debug/ObjectEquiv.hs b/src/GHC/Debug/ObjectEquiv.hs
--- a/src/GHC/Debug/ObjectEquiv.hs
+++ b/src/GHC/Debug/ObjectEquiv.hs
@@ -86,21 +86,13 @@
 checkSize :: ObjectEquivState -> Int
 checkSize (ObjectEquivState e1 _ _) = PS.size e1
 
-type PtrClosure = DebugClosureWithSize SrtPayload PapPayload ConstrDesc StackFrames ClosurePtr
+type PtrClosure = DebugClosureWithSize CCSPtr SrtPayload PapPayload ConstrDesc StackFrames ClosurePtr
 
 -- | General function for performing a heap census in constant memory
 censusObjectEquiv :: [ClosurePtr] -> DebugM ObjectEquivState
 censusObjectEquiv cps = snd <$> runStateT (traceFromM funcs cps) (ObjectEquivState PS.empty IM.empty IM.empty)
   where
-    funcs = TraceFunctions {
-               papTrace = const (return ())
-              , srtTrace = const (return ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (return ())
-              , conDescTrace = const (return ())
-
-            }
+    funcs = justClosures closAccum
     -- Add cos
     closAccum  :: ClosurePtr
                -> SizedClosure
@@ -111,10 +103,10 @@
       -- for this cp
       -- Step 1: Decode a bit more of the object, so we can see all the
       -- pointers.
-      s' <- lift $ quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc dereferenceStack pure s
+      s' <- lift $ hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc dereferenceStack pure s
       -- Step 2: Replace all the pointers in the closure by things they are
       -- equivalent to we have already seen.
-      s''  <- quintraverse (traverse rep_c) (traverse rep_c) pure (traverse rep_c) rep_c s'
+      s''  <- hextraverse pure (traverse rep_c) (traverse rep_c) pure (traverse rep_c) rep_c s'
       -- Step 3: Have we seen a closure like this one before?
       modify' (addEquiv cp s'')
 
diff --git a/src/GHC/Debug/ParTrace.hs b/src/GHC/Debug/ParTrace.hs
--- a/src/GHC/Debug/ParTrace.hs
+++ b/src/GHC/Debug/ParTrace.hs
@@ -5,7 +5,9 @@
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+
 -- | Functions to support the constant space traversal of a heap.
 -- This module is like the Trace module but performs the tracing in
 -- parellel. The speed-up is quite modest but hopefully can be improved in
@@ -30,9 +32,12 @@
 import Data.IORef
 import Control.Exception.Base
 import Control.Concurrent.STM
+import Data.Bitraversable
+import Data.Coerce ( coerce )
+import GHC.Conc (numCapabilities)
 
 threads :: Int
-threads = 64
+threads = numCapabilities
 
 type InChan = TChan
 type OutChan = TChan
@@ -43,14 +48,17 @@
 -- * Outer map, segmented by MBlock
 --  * Inner map, blocks for that MBlock
 --    * Inner IOBitArray, visited information for that block
-data ThreadState s = ThreadState (IM.IntMap (IM.IntMap (IOBitArray Word16))) (IORef s)
+data ThreadState s = ThreadState
+  { visitedPtrs :: IM.IntMap (IM.IntMap (IOBitArray Word16))
+  , globalState :: IORef s
+  }
 
 newtype ThreadInfo a = ThreadInfo (InChan (ClosurePtrWithInfo a))
 
 -- | A 'ClosurePtr' with some additional information which needs to be
 -- communicated across to another thread.
 data ClosurePtrWithInfo a = ClosurePtrWithInfo !a !ClosurePtr
-
+                          | CCSPtrWithInfo CCSPtr
 
 -- | Map from Thread -> Information about the thread
 type ThreadMap a = IM.IntMap (ThreadInfo a)
@@ -80,6 +88,12 @@
   case IM.lookup mkey st of
     Nothing -> error $ "Not enough chans:" ++ show mkey ++ show threads
     Just (ThreadInfo ic) -> atomically $ writeTChan ic cpi
+sendToChan ts cpi@(CCSPtrWithInfo ccsPtr) = DebugM $ liftIO $ do
+  let st = visited ts
+      mkey = getMBlockKey (coerce ccsPtr)
+  case IM.lookup mkey st of
+    Nothing -> error $ "Not enough chans:" ++ show mkey ++ show threads
+    Just (ThreadInfo ic) -> atomically $ writeTChan ic cpi
 
 initThread :: Monoid s =>
               Int
@@ -129,13 +143,27 @@
           unsafeLiftIO $ writeIORef r m'
           if b
             then do
-              s <- visitedVal k cp a
+              s <- visitedClosVal k cp a
               unsafeLiftIO $ modifyIORef' ref (s <>)
             else do
               sc <- dereferenceClosure cp
               (a', s, cont) <- closTrace k cp sc a
               unsafeLiftIO $ modifyIORef' ref (s <>)
-              cont (() <$ quintraverse (gosrt r a') (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)
+              cont (() <$ hextraverse (goCCS r) (gosrt r a') (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)
+    deref r (CCSPtrWithInfo cp) = do
+        m <- unsafeLiftIO $ readIORef r
+        do
+          (m', b) <- unsafeLiftIO $ checkVisit (coerce cp) m
+          unsafeLiftIO $ writeIORef r m'
+          if b
+            then do
+              s <- visitedCcsVal k cp
+              unsafeLiftIO $ modifyIORef' ref (s <>)
+            else do
+              ccs' <- dereferenceCCS cp
+              s <- ccsTrace k cp ccs'
+              unsafeLiftIO $ modifyIORef' ref (s <>)
+              () <$ bitraverse (goCCS r) goCC ccs'
 
     goc r c@(ClosurePtrWithInfo _i cp) =
       let mkey = getMBlockKey cp
@@ -148,12 +176,21 @@
     gos r a st = do
       st' <- dereferenceStack st
       stackTrace k st'
-      () <$ traverse (goc r . ClosurePtrWithInfo a) st'
+      () <$ bitraverse (gosrt r a) (goc r . ClosurePtrWithInfo a) st'
 
     gocd d = do
       cd <- dereferenceConDesc d
       conDescTrace k cd
 
+    goCCS r cp =
+        let mkey = getMBlockKey (coerce cp)
+        in if (mkey == n)
+            then deref r (CCSPtrWithInfo cp)
+            else go (CCSPtrWithInfo cp)
+
+    goCC p = do
+      () <$ dereferenceCC p
+
     gop r a p = do
       p' <- dereferencePapPayload p
       papTrace k p'
@@ -193,33 +230,31 @@
       (st', res) <- handleBlockLevel bk offset bm
       return (ThreadState (IM.insert mbk st' v) ref, res)
 
-
-
-
-
 data TraceFunctionsIO a s =
       TraceFunctionsIO { papTrace :: !(GenPapPayload ClosurePtr -> DebugM ())
       , srtTrace :: !(GenSrtPayload ClosurePtr -> DebugM ())
       , stackTrace :: !(GenStackFrames SrtCont ClosurePtr -> DebugM ())
       , closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
-      , visitedVal :: !(ClosurePtr -> a -> DebugM s)
+      , visitedClosVal :: !(ClosurePtr -> a -> DebugM s)
+      , visitedCcsVal :: !(CCSPtr -> DebugM s)
       , conDescTrace :: !(ConstrDesc -> DebugM ())
+      , ccsTrace :: !(CCSPtr -> CCSPayload -> DebugM s)
       }
 
 
 -- | A generic heap traversal function which will use a small amount of
--- memory linear in the heap size. Using this function with appropiate
+-- memory linear in the heap size. Using this function with appropriate
 -- accumulation functions you should be able to traverse quite big heaps in
 -- not a huge amount of memory.
 --
--- The performance of this parralel version depends on how much contention
+-- The performance of this parallel version depends on how much contention
 -- the functions given in 'TraceFunctionsIO' content for the handle
 -- connecting for the debuggee (which is protected by an 'MVar'). With no
 -- contention, and precached blocks, the workload can be very evenly
 -- distributed leading to high core utilisation.
 --
 -- As performance depends highly on contention, snapshot mode is much more
--- amenable to parrelisation where the time taken for requests is much
+-- amenable to parallelisation where the time taken for requests is much
 -- lower.
 traceParFromM :: Monoid s => TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
 traceParFromM k cps = do
@@ -231,8 +266,9 @@
       go  = sendToChan (TraceState ts_map)
   as <- sequence (map ($ go) start )
   mapM_ go cps
-  unsafeLiftIO $ waitFinish work_actives
-  unsafeLiftIO $ mapM_ cancel as
+  wait_finish <- unsafeLiftIO $ async (waitFinish work_actives)
+  unsafeLiftIO $ waitAny $ (() <$ wait_finish) : (map ((<$) ()) as)
+  unsafeLiftIO $ mconcat <$> mapM cancel as
   unsafeLiftIO $ mconcat <$> mapM wait as
 
 waitFinish :: [STM Bool] -> IO ()
@@ -245,12 +281,21 @@
       -- active work and empty chan)
       if b then checkDone xs else retry
 
--- | A parellel tracing function.
+-- | A parallel tracing function.
 tracePar :: [ClosurePtr] -> DebugM ()
 tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ())
   where
     nop = const (return ())
-    funcs = TraceFunctionsIO nop nop stack clos (const (const (return ()))) nop
+    funcs = TraceFunctionsIO
+      { papTrace = nop
+      , srtTrace = nop
+      , stackTrace = stack
+      , closTrace = clos
+      , visitedClosVal = const (const (return ()))
+      , visitedCcsVal = nop
+      , conDescTrace = nop
+      , ccsTrace = const (const (return ()))
+      }
 
     stack :: GenStackFrames SrtCont ClosurePtr -> DebugM ()
     stack fs =
@@ -263,5 +308,3 @@
       let itb = info (noSize sc)
       _traced <- getSourceInfo (tableId itb)
       return ((), (), id)
-
-
diff --git a/src/GHC/Debug/Profile.hs b/src/GHC/Debug/Profile.hs
--- a/src/GHC/Debug/Profile.hs
+++ b/src/GHC/Debug/Profile.hs
@@ -9,6 +9,8 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
+
 {- | Functions for performing whole heap census in the style of the normal
 - heap profiling -}
 module GHC.Debug.Profile( censusClosureType
@@ -17,9 +19,22 @@
                         , CensusByClosureType
                         , writeCensusByClosureType
                         , CensusStats(..)
+                        , ProfileKey(..)
+                        , ProfileKeyArgs(..)
+                        , prettyProfileKey
+                        , prettyShortProfileKey
+                        , prettyProfileKeyArgs
+                        , prettyProfileKeyArgs'
+                        , prettyShortProfileKeyArgs
                         , mkCS
                         , Count(..)
-                        , closureToKey ) where
+                        , closureToKey
+                        , ConstrDescText
+                        , packConstrDesc
+                        , pkgsText
+                        , modlText
+                        , nameText
+                        ) where
 
 import GHC.Debug.Client.Monad
 import GHC.Debug.Client
@@ -28,15 +43,18 @@
 import GHC.Debug.Profile.Types
 
 import qualified Data.Map.Strict as Map
-import Control.Monad.State
+import Control.Monad.State.Strict
 import Data.List (sortBy)
 import Data.Ord
-import Data.Text (pack, Text, unpack)
+import Data.Text (pack, Text)
 import Data.Semigroup
 import qualified Data.Text as T
+import qualified Data.Text.IO as T
 import qualified Data.Map.Monoidal.Strict as MMap
 import Data.Bitraversable
 import Control.Monad
+import qualified Data.Set as Set
+import qualified Data.Vector as V
 
 --import Control.Concurrent
 --import Eventlog.Types
@@ -45,32 +63,95 @@
 --import Eventlog.HtmlTemplate
 --import Eventlog.Args (defaultArgs, Option(..))
 
-
-type CensusByClosureType = Map.Map Text CensusStats
+type CensusByClosureType = Map.Map (ProfileKey, ProfileKeyArgs) CensusStats
 
 -- | Perform a heap census in the same style as the -hT profile.
 censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
 censusClosureType = closureCensusBy go
   where
     go :: ClosurePtr -> SizedClosure
-       -> DebugM (Maybe (Text, CensusStats))
-    go _ s = do
-      d <- quintraverse pure pure dereferenceConDesc pure pure s
+       -> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats))
+    go cp s = do
+      d <- hextraverse pure pure pure dereferenceConDesc pure pure s
       let siz :: Size
           siz = dcSize d
-          v =  mkCS siz
-      return $ Just (closureToKey (noSize d), v)
-
-
+          v =  mkCS cp siz
+      return $ Just ((closureToProfileKey (noSize d), NoArgs), v)
 
-closureToKey :: DebugClosure srt a ConstrDesc c d -> Text
+closureToKey :: DebugClosure ccs srt a ConstrDesc c d -> Text
 closureToKey d =
   case d of
      ConstrClosure { constrDesc = ConstrDesc a b c }
        -> pack a <> ":" <> pack b <> ":" <> pack c
      _ -> pack (show (tipe (decodedTable (info d))))
 
+-- | 'ConstrDescText' wraps a 'ConstrDesc' but is backed by a 'Text'.
+--
+-- More efficient to keep around than 'ConstrDesc'.
+newtype ConstrDescText = ConstrDescText
+  { descText :: Text
+    -- ^ Contains the name, module name and package name. Values are separated by ';'.
+  } deriving (Show, Ord, Eq)
 
+pkgsText :: ConstrDescText -> Text
+pkgsText desc = case T.splitOn ";" (descText desc) of
+  _:_:pkgs:_ -> pkgs
+  _ -> error $ "pkgsText: invariant violation: " <> T.unpack (descText desc)
+
+
+modlText :: ConstrDescText -> Text
+modlText desc = case T.splitOn ";" (descText desc) of
+  _:modl:_:_ -> modl
+  _ -> error $ "modlText: invariant violation: " <> T.unpack (descText desc)
+
+nameText  :: ConstrDescText -> Text
+nameText desc = case T.splitOn ";" (descText desc) of
+  name:_:_:_ -> name
+  _ -> error $ "nameText: invariant violation: " <> T.unpack (descText desc)
+
+packConstrDesc :: ConstrDesc -> ConstrDescText
+packConstrDesc constrDesc = ConstrDescText
+  { descText = T.intercalate ";" [T.pack (name constrDesc), T.pack (modl constrDesc), T.pack (pkg constrDesc)]
+  }
+
+data ProfileKey
+  = ProfileConstrDesc !ConstrDescText
+  | ProfileClosureDesc !Text
+  deriving (Show, Ord, Eq)
+
+-- | Show the full 'ProfileKey', including package and module locations if available.
+prettyProfileKey :: ProfileKey -> Text
+prettyProfileKey (ProfileClosureDesc k) = k
+prettyProfileKey (ProfileConstrDesc desc) = pkgsText desc <> ":" <> modlText desc <> ":" <> nameText desc
+
+-- | Show the 'ProfileKey' in a shortened form if possible.
+-- For example, it omits package and module locations for 'ProfileConstrDesc'.
+prettyShortProfileKey :: ProfileKey -> Text
+prettyShortProfileKey (ProfileClosureDesc k) = k
+prettyShortProfileKey (ProfileConstrDesc desc) = nameText desc
+
+closureToProfileKey :: DebugClosure ccs srt a ConstrDesc c d -> ProfileKey
+closureToProfileKey d =
+  case d of
+     ConstrClosure { constrDesc = constrDesc } -> ProfileConstrDesc $ packConstrDesc constrDesc
+     _ -> ProfileClosureDesc $ pack (show (tipe (decodedTable (info d))))
+data ProfileKeyArgs
+  = ArrKeyArgs !ProfileKey !Int
+  | AllKeyArgs !(V.Vector ProfileKey)
+  | NoArgs
+  deriving (Show, Ord, Eq)
+
+prettyProfileKeyArgs :: ProfileKeyArgs -> Text
+prettyProfileKeyArgs = prettyProfileKeyArgs' prettyProfileKey
+
+prettyShortProfileKeyArgs :: ProfileKeyArgs -> Text
+prettyShortProfileKeyArgs = prettyProfileKeyArgs' prettyShortProfileKey
+
+prettyProfileKeyArgs' :: (ProfileKey -> Text) -> ProfileKeyArgs -> Text
+prettyProfileKeyArgs' prettyKey (ArrKeyArgs typ num) = "[" <> prettyKey typ <> ": " <> T.pack (show num) <> "]"
+prettyProfileKeyArgs' prettyKey (AllKeyArgs args) = "[" <> T.intercalate "," (map prettyKey $ V.toList args) <> "]"
+prettyProfileKeyArgs' _  NoArgs = ""
+
 -- | General function for performing a heap census in constant memory
 closureCensusBy :: forall k v . (Semigroup v, Ord k)
                 => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
@@ -84,9 +165,10 @@
               , srtTrace = const (return ())
               , stackTrace = const (return ())
               , closTrace = closAccum
-              , visitedVal = const (const (return MMap.empty))
+              , visitedClosVal = const (const (return MMap.empty))
+              , visitedCcsVal = const (return MMap.empty)
               , conDescTrace = const (return ())
-
+              , ccsTrace = const (const (return mempty))
             }
     -- Add cos
     closAccum  :: ClosurePtr
@@ -105,36 +187,49 @@
 census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
 census2LevelClosureType cps = snd <$> runStateT (traceFromM funcs cps) Map.empty
   where
-    funcs = TraceFunctions {
-               papTrace = const (return ())
-              , srtTrace = const (return ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (return ())
-              , conDescTrace = const (return ())
-
-            }
+    funcs = justClosures closAccum
     -- Add cos
     closAccum  :: ClosurePtr
                -> SizedClosure
                -> (StateT CensusByClosureType DebugM) ()
                -> (StateT CensusByClosureType DebugM) ()
-    closAccum _ s k = do
-      s' <- lift $ quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure s
+    closAccum cp s k = do
+      s' <- lift $ hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure s
       pts <- lift $ mapM dereferenceClosure (allClosures (noSize s'))
-      pts' <- lift $ mapM (quintraverse pure pure dereferenceConDesc pure pure) pts
+      pts' <- lift $ mapM (hextraverse pure pure pure dereferenceConDesc pure pure) pts
 
 
-      modify' (go s' pts')
+      modify' (go cp s' pts')
       k
 
-    go d args =
-      let k = closureToKey (noSize d)
-          kargs = map (closureToKey . noSize) args
-          final_k :: Text
-          final_k = k <> "[" <> T.intercalate "," kargs <> "]"
-      in Map.insertWith (<>) final_k (mkCS (dcSize d))
+    closureArgsToKeyArgs (ProfileClosureDesc k) kargs =
+      if k `Set.member` mutArrConstants && Set.size (Set.fromList kargs) == 1
+        then ArrKeyArgs (head kargs) (length kargs)
+        else AllKeyArgs $! V.fromList kargs
+    closureArgsToKeyArgs (ProfileConstrDesc _) kargs =
+      AllKeyArgs $ V.fromList kargs
 
+    go cp d args =
+      let !k = closureToProfileKey (noSize d)
+          kargs = map (closureToProfileKey . noSize) args
+          !keyArgs = closureArgsToKeyArgs k kargs
+      in Map.insertWith (<>) (k, keyArgs) (mkCS cp (dcSize d))
+
+    -- We handle these closure types differently as they can list each entry as an arg.
+    -- That leads to huge results, so we try to compress these closure types if and only if
+    -- they describe a constructor homogenous array. Thus, it works well for product types
+    -- but not for sum types.
+    mutArrConstants = Set.fromList $ map (T.pack . show)
+      [ MUT_ARR_PTRS_CLEAN
+      , MUT_ARR_PTRS_DIRTY
+      , MUT_ARR_PTRS_FROZEN_DIRTY
+      , MUT_ARR_PTRS_FROZEN_CLEAN
+      , SMALL_MUT_ARR_PTRS_CLEAN
+      , SMALL_MUT_ARR_PTRS_DIRTY
+      , SMALL_MUT_ARR_PTRS_FROZEN_DIRTY
+      , SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
+      ]
+
 {-
 -- | Parallel heap census
 parCensus :: [RawBlock] -> [ClosurePtr] -> DebugM (Map.Map Text CensusStats)
@@ -148,7 +243,7 @@
     clos :: ClosurePtr -> SizedClosure -> ()
               -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ())
     clos _cp sc () = do
-      d <- quintraverse pure dereferenceConDesc pure pure sc
+      d <- hextraverse pure dereferenceConDesc pure pure sc
       let s :: Size
           s = dcSize sc
           v =  mkCS s
@@ -159,10 +254,18 @@
 writeCensusByClosureType :: FilePath -> CensusByClosureType -> IO ()
 writeCensusByClosureType outpath c = do
   let res = sortBy (flip (comparing (cssize . snd))) (Map.toList c)
-      showLine (k, CS (Count n) (Size s) (Max (Size mn))) =
-        concat [unpack k, ":", show s,":", show n, ":", show mn,":", show @Double (fromIntegral s / fromIntegral n)]
-  writeFile outpath (unlines $ "key, total, count, max, avg" : map showLine res)
-
+  T.writeFile outpath (T.unlines $ "key; total; count; max; avg" : map showLine res)
+  where
+    separator = "; "
+    showKey k args = prettyProfileKey k <> prettyProfileKeyArgs args
+    showLine ((k, kargs), CS (Count n) (Size s) (Max (Size mn)) _) =
+      T.intercalate separator
+        [ showKey k kargs
+        , T.pack (show s)
+        , T.pack (show n)
+        , T.pack (show mn)
+        , T.pack (show @Double (fromIntegral s / fromIntegral n))
+        ]
 
 {-
 -- | Peform a profile at the given interval (in seconds), the result will
diff --git a/src/GHC/Debug/Profile/Types.hs b/src/GHC/Debug/Profile/Types.hs
--- a/src/GHC/Debug/Profile/Types.hs
+++ b/src/GHC/Debug/Profile/Types.hs
@@ -5,17 +5,33 @@
 import Data.Monoid
 import Data.Semigroup
 
-newtype Count = Count Int
+newtype Count = Count {getCount :: Int }
                 deriving (Semigroup, Monoid, Num) via Sum Int
                 deriving (Show, Ord, Eq)
 
-data CensusStats = CS { cscount :: !Count, cssize :: !Size, csmax :: !(Max Size) } deriving (Show, Eq)
+newtype Sample = Sample { getSamples :: [ClosurePtr] } deriving (Show, Eq)
 
-mkCS :: Size -> CensusStats
-mkCS i = CS (Count 1) i (Max i)
+instance Monoid Sample where
+  mempty = Sample []
 
+instance Semigroup Sample where
+  (Sample a) <> (Sample b) =
+    case (take 5 (a ++ b)) of
+      xs@(_:_:_:_:_:_) -> Sample xs
+      xs -> Sample xs
+
+
+
+data CensusStats = CS { cscount :: !Count
+                        , cssize :: !Size
+                        , csmax :: !(Max Size)
+                        , sample :: !Sample } deriving (Show, Eq)
+
+mkCS :: ClosurePtr -> Size -> CensusStats
+mkCS cp i = CS (Count 1) i (Max i) (Sample [cp])
+
 instance Monoid CensusStats where
-  mempty = CS mempty mempty (Max (Size 0))
+  mempty = CS mempty mempty (Max (Size 0)) mempty
 
 instance Semigroup CensusStats where
-  (CS a b c) <> (CS a1 b1 c1) = CS (a <> a1) (b <> b1) (c <> c1)
+  (CS a b c d) <> (CS a1 b1 c1 d1) = CS (a <> a1) (b <> b1) (c <> c1) (d <> d1)
diff --git a/src/GHC/Debug/Retainers.hs b/src/GHC/Debug/Retainers.hs
--- a/src/GHC/Debug/Retainers.hs
+++ b/src/GHC/Debug/Retainers.hs
@@ -1,7 +1,24 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
 -- | Functions for computing retainers
-module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainersOfInfoTable, findRetainers, addLocationToStack, displayRetainerStack, addLocationToStack', displayRetainerStack') where
+module GHC.Debug.Retainers
+  ( findRetainers
+  , findRetainersOf
+  , findRetainersOfConstructor
+  , findRetainersOfConstructorExact
+  , findRetainersOfInfoTable
+  , addLocationToStack
+  , displayRetainerStack
+  , addLocationToStack'
+  , displayRetainerStack'
+  , findRetainersOfArrWords
+  , EraRange(..)
+  , profHeaderInEraRange
+  , ClosureFilter(..)
+  , profHeaderReferencesCCS
+  , findRetainersOfEra) where
 
+import Prelude hiding (filter)
 import GHC.Debug.Client
 import Control.Monad.State
 import GHC.Debug.Trace
@@ -10,64 +27,131 @@
 
 import qualified Data.Set as Set
 import Control.Monad.RWS
+import Data.Word
 
-addOne :: [ClosurePtr] -> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
+addOne :: a -> (Maybe Int, [a]) -> (Maybe Int, [a])
 addOne _ (Just 0, cp) = (Just 0, cp)
-addOne cp (n, cps)    = (subtract 1 <$> n, cp:cps)
+addOne cp (n, cps)    = (subtract 1 <$> n, cp : cps)
 
+data EraRange
+  = EraRange { startEra :: Word64, endEra :: Word64} -- inclusive
+  deriving (Eq, Ord, Show)
+
+inEraRange :: Word64 -> Maybe EraRange -> Bool
+inEraRange _ Nothing = True
+inEraRange n (Just (EraRange s e)) = s <= n && n <= e
+
+profHeaderReferencesCCS :: Maybe ProfHeaderWithPtr -> Set.Set CCSPtr -> Bool
+profHeaderReferencesCCS Nothing _ = False
+profHeaderReferencesCCS (Just profHeader) f = ccs profHeader `Set.member` f
+
+profHeaderInEraRange :: Maybe (ProfHeader a) -> Maybe EraRange -> Bool
+profHeaderInEraRange Nothing _ = True
+profHeaderInEraRange (Just ph) eras
+  = case hp ph of
+      EraWord w -> w `inEraRange` eras
+      _ -> True -- Don't filter if no era profiling
+
+data ClosureFilter
+ = ConstructorDescFilter (ConstrDesc -> Bool)
+ | InfoFilter (StgInfoTable -> Bool)
+ | InfoPtrFilter (InfoTablePtr -> Bool)
+ | InfoSourceFilter (SourceInformation -> Bool)
+ | SizeFilter (Size -> Bool)
+ | ProfHeaderFilter (Maybe ProfHeaderWithPtr -> Bool)
+ | AddressFilter (ClosurePtr -> Bool)
+ | AndFilter ClosureFilter ClosureFilter
+ | OrFilter ClosureFilter ClosureFilter
+ | NotFilter ClosureFilter
+ | PureFilter Bool
+
+matchesFilter :: ClosureFilter -> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
+matchesFilter filter ptr sc parents = case filter of
+  ConstructorDescFilter p -> case noSize sc of
+    ConstrClosure _ _ _ _ cd -> do
+      cd' <- dereferenceConDesc cd
+      return $ p cd'
+    _ -> pure False
+  InfoFilter p -> pure $ p (decodedTable (info (noSize sc)))
+  InfoPtrFilter p -> pure $ p (tableId (info (noSize sc)))
+  InfoSourceFilter p -> do
+    loc <- getSourceInfo (tableId (info (noSize sc)))
+    case loc of
+      Nothing -> return False
+      Just cur_loc -> pure $ p cur_loc
+  SizeFilter p -> pure $ p (dcSize sc)
+  ProfHeaderFilter p -> pure $ p (profHeader $ noSize sc)
+  AddressFilter p -> pure $ p ptr
+  AndFilter f1 f2 -> do
+    r1 <- matchesFilter f1 ptr sc parents
+    case r1 of
+      False -> pure False
+      True -> matchesFilter f2 ptr sc parents
+  OrFilter f1 f2 -> do
+    r1 <- matchesFilter f1 ptr sc parents
+    case r1 of
+      True -> pure True
+      False -> matchesFilter f2 ptr sc parents
+  NotFilter f1  -> do
+    r1 <- matchesFilter f1 ptr sc parents
+    pure (not r1)
+  PureFilter b -> pure b
+
 findRetainersOf :: Maybe Int
                 -> [ClosurePtr]
                 -> [ClosurePtr]
                 -> DebugM [[ClosurePtr]]
-findRetainersOf limit cps bads = findRetainers limit cps (\cp _ -> return (cp `Set.member` bad_set))
+findRetainersOf limit cps bads =
+  findRetainers limit (AddressFilter (`Set.member` bad_set)) cps
   where
     bad_set = Set.fromList bads
 
-findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
+findRetainersOfConstructor :: Maybe Int
+                           -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
 findRetainersOfConstructor limit rroots con_name =
-  findRetainers limit rroots go
-  where
-    go _ sc =
-      case noSize sc of
-        ConstrClosure _ _ _ cd -> do
-          ConstrDesc _ _  cname <- dereferenceConDesc cd
-          return $ cname == con_name
-        _ -> return $ False
+  findRetainers limit (ConstructorDescFilter ((== con_name) . name)) rroots
 
-findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
+findRetainersOfConstructorExact
+  :: Maybe Int
+  -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
 findRetainersOfConstructorExact limit rroots clos_name =
-  findRetainers limit rroots go
+  findRetainers limit (InfoSourceFilter ((== clos_name) . infoName)) rroots
+
+findRetainersOfEra
+  :: Maybe Int
+  -> EraRange
+  -> [ClosurePtr] -> DebugM [[ClosurePtr]]
+findRetainersOfEra limit eras rroots =
+  findRetainers limit filter rroots
   where
-    go _ sc = do
-      loc <- getSourceInfo (tableId (info (noSize sc)))
-      case loc of
-        Nothing -> return False
-        Just cur_loc ->
+    filter = ProfHeaderFilter (`profHeaderInEraRange` (Just eras))
 
-          return $ (infoName cur_loc) == clos_name
+findRetainersOfArrWords
+  :: Maybe Int
+  -> [ClosurePtr] -> Size -> DebugM [[ClosurePtr]]
+findRetainersOfArrWords limit rroots lim =
+  findRetainers limit filter rroots
+  where
+    -- TODO : this is the size of the entire closure, not the size of the ArrWords
+    filter = AndFilter (InfoFilter ((== ARR_WORDS) . tipe))
+                       (SizeFilter (>= lim))
 
-findRetainersOfInfoTable :: Maybe Int -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]]
+findRetainersOfInfoTable
+  :: Maybe Int
+  -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]]
 findRetainersOfInfoTable limit rroots info_ptr =
-  findRetainers limit rroots go
-  where
-    go _ sc = return $ tableId (info (noSize sc)) == info_ptr
+  findRetainers limit (InfoPtrFilter (== info_ptr)) rroots
 
 -- | From the given roots, find any path to one of the given pointers.
 -- Note: This function can be quite slow! The first argument is a limit to
 -- how many paths to find. You should normally set this to a small number
 -- such as 10.
-findRetainers :: Maybe Int -> [ClosurePtr] -> (ClosurePtr -> SizedClosure -> DebugM Bool) -> DebugM [[ClosurePtr]]
-findRetainers limit rroots p = (\(_, r, _) -> snd r) <$> runRWST (traceFromM funcs rroots) [] (limit, [])
+findRetainers :: Maybe Int
+  -> ClosureFilter
+  -> [ClosurePtr] -> DebugM [[ClosurePtr]]
+findRetainers limit filter rroots = (\(_, r, _) -> snd r) <$> runRWST (traceFromM funcs rroots) [] (limit, [])
   where
-    funcs = TraceFunctions {
-               papTrace = const (return ())
-              , srtTrace = const (return ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (return ())
-              , conDescTrace = const (return ())
-
-            }
+    funcs = justClosures closAccum
     -- Add clos
     closAccum  :: ClosurePtr
                -> SizedClosure
@@ -75,19 +159,17 @@
                -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
     closAccum _ (noSize -> WeakClosure {}) _ = return ()
     closAccum cp sc k = do
-      b <- lift $ p cp sc
+      ctx <- ask
+      b <- lift $ matchesFilter filter cp sc ctx
       if b
-        then do
-          ctx <- ask
-          modify' (addOne (cp: ctx))
-          local (cp:) k
-          -- Don't call k, there might be more paths to the pointer but we
-          -- probably just care about this first one.
-        else do
-          (lim, _) <- get
-          case lim of
-            Just 0 -> return ()
-            _ -> local (cp:) k
+      then do
+        modify' (addOne (cp: ctx))
+        local (cp:) k
+      else do
+        (lim, _) <- get
+        case lim of
+          Just 0 -> return ()
+          _ -> local (cp:) k
 
 addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureP, Maybe SourceInformation)]
 addLocationToStack r = do
diff --git a/src/GHC/Debug/Snapshot.hs b/src/GHC/Debug/Snapshot.hs
--- a/src/GHC/Debug/Snapshot.hs
+++ b/src/GHC/Debug/Snapshot.hs
@@ -13,14 +13,18 @@
 import GHC.Debug.Client
 import Control.Monad.Identity
 import Control.Monad.Trans
+import GHC.Debug.CostCentres (findAllChildrenOfCC)
+import Control.Monad
+import GHC.Debug.Types.Version
 
 -- | Make a snapshot of the current heap and save it to the given file.
 snapshot :: FilePath -> DebugM ()
 snapshot fp = do
   precacheBlocks
-  version
+  ver <- version
   rs <- gcRoots
   _so <- savedObjects
+  when (isProfiledRTS ver) (() <$ findAllChildrenOfCC (const False))
   tracePar rs
   saveCache fp
 
@@ -29,8 +33,7 @@
 traceFrom :: [ClosurePtr] -> DebugM ()
 traceFrom cps = runIdentityT (traceFromM funcs cps)
   where
-    nop = const (return ())
-    funcs = TraceFunctions nop nop nop clos (const (return ())) nop
+    funcs = justClosures clos
 
     clos :: ClosurePtr -> SizedClosure -> (IdentityT DebugM) ()
               ->  (IdentityT DebugM) ()
diff --git a/src/GHC/Debug/Strings.hs b/src/GHC/Debug/Strings.hs
--- a/src/GHC/Debug/Strings.hs
+++ b/src/GHC/Debug/Strings.hs
@@ -7,7 +7,7 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 module GHC.Debug.Strings ( stringProgram, arrWordsProgram
-                         , arrWordsAnalysis, stringAnalysis) where
+                         , arrWordsAnalysis, stringAnalysis, decodeString) where
 
 import GHC.Debug.Client
 import GHC.Debug.Types.Ptr
@@ -61,15 +61,7 @@
 stringAnalysis :: [ClosurePtr] -> DebugM (Map.Map String (S.Set ClosurePtr))
 stringAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) False (Map.empty)
   where
-    funcs = TraceFunctions {
-               papTrace = const (return ())
-              , srtTrace = const (return ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (return ())
-              , conDescTrace = const (return ())
-
-            }
+    funcs = justClosures closAccum
 
     -- First time we have visited a closure
     closAccum  :: ClosurePtr
@@ -78,7 +70,7 @@
                -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()
     closAccum cp sc k = do
       case noSize sc of
-        ConstrClosure _ _ _ cd -> do
+        ConstrClosure _ _ _ _ cd -> do
           cd' <- lift $ dereferenceConDesc cd
           case cd' of
             ConstrDesc _ _ cd2 | cd2 == ":" -> do
@@ -89,7 +81,7 @@
         process :: ClosurePtr -> SizedClosure
                 -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()
         process p_cp clos = do
-          clos' <- lift $ quintraverse pure pure dereferenceConDesc return return (noSize clos)
+          clos' <- lift $ hextraverse pure pure pure dereferenceConDesc return return (noSize clos)
           checked <- lift $ check_bin clos'
           if checked
             then do
@@ -105,25 +97,36 @@
         process_2 p_cp = do
           cp' <- dereferenceClosure p_cp
           case noSize cp' of
-            (ConstrClosure _ _ _ cd) -> do
+            (ConstrClosure _ _ _ _ cd) -> do
               (ConstrDesc _ _ cn) <- dereferenceConDesc cd
               return (cn == "C#")
+            (IndClosure _ _ i) ->
+              process_2 i
             _ -> return False
 
-        check_bin (ConstrClosure _ [h,_] _ (ConstrDesc _ _ ":")) = process_2 h
+        check_bin (ConstrClosure _ _ [h,_] _ (ConstrDesc _ _ ":")) = process_2 h
+        check_bin (IndClosure _ _ i) = do
+          sizedI <- dereferenceClosure i
+          clos' <- hextraverse pure pure pure dereferenceConDesc return return (noSize sizedI)
+          check_bin clos'
         check_bin _ = return False
 
 decodeString :: ClosurePtr -> DebugM String
 decodeString cp = do
   cp' <- dereferenceClosure cp
   case noSize cp' of
-    (ConstrClosure _ [p,ps] _ _) -> do
-      cp'' <- dereferenceClosure p
-      case noSize cp'' of
-        (ConstrClosure _ _ [w] _) -> do
-          (chr (fromIntegral w):) <$> decodeString ps
-        _ -> return []
+    (IndClosure _ _ i) -> decodeString i
+    (ConstrClosure _ _ [p,ps] _ _) -> do
+      go p ps
     _ -> return []
+    where
+  go headp tailp = do
+    cp'' <- dereferenceClosure headp
+    case noSize cp'' of
+      (IndClosure _ _ i) -> go i tailp
+      (ConstrClosure _ _ _ [w] _) -> do
+        (chr (fromIntegral w):) <$> decodeString tailp
+      _ -> return []
 
 
 printResult :: Show a => Map.Map a Count -> IO [a]
@@ -140,15 +143,7 @@
 arrWordsAnalysis :: [ClosurePtr] -> DebugM (Map.Map ByteString (S.Set ClosurePtr))
 arrWordsAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) () (Map.empty)
   where
-    funcs = TraceFunctions {
-               papTrace = const (return ())
-              , srtTrace = const (return ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (return ())
-              , conDescTrace = const (return ())
-
-            }
+    funcs = justClosures closAccum
 
     -- First time we have visited a closure
     closAccum  :: ClosurePtr
@@ -157,7 +152,7 @@
                -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()
     closAccum cp sc k = do
           case (noSize sc) of
-            ArrWordsClosure _ _ p ->  do
+            ArrWordsClosure _ _ _ p ->  do
               modify' (Map.insertWith (<>) (arrWordsBS p) (S.singleton cp))
               k
             _ -> k
diff --git a/src/GHC/Debug/Thunks.hs b/src/GHC/Debug/Thunks.hs
new file mode 100644
--- /dev/null
+++ b/src/GHC/Debug/Thunks.hs
@@ -0,0 +1,29 @@
+module GHC.Debug.Thunks where
+
+import GHC.Debug.Types
+import GHC.Debug.Client.Monad
+import GHC.Debug.Profile.Types
+import qualified Data.Map.Strict as Map
+import Control.Monad.RWS
+import GHC.Debug.Trace
+import GHC.Debug.Client.Query
+
+
+thunkAnalysis :: [ClosurePtr] -> DebugM (Map.Map (Maybe SourceInformation) Count)
+thunkAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) () (Map.empty)
+  where
+    funcs = justClosures closAccum
+
+    getSourceLoc c = getSourceInfo (tableId (info (noSize c)))
+
+    closAccum  :: ClosurePtr
+               -> SizedClosure
+               -> (RWST () () (Map.Map (Maybe SourceInformation) Count) DebugM) ()
+               -> (RWST () () (Map.Map (Maybe SourceInformation) Count) DebugM) ()
+    closAccum _ sc k = do
+          case (noSize sc) of
+            ThunkClosure {} ->  do
+              loc <- lift $ getSourceLoc sc
+              modify' (Map.insertWith (<>) loc (Count 1))
+              k
+            _ -> k
diff --git a/src/GHC/Debug/Trace.hs b/src/GHC/Debug/Trace.hs
--- a/src/GHC/Debug/Trace.hs
+++ b/src/GHC/Debug/Trace.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
 -- | Functions to support the constant space traversal of a heap.
 module GHC.Debug.Trace ( traceFromM, TraceFunctions(..), justClosures ) where
 
@@ -14,6 +15,8 @@
 import Control.Monad
 import Data.IORef
 import Data.Word
+import Data.Bitraversable
+import Data.Coerce
 
 newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16))
 
@@ -53,16 +56,14 @@
       , closTrace :: !(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
       , visitedVal :: !(ClosurePtr -> (m DebugM) ())
       , conDescTrace :: !(ConstrDesc -> m DebugM ())
+      , ccsTrace :: !(CCSPtr -> CCSPayload -> m DebugM ())
       }
 
 justClosures :: C m => (ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()) -> TraceFunctions m
-justClosures f = TraceFunctions nop nop nop f nop nop
+justClosures f = TraceFunctions nop nop nop f nop nop (const nop)
   where
     nop = const (return ())
 
-
-
-
 type C m = (MonadTrans m, Monad (m DebugM))
 
 -- | A generic heap traversal function which will use a small amount of
@@ -92,7 +93,7 @@
         else do
         sc <- lift $ lift $ dereferenceClosure cp
         ReaderT $ \st -> closTrace k cp sc
-         (runReaderT (() <$ quintraverse gosrt gop gocd gos go sc) st)
+         (runReaderT (() <$ hextraverse goccs gosrt gop gocd gos go sc) st)
 
 
     gos st = do
@@ -113,3 +114,16 @@
       p' <- lift $ lift $ dereferenceSRT p
       lift $ srtTrace k p'
       () <$ traverse go p'
+
+    goccs p = do
+      mref <- ask
+      (mnum_visited, b) <- lift $ lift $ unsafeLiftIO (checkVisit (coerce p) mref)
+      if b
+        then return ()
+        else do
+          p' <- lift $ lift $ dereferenceCCS p
+          lift $ ccsTrace k p p'
+          () <$ bitraverse goccs pure p'
+
+
+
diff --git a/src/GHC/Debug/TypePointsFrom.hs b/src/GHC/Debug/TypePointsFrom.hs
--- a/src/GHC/Debug/TypePointsFrom.hs
+++ b/src/GHC/Debug/TypePointsFrom.hs
@@ -75,14 +75,15 @@
 typePointsFrom cs = traceParFromM funcs (map (ClosurePtrWithInfo Root) cs)
 
   where
-    nop = const (return ())
-    funcs = TraceFunctionsIO nop nop nop clos visit nop
+    nop = const (return mempty)
+    nop2 = const (return mempty)
+    funcs = TraceFunctionsIO nop nop nop clos visit nop2 nop (const nop2)
 
     visit :: ClosurePtr -> Context -> DebugM TypePointsFrom
     visit cp ctx = do
       sc <- dereferenceClosure cp
       let k = tableId $ info (noSize sc)
-          v = mkCS (dcSize sc)
+          v = mkCS cp (dcSize sc)
           parent_edge = case ctx of
                           Root -> []
                           Parent pk -> [(Edge k pk, v)]
@@ -92,11 +93,11 @@
 
     clos :: ClosurePtr -> SizedClosure -> Context
               -> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())
-    clos _cp sc ctx = do
+    clos cp sc ctx = do
       let k = tableId $ info (noSize sc)
       let s :: Size
           s = dcSize sc
-          v =  mkCS s
+          v =  mkCS cp s
 
           -- Edges point from the object TO what retains it
           parent_edge = case ctx of