.gitlab-ci.yml

-image: nixos/nix
+image: debian:12
 
 workflow:
   rules:
     - if: '$CI_COMMIT_BRANCH'
 
 ci:
+  parallel:
+      matrix:
+        - 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:
-    - nix-shell -p git
-    - nix-shell
-    - cabal update
-    - cabal build debugger
-    - cabal test
+    - apt-get update && apt-get install -y curl bash git build-essential curl libffi-dev libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5
+    - ./ci.sh
 
-pages:
-  script:
-    - nix-build -A site --arg ci true -o site-out --option trusted-public-keys "mpickering.cachix.org-1:COxPsDJqqrggZgvKG6JeH9baHPue8/pcpYkmcBPUbeg= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option substituters "https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/ https://mpickering.cachix.org"
-    - mkdir -p public
-    - cp -r site-out/* public/
-  artifacts:
-    paths:
-      - public
-
-  rules:
-    - if: '$CI_COMMIT_BRANCH == "master"'
+      #pages:
+      #  script:
+      #    - nix-build -A site --arg ci true -o site-out --option trusted-public-keys "mpickering.cachix.org-1:COxPsDJqqrggZgvKG6JeH9baHPue8/pcpYkmcBPUbeg= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option substituters "https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/ https://mpickering.cachix.org"
+      #    - mkdir -p public
+      #    - cp -r site-out/* public/
+      #  artifacts:
+      #    paths:
+      #      - public
+      #
+      #  rules:
+      #    - if: '$CI_COMMIT_BRANCH == "master"'

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

ci.sh

+#!/usr/bin/env bash
+set -x
+set -eo pipefail
+
+runner_temp=$(mktemp -d)
+
+export GHCUP_INSTALL_BASE_PREFIX=$runner_temp/foobarbaz
+export BOOTSTRAP_HASKELL_NONINTERACTIVE=1
+export BOOTSTRAP_HASKELL_MINIMAL=1
+export BOOTSTRAP_HASKELL_ADJUST_BASHRC=1
+
+curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
+
+source $GHCUP_INSTALL_BASE_PREFIX/.ghcup/env || source ~/.bashrc
+
+ghcup --version
+which ghcup | grep foobarbaz
+
+ghcup --metadata-caching=0 -v install ghc --set $VERSION
+ghcup --metadata-caching=0 -v install cabal
+
+ghc --version
+ghc --info
+
+cabal update
+cabal build all

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
+  implemented in your own library if you want to use them.
+* Update with support for ghc-9.4 and ghc-9.6.
+* Add support for debugging over a TCP socket (`withDebuggeeConnectTCP`)
+
+
+## 0.4.0.1 -- 2023-03-09
+
+* Relax some version bounds and use eventlog2html 0.9.3
+
+## 0.4 -- 2022-12-14
+
+* Add support for tracing SRTs. This is quite an invasive change which adds a new
+  pointer type to the DebugClosure type. This change is reflected in the API for
+  parTrace and traceFrom.
+
+* The `Quadtraverse` abstraction is generalised to `Quintraverse` to account for
+  this new type parameter.
+
+## 0.3 -- 2022-10-06
+
+* Abstract away tracing functions to allow configuration of progress reporting.
+* Add stringAnalysis and arrWordsAnalysis in GHC.Debug.Strings
+* Make block decoding more robust if the cache lookup fails for some reason.
+* Fix bug in snapshots where we weren't storing stack frame source locations or
+  version.
+
 ## 0.2.1.0 -- 2022-05-06
 
 * Fix findRetainersOfConstructorExact

client/ghc-debug-client.cabal

 cabal-version:       3.0
 name:                ghc-debug-client
-version:             0.2.1.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,
@@ -27,9 +28,11 @@ library
                        GHC.Debug.Trace,
                        GHC.Debug.ParTrace,
                        GHC.Debug.Count,
+                       GHC.Debug.Strings,
                        GHC.Debug.TypePointsFrom,
                        GHC.Debug.Snapshot,
                        GHC.Debug.Dominators,
+                       GHC.Debug.Thunks,
                        GHC.Debug.Client.Query,
                        GHC.Debug.Client.Monad,
                        GHC.Debug.Client.BlockCache,
@@ -37,28 +40,30 @@ library
                        GHC.Debug.Client.Monad.Class,
                        GHC.Debug.Client.Monad.Simple
 
-  build-depends:       base >=4.16 && < 4.17,
+  build-depends:       base >=4.16 && < 4.22,
                        network >= 2.6 ,
                        containers ^>= 0.6,
                        unordered-containers ^>= 0.2.13,
-                       ghc-debug-common == 0.2.1.0,
-                       ghc-debug-convention == 0.2.0.0,
-                       text ^>= 1.2.4,
+                       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,
-                       mtl ^>= 2.2,
-                       eventlog2html >= 0.8.3,
+                       bitwise >= 1.0,
+                       hashable >= 1.3 && < 1.6,
+                       mtl >= 2.2 && <2.4,
                        binary ^>= 0.8,
                        psqueues ^>= 0.2,
                        dom-lt ^>= 0.2,
                        async ^>= 2.2,
                        monoidal-containers >= 0.6,
                        language-dot ^>= 0.1,
-                       ghc-prim ^>= 0.8,
-                       stm ^>= 2.5
+                       ghc-prim >= 0.8 && <0.14,
+                       stm ^>= 2.5,
+                       vector ^>= 0.13.1 ,
+                       bytestring >= 0.11,
+                       contra-tracer ^>= 0.2.0
 
   hs-source-dirs:      src
   default-language:    Haskell2010

client/src/GHC/Debug/Client.hs

@@ -49,13 +49,20 @@ module GHC.Debug.Client
   , savedObjects
   , precacheBlocks
   , dereferenceClosure
+  , dereferenceToClosurePtr
+  , addConstrDesc
+  , requestCCSMain
   , dereferenceClosures
   , dereferenceStack
   , dereferencePapPayload
   , dereferenceConDesc
   , dereferenceInfoTable
+  , dereferenceIndexTable
+  , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCC
 
-  , Quadtraversable(..)
+  , Hextraversable(..)
 
   -- * Building a Heap Graph
   , buildHeapGraph
@@ -82,6 +89,9 @@ module GHC.Debug.Client
   , StackPtr
   , ClosurePtr
   , InfoTablePtr
+  , CCPtr
+  , CCSPtr
+  , IndexTablePtr
   , HG.StackHI
   , HG.PapHI
   , HG.HeapGraphIndex
@@ -94,11 +104,13 @@ import GHC.Debug.Client.Monad
 import           GHC.Debug.Client.Query
 import qualified GHC.Debug.Types.Graph as HG
 import Data.List.NonEmpty (NonEmpty)
+import Data.Bitraversable
+import Control.Monad
 
 derefFuncM :: HG.DerefFunction DebugM Size
 derefFuncM c = do
   c' <- dereferenceClosure c
-  quadtraverse dereferencePapPayload dereferenceConDesc 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

client/src/GHC/Debug/Client/BlockCache.hs

@@ -20,6 +20,7 @@ import Data.IORef
 import Data.Bits
 import Data.List (sort)
 import Data.Binary
+import Control.Tracer
 
 newtype BlockCache = BlockCache (HM.HashMap Word64 RawBlock)
 
@@ -59,8 +60,8 @@ instance Hashable (BlockCacheRequest a) where
   hashWithSalt s (LookupClosure cpt) = s `hashWithSalt` (1 :: Int) `hashWithSalt` cpt
   hashWithSalt s PopulateBlockCache  = s `hashWithSalt` (2 :: Int)
 
-handleBlockReq :: (forall a . Request a -> IO a) -> IORef BlockCache -> BlockCacheRequest resp -> IO resp
-handleBlockReq do_req ref (LookupClosure cp) = do
+handleBlockReq :: Tracer IO String -> (forall a . Request a -> IO a) -> IORef BlockCache -> BlockCacheRequest resp -> IO resp
+handleBlockReq _ do_req ref (LookupClosure cp) = do
   bc <- readIORef ref
   let mrb = lookupClosure cp bc
   rb <- case mrb of
@@ -71,10 +72,10 @@ handleBlockReq do_req ref (LookupClosure cp) = do
                Just rb -> do
                  return rb
   return (extractFromBlock cp rb)
-handleBlockReq do_req ref PopulateBlockCache = do
+handleBlockReq tracer do_req ref PopulateBlockCache = do
   blocks <- do_req RequestAllBlocks
 --  mapM_ (\rb -> print ("NEW", rawBlockAddr rb)) blocks
-  print ("CACHING", length blocks)
+  traceWith tracer $ "Populating block cache with " ++ show (length blocks) ++ " blocks"
   atomicModifyIORef' ref ((,()) . addBlocks blocks)
   return blocks
 

client/src/GHC/Debug/Client/Monad.hs

@@ -18,17 +18,23 @@ module GHC.Debug.Client.Monad
     -- * Running/Connecting to a debuggee
   , withDebuggeeRun
   , withDebuggeeConnect
+  , withDebuggeeConnectTCP
   , debuggeeRun
   , debuggeeConnect
+  , debuggeeConnectTCP
+  , debuggeeConnectWithTracer
+  , debuggeeConnectWithTracerTCP
   , debuggeeClose
   -- * Snapshot run
   , snapshotInit
+  , snapshotInitWithTracer
   , snapshotRun
     -- * Logging
   , outputRequestLog
   ) where
 
 import Control.Exception (finally)
+import Data.Word (Word16)
 import Network.Socket
 import System.Process
 import System.Environment
@@ -36,6 +42,7 @@ import GHC.Debug.Client.Monad.Class
 import GHC.Debug.Types (Request(..))
 import qualified GHC.Debug.Client.Monad.Simple as S
 import System.IO
+import Control.Tracer
 
 type DebugM = S.DebugM
 
@@ -78,6 +85,19 @@ withDebuggeeConnect socketName action = do
       `finally`
       debuggeeClose new_env
 
+-- | Bracketed version of @debuggeeConnectTCP@. Connects to a debuggee, runs the
+-- action, then closes the debuggee.
+withDebuggeeConnectTCP
+  :: String  -- ^ host of the tcp socket (e.g. @"127.0.0.1"@)
+  -> Word16  -- ^ port of the tcp socket (e.g. @1235@)
+  -> (Debuggee -> IO a)
+  -> IO a
+withDebuggeeConnectTCP host port action = do
+    new_env <- debuggeeConnectTCP host port
+    action new_env
+      `finally`
+      debuggeeClose new_env
+
 -- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done.
 debuggeeRun :: FilePath  -- ^ path to executable to run as the debuggee
             -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
@@ -88,19 +108,45 @@ debuggeeRun exeName socketName = do
     -- Now connect to the socket the debuggeeProcess just started
     debuggeeConnect socketName
 
+debuggeeConnect :: FilePath -> IO Debuggee
+debuggeeConnect = debuggeeConnectWithTracer debugTracer
+
+debuggeeConnectTCP :: String -> Word16 -> IO Debuggee
+debuggeeConnectTCP = debuggeeConnectWithTracerTCP debugTracer
+
 -- | Connect to a debuggee on the given socket. Use @debuggeeClose@ when you're done.
-debuggeeConnect :: FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
+debuggeeConnectWithTracer
+                :: Tracer IO String
+                -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
                 -> IO Debuggee
-debuggeeConnect socketName = do
+debuggeeConnectWithTracer tracer socketName = do
     s <- socket AF_UNIX Stream defaultProtocol
     connect s (SockAddrUnix socketName)
     hdl <- socketToHandle s ReadWriteMode
-    new_env <- newEnv @DebugM (SocketMode hdl)
+    new_env <- newEnv @DebugM tracer (SocketMode hdl)
+    return (Debuggee new_env)
+
+debuggeeConnectWithTracerTCP
+  :: Tracer IO String
+  -> String  -- ^ host of the tcp socket (e.g. @"127.0.0.1"@)
+  -> Word16  -- ^ port of the tcp socket (e.g. @1235@)
+  -> IO Debuggee
+debuggeeConnectWithTracerTCP tracer host port = do
+    addr:_ <- getAddrInfo (Just defaultHints) (Just host) (Just $ show port)
+    s <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+    connect s (addrAddress addr)
+    hdl <- socketToHandle s ReadWriteMode
+    new_env <- newEnv @DebugM tracer (SocketMode hdl)
     return (Debuggee new_env)
 
 -- | Create a debuggee by loading a snapshot created by 'snapshot'.
 snapshotInit :: FilePath -> IO Debuggee
-snapshotInit fp = Debuggee <$> newEnv @DebugM (SnapshotMode fp)
+snapshotInit = snapshotInitWithTracer debugTracer
+
+snapshotInitWithTracer :: Tracer IO String -> FilePath -> IO Debuggee
+snapshotInitWithTracer tracer fp =
+  Debuggee <$> newEnv @DebugM tracer (SnapshotMode fp)
+
 
 -- | Start an analysis session using a snapshot. This will not connect to a
 -- debuggee. The snapshot is created by 'snapshot'.

client/src/GHC/Debug/Client/Monad/Class.hs

@@ -5,6 +5,7 @@ module GHC.Debug.Client.Monad.Class where
 import Data.Typeable
 import GHC.Debug.Client.BlockCache
 import GHC.Debug.Types
+import Control.Tracer
 import System.IO
 
 class (MonadFail m, Monad m) => DebugMonad m where
@@ -15,7 +16,7 @@ class (MonadFail m, Monad m) => DebugMonad m where
   printRequestLog :: DebugEnv m -> IO ()
   runDebug :: DebugEnv m -> m a -> IO a
   runDebugTrace :: DebugEnv m -> m a -> IO (a, [String])
-  newEnv :: Mode -> IO (DebugEnv m)
+  newEnv :: Tracer IO String -> Mode -> IO (DebugEnv m)
 
   saveCache :: FilePath -> m ()
   loadCache :: FilePath -> m ()

client/src/GHC/Debug/Client/Monad/Simple.hs

@@ -21,6 +21,7 @@ import System.IO
 import Data.IORef
 import Data.List
 import Data.Ord
+import Control.Tracer
 
 import GHC.Debug.Client.BlockCache
 import GHC.Debug.Client.RequestCache
@@ -37,6 +38,7 @@ data Debuggee = Debuggee { -- Keep track of how many of each request we make
                          , debuggeeBlockCache :: IORef BlockCache
                          , debuggeeRequestCache :: MVar RequestCache
                          , debuggeeHandle :: Maybe (MVar Handle)
+                         , debuggeeTrace :: Tracer IO String
                          }
 
 data FetchStats = FetchStats { _networkRequests :: !Int, _cachedRequests :: !Int }
@@ -88,7 +90,10 @@ instance DebugMonad DebugM where
   type DebugEnv DebugM = Debuggee
   request = DebugM . simpleReq
   requestBlock = blockReq
-  traceMsg = DebugM . liftIO . putStrLn
+  traceMsg s = DebugM $ do
+    Debuggee{..} <- ask
+    liftIO $ traceWith debuggeeTrace s
+
   printRequestLog e = do
     case debuggeeRequestCount e of
       Just hm_ref -> do
@@ -96,9 +101,9 @@ instance DebugMonad DebugM where
       Nothing -> putStrLn "No request log in Simple(TM) mode"
   runDebug = runSimple
   runDebugTrace e a = (,[]) <$> runDebug e a
-  newEnv m = case m of
-               SnapshotMode f -> mkSnapshotEnv f
-               SocketMode h -> mkHandleEnv h
+  newEnv t m = case m of
+               SnapshotMode f -> mkSnapshotEnv t f
+               SocketMode h -> mkHandleEnv t h
 
   loadCache fp = DebugM $ do
     (Snapshot _ new_req_cache) <- lift $ decodeFile fp
@@ -118,32 +123,33 @@ 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
 
 
 
 runSimple :: Debuggee -> DebugM a -> IO a
 runSimple d (DebugM a) = runReaderT a d
 
-mkEnv :: (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee
-mkEnv (req_c, block_c) h = do
+mkEnv :: Tracer IO String
+      -> (RequestCache, BlockCache)
+      -> Maybe Handle
+      -> IO Debuggee
+mkEnv trace_msg (req_c, block_c) h = do
   let enable_stats = False
   mcount <- if enable_stats then Just <$> newIORef HM.empty else return Nothing
   bc <- newIORef  block_c
   rc <- newMVar req_c
   mhdl <-  traverse newMVar h
-  return $ Debuggee mcount bc rc mhdl
+  return $ Debuggee mcount bc rc mhdl trace_msg
 
-mkHandleEnv :: Handle -> IO Debuggee
-mkHandleEnv h = mkEnv (emptyRequestCache, emptyBlockCache) (Just h)
+mkHandleEnv :: Tracer IO String -> Handle -> IO Debuggee
+mkHandleEnv trace_msg h = mkEnv trace_msg (emptyRequestCache, emptyBlockCache) (Just h)
 
-mkSnapshotEnv :: FilePath -> IO Debuggee
-mkSnapshotEnv fp = do
+mkSnapshotEnv :: Tracer IO String -> FilePath -> IO Debuggee
+mkSnapshotEnv trace_msg fp = do
   Snapshot _ req_c <- decodeFile fp
   let block_c = initBlockCacheFromReqCache req_c
-  mkEnv (req_c, block_c) Nothing
+  mkEnv trace_msg (req_c, block_c) Nothing
 
 -- TODO: Sending multiple pauses will clear the cache, should keep track of
 -- the pause state and only clear caches if the state changes.
@@ -176,8 +182,9 @@ simpleReq req = do
 blockReq :: BlockCacheRequest resp -> DebugM resp
 blockReq req = DebugM $ do
   bc  <- asks debuggeeBlockCache
+  tracer  <- asks debuggeeTrace
   env <- ask
-  liftIO $ handleBlockReq (\r -> runReaderT (simpleReq r) env) bc req
+  liftIO $ handleBlockReq tracer (\r -> runReaderT (simpleReq r) env) bc req
 
 newtype DebugM a = DebugM (ReaderT Debuggee IO a)
                    -- Only derive the instances that DebugMonad needs

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
@@ -25,21 +27,27 @@ module GHC.Debug.Client.Query
   , dereferenceClosure
   , dereferenceClosureDirect
   , dereferenceClosureC
+  , dereferenceToClosurePtr
+  , addConstrDesc
   , dereferenceStack
   , dereferencePapPayload
   , dereferenceConDesc
   , dereferenceInfoTable
-
+  , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCCSDirect
+  , dereferenceCC
+  , dereferenceIndexTable
+  , dereferenceIndexTableDirect
   ) where
 
 import           Control.Exception
 import           GHC.Debug.Types
-import           GHC.Debug.Decode
+import qualified GHC.Debug.Decode as D
 import           GHC.Debug.Decode.Stack
 import GHC.Debug.Client.Monad
 import           GHC.Debug.Client.BlockCache
 import Control.Monad.State
-import Data.Word
 
 import Debug.Trace
 
@@ -70,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 =
@@ -79,9 +89,17 @@ pauseThen e d =
 
 
 dereferenceClosureC :: ClosurePtr -> DebugM SizedClosureC
-dereferenceClosureC cp = do
-  c <- dereferenceClosure cp
-  quadtraverse pure dereferenceConDesc pure pure c
+dereferenceClosureC cp = addConstrDesc =<< dereferenceClosure cp
+
+addConstrDesc :: SizedClosure -> DebugM SizedClosureC
+addConstrDesc 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
+  hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc pure pure c
+
 
 -- | Decode a closure corresponding to the given 'ClosurePtr'
 -- You should not use this function directly unless you know what you are
@@ -91,7 +109,15 @@ dereferenceClosureDirect c = do
     raw_c <- request (RequestClosure c)
     let it = getInfoTblPtr raw_c
     raw_it <- request (RequestInfoTable it)
-    return $ decodeClosure raw_it (c, raw_c)
+    decodeClosure (it, raw_it) (c, raw_c)
+
+decodeClosure :: (InfoTablePtr, RawInfoTable)
+              -> (ClosurePtr, RawClosure)
+              -> DebugM SizedClosure
+decodeClosure (itp, raw_it) c = do
+  ver <- version
+  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
@@ -159,7 +185,7 @@ dereferenceClosure cp
         else do
           let it = getInfoTblPtr rc
           st_it <- request (RequestInfoTable it)
-          return $ 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]
@@ -182,10 +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 Word32
+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

client/src/GHC/Debug/Client/RequestCache.hs

@@ -4,6 +4,7 @@
 module GHC.Debug.Client.RequestCache(RequestCache
                                     , cacheReq
                                     , lookupReq
+                                    , lookupBlocks
                                     , emptyRequestCache
                                     , clearMovableRequests
                                     , putCache
@@ -14,8 +15,6 @@ import GHC.Debug.Types
 import Unsafe.Coerce
 import Data.Binary
 import Control.Monad
-import Data.Binary.Put
-import Data.Binary.Get
 
 newtype RequestCache = RequestCache (HM.HashMap AnyReq AnyResp)
 
@@ -35,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
 
@@ -43,13 +57,13 @@ emptyRequestCache = RequestCache HM.empty
 -- amount of input.
 
 getResponseBinary :: Request a -> Get a
-getResponseBinary RequestVersion       = getWord32be
+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
 getResponseBinary (RequestConstrDesc _)  = getConstrDescCache
@@ -58,14 +72,19 @@ 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 w = putWord32be w
+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
 putResponseBinary (RequestConstrDesc _) cd  = putConstrDescCache cd
@@ -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

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]

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)

client/src/GHC/Debug/Count.hs

-module GHC.Debug.Count where
+module GHC.Debug.Count (parCount, count, asyncCount, asyncParCount) where
 
 import           GHC.Debug.Types
 import GHC.Debug.Client.Monad
 import           GHC.Debug.Profile
 import           GHC.Debug.Trace
 import           GHC.Debug.ParTrace hiding (TraceFunctionsIO(..))
-import GHC.Debug.ParTrace (TraceFunctionsIO(TraceFunctionsIO))
 import Control.Monad.State
-
+import Control.Monad.Reader
+import Data.IORef
 
 parCount :: [ClosurePtr] -> DebugM CensusStats
-parCount = traceParFromM funcs . map (ClosurePtrWithInfo ())
+parCount = traceParFromWithState (justClosuresPar clos) . map (ClosurePtrWithInfo ())
   where
-    nop = const (return ())
-    funcs = TraceFunctionsIO nop nop clos (const (const (return mempty))) nop
+    clos :: WorkerId -> ClosurePtr -> SizedClosure -> ()
+              -> DebugM ((), CensusStats, DebugM () -> DebugM ())
+    clos _ cp sc _ = do
+      return ((), mkCS cp (dcSize sc), id)
 
-    clos :: ClosurePtr -> SizedClosure -> ()
+asyncParCount :: [ClosurePtr] -> DebugM (IO (AsyncTraceResult CensusStats), DebugM ())
+asyncParCount cps = asyncTraceParFromWithState (justClosuresPar clos) (map (ClosurePtrWithInfo ()) cps)
+  where
+    clos :: WorkerId -> 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 ())
-              , 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
+
+
+data CountResult = CountResult { countCensus :: !CensusStats } deriving (Show)
+
+-- | An async version of count which the request can be inspected whilst the action is running.
+asyncCount :: [ClosurePtr] -> DebugM (IO CountResult, DebugM ())
+asyncCount cps = do
+  cr <- unsafeLiftIO $ newIORef (CountResult mempty)
+  let runCensus = runReaderT (traceFromM funcs cps) cr
+  return (readIORef cr, runCensus)
+
+  where
+    funcs = justClosures closAccum
+
+    closAccum  :: ClosurePtr
+               -> SizedClosure
+               ->  (ReaderT (IORef CountResult) DebugM) ()
+               ->  (ReaderT (IORef CountResult) DebugM) ()
+    closAccum cp s k = do
+      cr <- ask
+      lift $ unsafeLiftIO $ modifyIORef' cr (go cp s)
+      k
+
+    go :: ClosurePtr -> SizedClosure -> CountResult -> CountResult
+    go cp sc cr = cr { countCensus = mkCS cp (dcSize sc) <> countCensus cr }
+

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

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"

client/src/GHC/Debug/ObjectEquiv.hs

@@ -86,20 +86,13 @@ trimMap o = if checkSize o > limit
 checkSize :: ObjectEquivState -> Int
 checkSize (ObjectEquivState e1 _ _) = PS.size e1
 
-type PtrClosure = DebugClosureWithSize 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 ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (return ())
-              , conDescTrace = const (return ())
-
-            }
+    funcs = justClosures closAccum
     -- Add cos
     closAccum  :: ClosurePtr
                -> SizedClosure
@@ -110,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 $ quadtraverse 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''  <- quadtraverse (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'')
 
@@ -153,7 +146,7 @@ printObjectEquiv c = do
   let cmp (_, b,_) = b
       res = sortBy (flip (comparing cmp)) (PS.toList c)
       showLine (k, p, v) =
-        concat [show v, ":", show p,":", ppClosure "" (\_ -> show) 0 (noSize k)]
+        concat [show v, ":", show p,":", ppClosure (\_ -> show) 0 (noSize k)]
   mapM_ (putStrLn . showLine) res
 --  writeFile "profile/profile_out.txt" (unlines $ "key, total, count, max, avg" : (map showLine res))
 

client/src/GHC/Debug/ParTrace.hs

@@ -5,7 +5,12 @@
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# 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
@@ -14,7 +19,15 @@
 -- The tracing functions create a thread for each MBlock which we
 -- traverse, closures are then sent to the relevant threads to be
 -- dereferenced and thread-local storage is accumulated.
-module GHC.Debug.ParTrace ( traceParFromM, tracePar, TraceFunctionsIO(..), ClosurePtrWithInfo(..) ) where
+module GHC.Debug.ParTrace ( traceParFromM
+                          , tracePar
+                          , traceParFromWithState
+                          , asyncTraceParFromWithState
+                          , justClosuresPar
+                          , WorkerId(..)
+                          , TraceFunctionsIO(..)
+                          , ClosurePtrWithInfo(..)
+                          , AsyncTraceResult(..)) where
 
 import           GHC.Debug.Types
 import           GHC.Debug.Client.Query
@@ -22,37 +35,41 @@ import           GHC.Debug.Client.Query
 import qualified Data.IntMap as IM
 import Data.Array.BitArray.IO hiding (map)
 import Control.Monad.Reader
+import Control.Monad
 import Data.Word
 import GHC.Debug.Client.Monad.Simple
+import GHC.Debug.Client.Monad.Class
 import Control.Concurrent.Async
 import Data.IORef
 import Control.Exception.Base
-import Debug.Trace
 import Control.Concurrent.STM
+import Data.Bitraversable
+import Data.Coerce ( coerce )
+import GHC.Conc (numCapabilities)
+import qualified Data.Map as Map
 
 threads :: Int
-threads = 64
+threads = numCapabilities
 
 type InChan = TChan
 type OutChan = TChan
 
-unsafeLiftIO :: IO a -> DebugM a
-unsafeLiftIO = DebugM . liftIO
-
 -- | State local to a thread, there are $threads spawned, each which deals
 -- with (address `div` 8) % threads. Each thread therefore:
 --
 -- * 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 = ThreadState
+  { visitedPtrs :: IM.IntMap (IM.IntMap (IOBitArray Word16))
+  }
 
 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)
@@ -69,31 +86,35 @@ getKeyTriple cp =
       mbk = fromIntegral raw_mbk `div` 8
   in (mbk, bk, fromIntegral offset)
 
-getMBlockKey :: ClosurePtr -> Int
+getMBlockKey :: ClosurePtr -> WorkerId
 getMBlockKey cp =
   let BlockPtr raw_bk = applyMBlockMask cp
   -- Not sure why I had to divide this by 4, but I did.
-  in (fromIntegral raw_bk `div` fromIntegral mblockMask `div` 4) `mod` threads
+  in WorkerId ((fromIntegral raw_bk `div` fromIntegral mblockMask `div` 4) `mod` threads)
 
 sendToChan :: TraceState a -> ClosurePtrWithInfo a -> DebugM ()
 sendToChan  ts cpi@(ClosurePtrWithInfo _ cp) = DebugM $ liftIO $ do
   let st = visited ts
-      mkey = getMBlockKey cp
+      WorkerId mkey = getMBlockKey cp
+  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
+      WorkerId 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
-           -> TraceFunctionsIO a s
-           -> DebugM (ThreadInfo a, STM Bool, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
+initThread :: WorkerId
+           -> TraceFunctionsIO a ()
+           -> DebugM (ThreadInfo a, STM Bool, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async ()))
 initThread n k = DebugM $ do
   e <- ask
   ic <- liftIO $ newTChanIO
   let oc = ic
-  ref <- liftIO $ newIORef mempty
   worker_active <- liftIO $ newTVarIO True
-  let start go = unsafeLiftIO $ async $ runSimple e $ workerThread n k worker_active ref go oc
+  let start go = unsafeLiftIO $ async $ runSimple e $ workerThread n k worker_active go oc
       finished = do
         active <- not <$> readTVar worker_active
         empty  <- isEmptyTChan ic
@@ -101,10 +122,10 @@ initThread n k = DebugM $ do
 
   return (ThreadInfo ic, finished, start)
 
-workerThread :: forall s a . Monoid s => Int -> TraceFunctionsIO a s -> TVar Bool -> IORef s -> (ClosurePtrWithInfo a -> DebugM ()) -> OutChan (ClosurePtrWithInfo a) -> DebugM s
-workerThread n k worker_active ref go oc = DebugM $ do
+workerThread :: forall a . WorkerId -> TraceFunctionsIO a () -> TVar Bool -> (ClosurePtrWithInfo a -> DebugM ()) -> OutChan (ClosurePtrWithInfo a) -> DebugM ()
+workerThread n k worker_active go oc = DebugM $ do
   d <- ask
-  r <- liftIO $ newIORef (ThreadState IM.empty ref)
+  r <- liftIO $ newIORef (ThreadState IM.empty)
   liftIO $ runSimple d (loop r)
   where
     loop r = do
@@ -120,8 +141,7 @@ workerThread n k worker_active ref go oc = DebugM $ do
         -- state for the thread. Each thread has a reference to all over
         -- threads, so the exception is only raised when ALL threads are
         -- waiting for work.
-        Left AsyncCancelled -> do
-          unsafeLiftIO $ readIORef ref
+        Left AsyncCancelled -> return ()
         Right cpi -> deref r cpi >> loop r
 
     deref r (ClosurePtrWithInfo a cp) = do
@@ -131,13 +151,23 @@ workerThread n k worker_active ref go oc = DebugM $ do
           unsafeLiftIO $ writeIORef r m'
           if b
             then do
-              s <- visitedVal k cp a
-              unsafeLiftIO $ modifyIORef' ref (s <>)
+              visitedClosVal k n cp a
             else do
               sc <- dereferenceClosure cp
-              (a', s, cont) <- closTrace k cp sc a
-              unsafeLiftIO $ modifyIORef' ref (s <>)
-              cont (() <$ quadtraverse (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)
+              (a', (), cont) <- closTrace k n cp sc a
+              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
+              visitedCcsVal k n cp
+            else do
+              ccs' <- dereferenceCCS cp
+              ccsTrace k n cp ccs'
+              () <$ bitraverse (goCCS r) goCC ccs'
 
     goc r c@(ClosurePtrWithInfo _i cp) =
       let mkey = getMBlockKey cp
@@ -149,16 +179,30 @@ workerThread n k worker_active ref go oc = DebugM $ do
     -- types as they are not as common.
     gos r a st = do
       st' <- dereferenceStack st
-      stackTrace k st'
-      () <$ traverse (goc r . ClosurePtrWithInfo a) st'
+      stackTrace k n st'
+      () <$ bitraverse (gosrt r a) (goc r . ClosurePtrWithInfo a) st'
 
     gocd d = do
       cd <- dereferenceConDesc d
-      conDescTrace k cd
+      conDescTrace k n 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'
+      papTrace k n p'
+      () <$ traverse (goc r . ClosurePtrWithInfo a) p'
+
+    gosrt r a p = do
+      p' <- dereferenceSRT p
+      srtTrace k n p'
       () <$ traverse (goc r . ClosurePtrWithInfo a) p'
 
 
@@ -178,57 +222,157 @@ handleBlockLevel bk offset m = do
       unless res (writeArray bm offset True)
       return (m, res)
 
-checkVisit :: ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)
+checkVisit :: ClosurePtr -> ThreadState -> IO (ThreadState, Bool)
 checkVisit cp st = do
   let (mbk, bk, offset) = getKeyTriple cp
-      ThreadState v ref = st
+      ThreadState v = st
   case IM.lookup mbk v of
     Nothing -> do
       (st', res) <- handleBlockLevel bk offset IM.empty
-      return (ThreadState (IM.insert mbk st' v) ref, res)
+      return (ThreadState (IM.insert mbk st' v) , res)
     Just bm -> do
       (st', res) <- handleBlockLevel bk offset bm
-      return (ThreadState (IM.insert mbk st' v) ref, res)
-
-
+      return (ThreadState (IM.insert mbk st' v) , res)
 
 
+newtype WorkerId = WorkerId Int deriving (Eq, Ord)
 
 data TraceFunctionsIO a s =
-      TraceFunctionsIO { papTrace :: !(GenPapPayload ClosurePtr -> DebugM ())
-      , stackTrace :: !(GenStackFrames ClosurePtr -> DebugM ())
-      , closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
-      , visitedVal :: !(ClosurePtr -> a -> DebugM s)
-      , conDescTrace :: !(ConstrDesc -> DebugM ())
+      TraceFunctionsIO { papTrace :: !(WorkerId -> GenPapPayload ClosurePtr -> DebugM ())
+      , srtTrace :: !(WorkerId -> GenSrtPayload ClosurePtr -> DebugM ())
+      , stackTrace :: !(WorkerId -> GenStackFrames SrtCont ClosurePtr -> DebugM ())
+      , closTrace :: !(WorkerId -> ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
+      , visitedClosVal :: !(WorkerId -> ClosurePtr -> a -> DebugM s)
+      , visitedCcsVal :: !(WorkerId -> CCSPtr -> DebugM s)
+      , conDescTrace :: !(WorkerId -> ConstrDesc -> DebugM ())
+      , ccsTrace :: !(WorkerId -> CCSPtr -> CCSPayload -> DebugM s)
       }
 
+justClosuresPar :: Monoid s =>
+                   (WorkerId -> ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
+                -> TraceFunctionsIO a s
+justClosuresPar clos = TraceFunctionsIO
+  { papTrace = nop
+  , srtTrace = nop
+  , stackTrace = nop
+  , closTrace = clos
+  , visitedClosVal = const (const (const (return mempty)))
+  , visitedCcsVal = const (const (return mempty))
+  , conDescTrace = nop
+  , ccsTrace = const (const (const (return mempty)))
+  }
+  where
+    nop = const (const (return ()))
+
+-- | Accumulate state from each node
+stateAccumulator  :: Semigroup s => Map.Map WorkerId (IORef s)
+                  -> TraceFunctionsIO a s
+                  -> TraceFunctionsIO a ()
+stateAccumulator refs f =
+    TraceFunctionsIO
+      { papTrace = papTrace f
+      , srtTrace = srtTrace f
+      , stackTrace = stackTrace f
+      , closTrace = \wid cp sc a -> do
+          let ref = refs Map.! wid
+          closTrace f wid cp sc a >>= \ (a', s, cont) -> do
+            unsafeLiftIO $ modifyIORef' ref (s <>)
+            return (a', (), cont)
+
+
+      , visitedClosVal = \wid cp a -> do
+          let ref = refs Map.! wid
+          visitedClosVal f wid cp a >>= \ s -> do
+            unsafeLiftIO $ modifyIORef' ref (s <>)
+            return ()
+      , visitedCcsVal = \wid ccs -> do
+          let ref = refs Map.! wid
+          visitedCcsVal f wid ccs >>= \ s -> do
+            unsafeLiftIO $ modifyIORef' ref (s <>)
+            return ()
+      , conDescTrace = conDescTrace f
+      , ccsTrace = \wid ccs ccs' -> do
+          let ref = refs Map.! wid
+          ccsTrace f wid ccs ccs' >>= \ s -> do
+            unsafeLiftIO $ modifyIORef' ref (s <>)
+            return ()
+      }
+
+data AsyncTraceResult s = Done s  -- ^ The traversal has finished, the result is the accumulated state.
+                        | Running s -- ^ The traversal is running, the current result
+                        | NotStarted -- ^ The traversal has not started yet.
+                        deriving (Foldable, Traversable, Functor, Show)
+
+
+
+-- | Perform a parallel trace, accumulating state as we go, which can be queried whilst
+-- the traversal is running.
+asyncTraceParFromWithState :: Monoid s
+                           => TraceFunctionsIO a s
+                           -- ^ The tracing function for dealing with closures.
+                           -> [ClosurePtrWithInfo a]
+                           -> DebugM (IO (AsyncTraceResult s), DebugM ())
+                           -- An IO action which can be used to query the current result of the trace, and an action to run the trace.
+asyncTraceParFromWithState f cps = do
+  progressVar <- unsafeLiftIO $ newIORef NotStarted
+  refs <- Map.fromList <$> mapM (\i -> (WorkerId i,) <$> unsafeLiftIO (newIORef mempty)) [0 .. threads - 1]
+  -- Run the tracing action
+  let performAction = do
+        unsafeLiftIO $ writeIORef progressVar (Running ())
+        traceParFromM (stateAccumulator refs f) cps
+        unsafeLiftIO $ writeIORef progressVar (Done ())
+  -- Collect the results
+  let read_results = mconcat <$> mapM (\(_wid, ref) -> readIORef ref) (Map.toList refs)
+  return (reportProgress progressVar read_results,  performAction)
+  where
+    reportProgress :: IORef (AsyncTraceResult ())
+                   -> IO s
+                   -> IO (AsyncTraceResult s)
+    reportProgress progressVar read_results = do
+      progress <- readIORef progressVar
+      traverse (\_ -> read_results) progress
+
+-- | A parallel traversal which accumulates state when visiting closures.
+traceParFromWithState :: Monoid s => TraceFunctionsIO a s
+                        -> [ClosurePtrWithInfo a]
+                        -> DebugM s
+traceParFromWithState f cps = do
+  (read_results, performAction) <- asyncTraceParFromWithState f cps
+  performAction
+  unsafeLiftIO $ do
+    res <- read_results
+    case res of
+      Done s -> return s
+      NotStarted -> error "NotStarted"
+      Running _ -> error "Running"
 
 -- | 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 :: TraceFunctionsIO a () -> [ClosurePtrWithInfo a] -> DebugM ()
 traceParFromM k cps = do
-traceParFromM k cps = do
+  traceMsg ("SPAWNING: " ++ show threads)
   (init_mblocks, work_actives, start)  <- unzip3 <$> mapM (\b -> do
- 
+                                    (ti, working, start) <- initThread (WorkerId b) k
                                     return ((fromIntegral b, ti), working, start)) [0 .. threads - 1]
   let ts_map = IM.fromList init_mblocks
       go  = sendToChan (TraceState ts_map)
   as <- sequence (map ($ go) start )
   mapM_ go cps
-  mapM_ go cps
-  unsafeLiftIO $ waitFinish work_actives
+  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 ()
@@ -241,18 +385,30 @@ 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 clos (const (const (return ()))) nop
+    nop = const (const (return ()))
+    funcs = TraceFunctionsIO
+      { papTrace = nop
+      , srtTrace = nop
+      , stackTrace = stack
+      , closTrace = clos
+      , visitedClosVal = const (const (const (return ())))
+      , visitedCcsVal = nop
+      , conDescTrace = nop
+      , ccsTrace = const (const (const (return ())))
+      }
 
-    clos :: ClosurePtr -> SizedClosure -> ()
-              -> DebugM ((), (), DebugM () -> DebugM ())
-    clos _cp sc _ = do
+    stack :: WorkerId -> GenStackFrames SrtCont ClosurePtr -> DebugM ()
+    stack _ fs =
+      let stack_frames = getFrames fs
+      in mapM_ (getSourceInfo . tableId . frame_info) stack_frames
+
+    clos :: WorkerId -> ClosurePtr -> SizedClosure -> ()
+              -> DebugM ((),  (), DebugM () -> DebugM ())
+    clos _ _cp sc _ = do
       let itb = info (noSize sc)
       _traced <- getSourceInfo (tableId itb)
       return ((), (), id)
-
-

client/src/GHC/Debug/Profile.hs

@@ -9,18 +9,32 @@
 {-# 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( profile
-                        , censusClosureType
+module GHC.Debug.Profile( censusClosureType
                         , census2LevelClosureType
                         , closureCensusBy
                         , 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
@@ -29,46 +43,114 @@ 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 Control.Concurrent
-import Eventlog.Types
-import Eventlog.Data
-import Eventlog.Total
-import Eventlog.HtmlTemplate
-import Eventlog.Args (defaultArgs)
-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
+--import Eventlog.Data
+--import Eventlog.Total
+--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 <- quadtraverse 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 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)
@@ -76,22 +158,14 @@ closureCensusBy :: forall k v . (Semigroup v, Ord k)
                 -> [ClosurePtr] -> DebugM (Map.Map k v)
 closureCensusBy f cps = do
   () <$ precacheBlocks
-  MMap.getMonoidalMap <$> traceParFromM funcs (map (ClosurePtrWithInfo ()) cps)
+  MMap.getMonoidalMap <$> traceParFromWithState (justClosuresPar closAccum) (map (ClosurePtrWithInfo ()) cps)
   where
-    funcs = TraceFunctionsIO {
-               papTrace = const (return ())
-              , stackTrace = const (return ())
-              , closTrace = closAccum
-              , visitedVal = const (const (return MMap.empty))
-              , conDescTrace = const (return ())
-
-            }
     -- Add cos
-    closAccum  :: ClosurePtr
+    closAccum  :: WorkerId -> ClosurePtr
                -> SizedClosure
                -> ()
                -> DebugM ((), MMap.MonoidalMap k v, a -> a)
-    closAccum cp s () = do
+    closAccum _ cp s () = do
       r <- f cp s
       return . (\s' -> ((), s', id)) $ case r of
         Just (k, v) -> MMap.singleton k v
@@ -103,34 +177,48 @@ closureCensusBy f cps = do
 census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
 census2LevelClosureType cps = snd <$> runStateT (traceFromM funcs cps) Map.empty
   where
-    funcs = TraceFunctions {
-               papTrace = 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 $ quadtraverse dereferencePapPayload dereferenceConDesc 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 (quadtraverse 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
@@ -145,7 +233,7 @@ parCensus bs cs =  do
     clos :: ClosurePtr -> SizedClosure -> ()
               -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ())
     clos _cp sc () = do
-      d <- quadtraverse pure dereferenceConDesc pure pure sc
+      d <- hextraverse pure dereferenceConDesc pure pure sc
       let s :: Size
           s = dcSize sc
           v =  mkCS s
@@ -156,11 +244,20 @@ 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
 -- be rendered after each iteration using @eventlog2html@.
 profile :: FilePath -> Int -> Debuggee -> IO ()
@@ -202,10 +299,11 @@ mkProfData raw_fs =
 renderProfile :: [(Int, CensusByClosureType)] -> IO ()
 renderProfile ss = do
   let pd = mkProfData ss
-  as <- defaultArgs "unused"
+  Run as <- defaultArgs "unused"
   (header, data_json, descs, closure_descs) <- generateJsonData as pd
   let html = templateString header data_json descs closure_descs as
   writeFile "profile/ht.html" html
   return ()
+  -}