Compare revisions

Zubin · Zubin · Zubin · Zubin · Matthew Pickering · Zubin
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -7,9 +7,12 @@ workflow:
 ci:
  parallel:
      matrix:
-        - VERSION: "9.6.2"
-        - VERSION: "9.4.5"
-        - VERSION: "9.2.8"
+        - VERSION: "9.12.2"
+        - VERSION: "9.12.1"
+        - VERSION: "9.10.2"
+        - VERSION: "9.10.1"
+        - VERSION: "9.8.4"
+        - VERSION: "9.6.7"
  tags:
    - x86_64-linux
  script:

--- a/cabal.project
+++ b/cabal.project
-packages: common, stub, client, test, dyepack-test, ghc-debug-brick, convention
+packages: common, stub, client, test, ghc-debug-brick, convention

 -- If you see a Cmm lexical error, then comment out this line
 -- debug-info: 3

--- a/client/CHANGELOG.md
+++ b/client/CHANGELOG.md
 # Revision history for ghc-debug-client

+## 0.7.0.0 -- 2025-05-20
+
+* Relax version bounds
+
+## 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

--- a/client/ghc-debug-client.cabal
+++ b/client/ghc-debug-client.cabal
 cabal-version:       3.0
 name:                ghc-debug-client
-version:             0.5.0.0
+version:             0.7.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 @@ extra-source-files:  CHANGELOG.md

 library
  exposed-modules:     GHC.Debug.Client,
+                       GHC.Debug.CostCentres,
                       GHC.Debug.Retainers,
                       GHC.Debug.GML,
                       GHC.Debug.Fragmentation,
@@ -31,6 +32,7 @@ library
                       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,18 +40,18 @@ library
                       GHC.Debug.Client.Monad.Class,
                       GHC.Debug.Client.Monad.Simple

-  build-depends:       base >=4.16 && < 4.19,
+  build-depends:       base >=4.16 && < 4.22,
                       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.7.0.0,
+                       ghc-debug-convention == 0.7.0.0,
+                       text >= 2.1 && < 3,
                       process ^>= 1.6,
-                       filepath ^>= 1.4,
+                       filepath >= 1.4 && < 1.6,
                       directory ^>= 1.3,
-                       bitwise ^>= 1.0,
-                       hashable >= 1.3 && < 1.5,
+                       bitwise >= 1.0,
+                       hashable >= 1.3 && < 1.6,
                       mtl >= 2.2 && <2.4,
                       binary ^>= 0.8,
                       psqueues ^>= 0.2,
@@ -57,10 +59,11 @@ library
                       async ^>= 2.2,
                       monoidal-containers >= 0.6,
                       language-dot ^>= 0.1,
-                       ghc-prim >= 0.8 && <0.11,
+                       ghc-prim >= 0.8 && <0.14,
                       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

--- a/client/src/GHC/Debug/Client.hs
+++ b/client/src/GHC/Debug/Client.hs
@@ -51,14 +51,18 @@ module GHC.Debug.Client
  , dereferenceClosure
  , dereferenceToClosurePtr
  , addConstrDesc
+  , requestCCSMain
  , dereferenceClosures
  , dereferenceStack
  , dereferencePapPayload
  , dereferenceConDesc
  , dereferenceInfoTable
+  , dereferenceIndexTable
  , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCC

-  , Quintraversable(..)
+  , Hextraversable(..)

  -- * Building a Heap Graph
  , buildHeapGraph
@@ -85,6 +89,9 @@ module GHC.Debug.Client
  , StackPtr
  , ClosurePtr
  , InfoTablePtr
+  , CCPtr
+  , CCSPtr
+  , IndexTablePtr
  , HG.StackHI
  , HG.PapHI
  , HG.HeapGraphIndex
@@ -103,7 +110,7 @@ import Control.Monad
 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

--- a/client/src/GHC/Debug/Client/Monad/Simple.hs
+++ b/client/src/GHC/Debug/Client/Monad/Simple.hs
@@ -123,9 +123,7 @@ instance DebugMonad DebugM where

 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




--- a/client/src/GHC/Debug/Client/Query.hs
+++ b/client/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 @@ module GHC.Debug.Client.Query
  , allBlocks
  , getSourceInfo
  , savedObjects
+  , requestCCSMain
  , version

  -- * Dereferencing functions
@@ -32,6 +34,11 @@ module GHC.Debug.Client.Query
  , dereferenceConDesc
  , dereferenceInfoTable
  , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCCSDirect
+  , dereferenceCC
+  , dereferenceIndexTable
+  , dereferenceIndexTableDirect
  ) where

 import           Control.Exception
@@ -71,8 +78,10 @@ withPause dbg act = bracket_ (pause dbg) (resume dbg) act
 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 @@ dereferenceClosureC cp = addConstrDesc =<< dereferenceClosure cp

 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 @@ dereferenceClosureDirect c = do
    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 @@ dereferenceClosure cp
        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 @@ getSourceInfo = request . RequestSourceInfo
 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
--- a/client/src/GHC/Debug/Client/RequestCache.hs
+++ b/client/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 @@ lookupReq req (RequestCache rc) = coerceResult <$> HM.lookup (AnyReq req) rc
    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 @@ emptyRequestCache = RequestCache HM.empty
 -- 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 RequestSavedObjects  = get
 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 RequestSavedObjects os = putList os
 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

--- a/client/src/GHC/Debug/Client/Search.hs
+++ b/client/src/GHC/Debug/Client/Search.hs
@@ -16,7 +16,7 @@ findConstructors con_name hg = findClosures predicate hg
    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]

--- a/client/src/GHC/Debug/CostCentres.hs
+++ b/client/src/GHC/Debug/CostCentres.hs
+{-# 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)
--- a/client/src/GHC/Debug/Count.hs
+++ b/client/src/GHC/Debug/Count.hs
@@ -12,36 +12,29 @@ import Control.Monad.State
 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
--- a/client/src/GHC/Debug/Fragmentation.hs
+++ b/client/src/GHC/Debug/Fragmentation.hs
@@ -47,7 +47,7 @@ censusByMBlock = closureCensusBy go
    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 @@ censusByBlock = closureCensusBy go
    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 @@ censusPinnedBlocks bs = closureCensusBy go
          -> 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 @@ censusPinnedBlocks bs = closureCensusBy go
 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 :: Word64 -> [CensusStats] -> IO ()
 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

--- a/client/src/GHC/Debug/GML.hs
+++ b/client/src/GHC/Debug/GML.hs
@@ -101,7 +101,7 @@ writeTpfToGML path tpf infoMap = do
            <> "]\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"

--- a/client/src/GHC/Debug/ObjectEquiv.hs
+++ b/client/src/GHC/Debug/ObjectEquiv.hs
@@ -86,21 +86,13 @@ trimMap o = if checkSize o > limit
 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 @@ censusObjectEquiv cps = snd <$> runStateT (traceFromM funcs cps) (ObjectEquivSta
      -- 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'')


--- a/client/src/GHC/Debug/ParTrace.hs
+++ b/client/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 Control.Concurrent.Async
 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 @@ type OutChan = TChan
 -- * 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 @@ sendToChan  ts cpi@(ClosurePtrWithInfo _ cp) = DebugM $ liftIO $ do
  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 @@ workerThread n k worker_active ref go oc = DebugM $ do
          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 @@ workerThread n k worker_active ref go oc = DebugM $ do
    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 @@ checkVisit cp st = do
      (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 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 @@ traceParFromM k cps = do
      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 @@ waitFinish working = atomically (checkDone working)
      -- 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 @@ tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ())
      let itb = info (noSize sc)
      _traced <- getSourceInfo (tableId itb)
      return ((), (), id)
-
-
--- a/client/src/GHC/Debug/Profile.hs
+++ b/client/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 @@ module GHC.Debug.Profile( censusClosureType
                        , 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.ParTrace
 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,31 +63,94 @@ import Control.Monad
 --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)
@@ -84,9 +165,10 @@ closureCensusBy f cps = do
              , 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,35 +187,48 @@ closureCensusBy f cps = do
 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
@@ -148,7 +243,7 @@ parCensus bs cs =  do
    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 @@ parCensus bs cs =  do
 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

--- a/client/src/GHC/Debug/Profile/Types.hs
+++ b/client/src/GHC/Debug/Profile/Types.hs
@@ -5,17 +5,33 @@ import           GHC.Debug.Types
 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)
--- a/client/src/GHC/Debug/Retainers.hs
+++ b/client/src/GHC/Debug/Retainers.hs
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
 -- | Functions for computing retainers
-module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainersOfInfoTable, findRetainers, addLocationToStack, displayRetainerStack, addLocationToStack', displayRetainerStack', findRetainersOfArrWords) 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
@@ -11,73 +27,131 @@ import Control.Monad

 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
-
-findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
+  findRetainers limit (ConstructorDescFilter ((== con_name) . name)) rroots
+
+findRetainersOfConstructorExact
+  :: Maybe Int
+  -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
 findRetainersOfConstructorExact limit rroots clos_name =
-  findRetainers limit rroots go
-  where
-    go _ sc = do
-      loc <- getSourceInfo (tableId (info (noSize sc)))
-      case loc of
-        Nothing -> return False
-        Just cur_loc ->
+  findRetainers limit (InfoSourceFilter ((== clos_name) . infoName)) rroots

-          return $ (infoName cur_loc) == clos_name
+findRetainersOfEra
+  :: Maybe Int
+  -> EraRange
+  -> [ClosurePtr] -> DebugM [[ClosurePtr]]
+findRetainersOfEra limit eras rroots =
+  findRetainers limit filter rroots
+  where
+    filter = ProfHeaderFilter (`profHeaderInEraRange` (Just eras))

-findRetainersOfArrWords :: Maybe Int -> [ClosurePtr] -> Word -> DebugM [[ClosurePtr]]
+findRetainersOfArrWords
+  :: Maybe Int
+  -> [ClosurePtr] -> Size -> DebugM [[ClosurePtr]]
 findRetainersOfArrWords limit rroots lim =
-  findRetainers limit rroots go
+  findRetainers limit filter rroots
  where
-    go _ sc = do
-      case noSize sc of
-        ArrWordsClosure {..} -> return $ bytes >= lim
-        _ -> return False
+    -- 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
@@ -85,19 +159,17 @@ findRetainers limit rroots p = (\(_, r, _) -> snd r) <$> runRWST (traceFromM fun
               -> 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

--- a/client/src/GHC/Debug/Snapshot.hs
+++ b/client/src/GHC/Debug/Snapshot.hs
@@ -13,14 +13,18 @@ import GHC.Debug.Client.Monad
 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 @@ snapshot fp = do
 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) ()

--- a/client/src/GHC/Debug/Strings.hs
+++ b/client/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 @@ programX sizeOf anal e = do
 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 @@ stringAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots)
               -> (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 @@ stringAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots)
        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 @@ stringAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots)
        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 @@ printResult m = do
 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 @@ arrWordsAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots
               -> (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
No results found