.gitignore

 .ghc.environment.*
 dist-newstyle/
+cabal.project.local
+.vscode/

.gitlab-ci.yml

+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:
+    - 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"'

.gitmodules

-[submodule "dwarf"]
-	path = dwarf
-	url = https://github.com/mpickering/dwarf.git
-[submodule "dwarfadt"]
-	path = dwarfadt
-	url = https://github.com/mpickering/dwarfadt.git

DEVELOP.md

+# Development Notes
+
+## Debugger <-> Debuggee Communication
+
+The debugger and debuggee communicate via a unix domain socket created by the
+debuggee via `start` in the `ghc-debug-stub` package. Such sockets appear as
+files in the file system. By convention, these sockets are placed with arbitrary
+name form "<PID> - <Title>" into the `$XDG_DATA_HOME/ghc-debug/debuggee`
+directory. This directory is observed by the frontend to automatically discover
+debuggees.The location of the socket can be overridden by setting the
+`GHC_DEBUG_SOCKET` environment variable when running the debuggee. In summary
+the socket location is:
+
+* `$GHC_DEBUG_SOCKET` if `GHC_DEBUG_SOCKET` is defined. Else
+* `$XDG_DATA_HOME/ghc-debug/debuggee/<PID>-<Title>` if `XDG_DATA_HOME` is defined. Else
+* `/tmp/ghc-debug/debuggee/<PID> - <Title>`
\ No newline at end of file

README.md

-This set of libraries is progress towards implementing an way to interact
-with Haskell's RTS from another Haskell program.
+[Documentation Site](http://ghc.gitlab.haskell.org/ghc-debug)
+
+
+`ghc-debug` is a set of libraries which allow you to inspect the heap of
+a running Haskell program from an external debugger.
 
 For example, you could use this library to
-* Implement a memory profiler, written in Haskell
-* Precisely analyse other heap properties such as retainers
+* Implement a memory profiler, written in Haskell - [GHC.Debug.Profile](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/Profile.hs)
+* Precisely analyse other heap properties such as retainers - [GHC.Debug.Retainers](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/Retainers.hs)
+* Work out any other question you want about the heap by writing your own
+custom analysis. The possibilities are endless!
 
-# How does it work?
+# Getting Started
 
-We call the process we want to debug the debuggee and the process which does
-the debugging the debugger.
-Whilst the debuggee is
-running it calls the C function `start` which creates a unix domain socket (`/tmp/ghc-debug` for now). The debugger starts and connects to the socket.
+There are two parts to using `ghc-debug`. Firstly the application you want to
+inspect has to be instrumented using the `withGhcDebug` function from
+`GHC.Debug.Stub`. This just wraps the normal main function of your executable,
+when it is executed it will create a socket by which a debugger can connect
+and issue requests to. The location of the socket can be controlled by setting
+the `GHC_DEBUG_SOCKET` variable when the executable is run.
 
-Once the debugger is connected it can send requests to the debuggee to control
-and inspect the RTS. The requests API is specified as follows:
+```
+import GHC.Debug.Stub
 
+main = withGhcDebug normalMain
 ```
--- | A request sent from the debugger to the debuggee parametrized on the result type.
-data Request a where
-    -- | Request protocol version
-    RequestVersion :: Request Word64
-    -- | Pause the debuggee.
-    RequestPause :: Request ()
-    -- | Resume the debuggee.
-    RequestResume :: Request ()
-    -- | Request the debuggee's root pointers.
-    RequestRoots :: Request [ClosurePtr]
-    -- | Request a set of closures.
-    RequestClosures :: [ClosurePtr] -> Request [GenClosure InfoTablePtr ClosurePtr]
-    -- | Request a set of info tables.
-    RequestInfoTables :: [InfoTablePtr] -> Request [StgInfoTable]
+
+Note: To enable source information you should also compile your application and
+dependencies with `-finfo-table-map` and optionally `-fdistinct-constructor-tables`.
+
+## A simple debugger
+
+The most productive way to use `ghc-debug` is to write your own heap analysis
+scripts. Fortunately, this is also quite simple. Here is a simple, complete, debugger
+which connects to the `/tmp/ghc-debug` socket, requests the GC roots and then
+decodes the first one up to depth 10 before printing the result to the user.
+
 ```
+import GHC.Debug.Client
 
-So far only the version, pause and resume functions are tested (and work).
+main = withDebuggeeConnect "/tmp/ghc-debug" p1
 
-We will add some more functions to this interface, for example, a request to
-call `findPtr` and also a way to mark objects of interest so we can retrieve their
-addresses in the same manner as `RequestRoots`.
+p1 :: Debuggee -> IO ()
+p1 e = do
+  pause e
+  g <- run e $ do
+        precacheBlocks
+        (r:_) <- gcRoots
+        buildHeapGraph (Just 10) r
+  putStrLn (ppHeapGraph (const "") g)
+```
 
-# How do I use it?
+The API for writing debuggers is described in the `GHC.Debug.Client` module.
+
+There are many more examples in the `test/Test.hs` file.
+
+## Snapshotting
+
+A convenient way to use `ghc-debug` is to take a *snapshot* of the heap and then
+perform further analysis on the snapshot rather than connecting to a running
+process. Snapshotting utilities are in the `GHC.Debug.Snapshot` module. A
+snapshot can be created using the `makeSnapshot` program, it will pause
+the process and then save a snapshot to the `/tmp/ghc-debug-snapshot` file.
+
+```
+import GHC.Debug.Client
+import GHC.Debug.Snapshot
+
+main = withDebuggeeConnect "/tmp/ghc-debug" (\d -> makeSnapshot d "/tmp/ghc-debug-snapshot")
+```
+
+A snapshot can be then used for further analysis. For example, we can run `p1` on
+the snapshot by using `snapshotRun` instead of `withDebuggeeConnect`. The same
+programs can be used with snapshots but requests such as pausing and resuming are
+just ignored.
+
+```
+import GHC.Debug.Client
+
+main = snapshotRun "/tmp/ghc-debug-snapshot" p1
+```
+
+
+## High-Level Analysis
+
+There are also some more high-level analysis tools already packaged with the
+library. Mostly as an idea about what sort of thing you could program yourself.
 
-In short, you don't, yet.
+* [Profiling](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/Profile.hs) - Profiling modes in the spirit of `-hT`.
+* [Object Equivalence](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/ObjectEquiv.hs) - Detect equivalent heap objects which could be shared.
+* [Count](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/Count.hs) - Simple heap statistics, total number of objects, total size and maximum object size.
+* [Fragmentation](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/Fragmentation.hs) - Functions for analysis memory fragmentation including block and mblock utilisation histograms.
+* [Retainers](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/Retainers.hs) - Finding paths through the heap to work out why objects are being retained.
+* [Type Points From](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/TypePointsFrom.hs) - Collapse a heap graph so that nodes are info tables and edges are references between info tables. This allows you to implement the [Cork](https://www.cs.utexas.edu/users/speedway/DaCapo/papers/cork-popl-2007.pdf) leak analysis.
 
-The project needs to built with a development version of GHC from [this](https://gitlab.haskell.org/ghc/ghc/tree/wip/ghc-debug) branch.
+These analysis modes are implemented in terms of the more low-level traversal
+functions.
 
-Then you can use normal cabal commands to build this library.
+* [Sequential Traversal](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/Trace.hs) - Traversal with low memory overhead, accounting for cycles.
+* [Parallel Traversal](https://gitlab.haskell.org/ghc/ghc-debug/-/blob/master/client/src/GHC/Debug/ParTrace.hs) - Experimental Parallel Traversal with low memory overhead.
 
-In order to make a process debuggable it needs to call the socket initialisation
-function `start`, see the `test-debug` executable for exactly how to do this.
+# Other Resources
 
-## Testing
+* [An introduction to ghc-debug: precise memory analysis for Haskell programs](https://www.youtube.com/watch?v=9zuAsGk9xoM)
+
+
+# How does it work?
+
+We call the process we want to debug the debuggee and the process which does
+the debugging the debugger.
+Whilst the debuggee is
+running it calls the C function `start` which creates a unix domain socket (which is set from `GHC_DEBUG_SOCKET`). The debugger starts and connects to the socket.
+
+Once the debugger is connected it can send requests to the debuggee to control
+and inspect the RTS.
+
+# How do I use it?
+
+You can build the libraries directly from hackage.
+
+### Automated Testing
+
+There are `hspec` tests, that can be run with `cabal`:
+
+```
+cabal new-test all
+```
 
-There are two test executables `test-debug` and `debugger` which are used to
-test the library.
+### Unexpected Build Failures
 
-`test-debug` is an interruptable program which prints out an incrementing
-counter each second. `debugger` starts and immediately attaches to `test-debug`
-and makes some requests. So the way to test the library is to first start `test-debug`
-and then start `debugger`. There are lots of helpeful traces to see what's going
-on with each process.
+If you encounter dependencies failing to build but there's a patch for
+the library in head.hackage then you may need to delete `~/.cabal/packages/head.hackage.org`
+so that the fresh patch is visible. This is probably a bug in cabal!

cabal.project

-packages: common, stub, client, dwarfadt, dwarf, ghc-vis, test, dyepack-test
+packages: common, stub, client, test, ghc-debug-brick, convention
 
-allow-newer: all
+-- If you see a Cmm lexical error, then comment out this line
+-- debug-info: 3
 
-repository head.hackage.ghc.haskell.org
-   url: https://ghc.gitlab.haskell.org/head.hackage/
-   secure: True
-   key-threshold: 3
-   root-keys:
-       7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
-       26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
-       f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
-
-
-source-repository-package
-  type: git
-  location: https://github.com/mpickering/threepenny-utils.git
-  tag: 75edf621ce69f09b7c04de4569d9737e54f8e636

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.1.0.0 -- YYYY-mm-dd
+## 0.7.0.0 -- 2025-05-20
 
-* First version. Released on an unsuspecting world.
+* 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
+
+## 0.2.0.0 -- 2021-12-06
+
+* Second version.
+
+## 0.1.0.0 -- 2021-06-14
+
+* First version.

client/ghc-debug-client.cabal

+cabal-version:       3.0
 name:                ghc-debug-client
-version:             0.1.0.0
--- synopsis:
--- description:
-homepage:            https://github.com/bgamari/ghc-debug
-license:             BSD3
+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
+                     ghc-debug.
+homepage:            https://gitlab.haskell.org/ghc/ghc-debug
+license:             BSD-3-Clause
 license-file:        LICENSE
-author:              Ben Gamari
-maintainer:          ben@smart-cactus.org
-copyright:           (c) 2019 Ben Gamari
+author:              Ben Gamari, Matthew Pickering, David Eichmann
+maintainer:          matthewtpickering@gmail.com
+copyright:           (c) 2019-2021 Ben Gamari, Matthew Pickering
 category:            Development
 build-type:          Simple
 extra-source-files:  CHANGELOG.md
-cabal-version:       >=1.10
 
 library
-  exposed-modules:     GHC.Debug.Client
-  build-depends:       base >=4.12 && <4.14,
-                       network >=2.6 && <2.7,
-                       unordered-containers,
-                       ghc-debug-common, cpu,
-                       dwarfadt, dwarf-el, text, process, filepath, directory
+  exposed-modules:     GHC.Debug.Client,
+                       GHC.Debug.CostCentres,
+                       GHC.Debug.Retainers,
+                       GHC.Debug.GML,
+                       GHC.Debug.Fragmentation,
+                       GHC.Debug.ObjectEquiv,
+                       GHC.Debug.Client.Search,
+                       GHC.Debug.Profile,
+                       GHC.Debug.Profile.Types,
+                       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,
+                       GHC.Debug.Client.RequestCache,
+                       GHC.Debug.Client.Monad.Class,
+                       GHC.Debug.Client.Monad.Simple
+
+  build-depends:       base >=4.16 && < 4.22,
+                       network >= 2.6 ,
+                       containers ^>= 0.6,
+                       unordered-containers ^>= 0.2.13,
+                       ghc-debug-common == 0.7.0.0,
+                       ghc-debug-convention == 0.7.0.0,
+                       text >= 2.1 && < 3,
+                       process ^>= 1.6,
+                       filepath >= 1.4 && < 1.6,
+                       directory ^>= 1.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 && <0.14,
+                       stm ^>= 2.5,
+                       vector ^>= 0.13.1 ,
+                       bytestring >= 0.11,
+                       contra-tracer ^>= 0.2.0
+
   hs-source-dirs:      src
-  default-language:    Haskell2010
\ No newline at end of file
+  default-language:    Haskell2010
+  default-extensions:  ApplicativeDo
+  ghc-options:         -Wall

client/src/GHC/Debug/Client.hs

+{- | The main API for creating debuggers. For example, this API can be used
+to connect to an instrumented process, query the GC roots and then decode
+the first root up to depth 10 and displayed to the user.
+
+@
+main = withDebuggeeConnect "\/tmp\/ghc-debug" p1
+
+p1 :: Debuggee -> IO ()
+p1 e = do
+  pause e
+  g <- run e $ do
+        precacheBlocks
+        (r:_) <- gcRoots
+        buildHeapGraph (Just 10) r
+  putStrLn (ppHeapGraph (const "") g)
+@
+
+-}
 module GHC.Debug.Client
-  ( Debuggee
-  , withDebuggee
-  , withDebuggeeSocket
-  , pauseDebuggee
-  , request
-  , Request(..)
-  , getInfoTblPtr
-  , decodeClosure
-  , decodeStack
-  , FieldValue(..)
-  , decodeInfoTable
-  , lookupInfoTable
-  , getDwarfInfo
-  , lookupDwarf
-  , showFileSnippet
-  , DebugClosure(..)
-  , dereferenceClosures
+  ( -- * Running/Connecting to a debuggee
+    Debuggee
+  , DebugM
+  , debuggeeRun
+  , debuggeeConnect
+  , debuggeeClose
+  , withDebuggeeRun
+  , withDebuggeeConnect
+  , socketDirectory
+  , snapshotRun
+
+    -- * Running DebugM
+  , run
+  , runTrace
+  , runAnalysis
+
+    -- * Pause/Resume
+  , pause
+  , fork
+  , pauseThen
+  , resume
+  , pausePoll
+  , withPause
+
+  -- * Basic Requests
+  , version
+  , gcRoots
+  , allBlocks
+  , getSourceInfo
+  , savedObjects
+  , precacheBlocks
   , dereferenceClosure
+  , dereferenceToClosurePtr
+  , addConstrDesc
+  , requestCCSMain
+  , dereferenceClosures
   , dereferenceStack
+  , dereferencePapPayload
   , dereferenceConDesc
-  , fullTraversal
-  , Tritraversable(..)
+  , dereferenceInfoTable
+  , dereferenceIndexTable
+  , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCC
+
+  , Hextraversable(..)
+
+  -- * Building a Heap Graph
+  , buildHeapGraph
+  , multiBuildHeapGraph
+  , HG.HeapGraph(..)
+  , HG.HeapGraphEntry(..)
+
+  -- * Printing a heap graph
+  , HG.ppHeapGraph
+
+  -- * Tracing
+  , traceWrite
+  , traceMsg
+
+  -- * Caching
+  , saveCache
+  , loadCache
+
+  -- * Types
+  , module GHC.Debug.Types.Closures
+  , SourceInformation(..)
+  , RawBlock(..)
+  , BlockPtr
+  , StackPtr
+  , ClosurePtr
+  , InfoTablePtr
+  , CCPtr
+  , CCSPtr
+  , IndexTablePtr
+  , HG.StackHI
+  , HG.PapHI
+  , HG.HeapGraphIndex
   ) where
 
-import Control.Concurrent
-import Control.Exception
-import Control.Monad
-import GHC.Debug.Types
-import GHC.Debug.Decode
-import GHC.Debug.Decode.Stack
-import Network.Socket
-import qualified Data.HashMap.Strict as HM
-import System.IO
-import Data.Word
-import Data.Maybe
-import System.Endian
-import Data.Foldable
-import Data.Coerce
+import           GHC.Debug.Types
+import           GHC.Debug.Types.Closures
+import           GHC.Debug.Convention (socketDirectory)
+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
+  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
+-- to a small number ~ 10, as otherwise you can easily run out of memory.
+buildHeapGraph :: Maybe Int -> ClosurePtr -> DebugM (HG.HeapGraph Size)
+buildHeapGraph = HG.buildHeapGraph derefFuncM
+
+-- | Build a heap graph starting from multiple roots. The first argument
+-- controls how many levels to recurse. You nearly always want to set this
+-- value to a small number ~ 10 as otherwise you can easily run out of
+-- memory.
+multiBuildHeapGraph :: Maybe Int -> NonEmpty ClosurePtr -> DebugM (HG.HeapGraph Size)
+multiBuildHeapGraph = HG.multiBuildHeapGraph derefFuncM
+
+-- | Perform the given analysis whilst the debuggee is paused, then resume
+-- and apply the continuation to the result.
+runAnalysis :: DebugM a -> (a -> IO r) -> Debuggee -> IO r
+runAnalysis a k e = do
+  pause e
+  r <- run e a
+  resume e
+  k r
 
-import qualified Data.Dwarf as Dwarf
-import qualified Data.Dwarf.ADT.Pretty as DwarfPretty
-import qualified Data.Dwarf.Elf as Dwarf.Elf
-
-import Data.Dwarf
-import Data.Dwarf.ADT
-import qualified Data.Text  as T
-import Data.List
-import System.Process
-import System.Environment
-import System.FilePath
-import System.Directory
-import Text.Printf
-
-data Debuggee = Debuggee { debuggeeHdl :: Handle
-                         , debuggeeInfoTblEnv :: MVar (HM.HashMap InfoTablePtr RawInfoTable)
-                         , debuggeeDwarf :: Maybe Dwarf
-                         , debuggeeFilename :: FilePath
-                         }
-
-
-debuggeeProcess :: FilePath -> FilePath -> IO CreateProcess
-debuggeeProcess exe sockName = do
-  e <- getEnvironment
-  return $
-    (proc exe []) { env = Just (("GHC_DEBUG_SOCKET", sockName) : e) }
-
--- | Open a debuggee, this will also read the DWARF information
-withDebuggee :: FilePath  -- ^ path to executable
-             -> (Debuggee -> IO a)
-             -> IO a
-withDebuggee exeName action = do
-    let sockName = "/tmp/ghc-debug2"
-    -- Read DWARF information from the executable
-    -- Start the process we want to debug
-    cp <- debuggeeProcess exeName sockName
-    withCreateProcess cp $ \_ _ _ _ -> do
-      dwarf <- getDwarfInfo exeName
-    -- Now connect to the socket the debuggeeProcess just started
-      withDebuggeeSocket exeName sockName (Just dwarf) action
-
-
--- | Open a debuggee's socket directly
-withDebuggeeSocket :: FilePath  -- ^ executable name of the debuggee
-                   -> FilePath  -- ^ debuggee's socket location
-                   -> Maybe Dwarf
-                   -> (Debuggee -> IO a)
-                   -> IO a
-withDebuggeeSocket exeName sockName mdwarf action = do
-    s <- socket AF_UNIX Stream defaultProtocol
-    connect s (SockAddrUnix sockName)
-    hdl <- socketToHandle s ReadWriteMode
-    infoTableEnv <- newMVar mempty
-    action (Debuggee hdl infoTableEnv mdwarf exeName)
-
--- | Send a request to a 'Debuggee' paused with 'pauseDebuggee'.
-request :: Debuggee -> Request resp -> IO resp
-request d req = doRequest (debuggeeHdl d) req
-
-lookupInfoTable :: Debuggee -> RawClosure -> IO (RawInfoTable, RawClosure)
-lookupInfoTable d rc = do
-    let ptr = getInfoTblPtr rc
-    itblEnv <- readMVar (debuggeeInfoTblEnv d)
-    case HM.lookup ptr itblEnv of
-      Nothing -> do
-        [itbl] <- request d (RequestInfoTables [ptr])
-        modifyMVar_ (debuggeeInfoTblEnv d) $ return . HM.insert ptr itbl
-        return (itbl, rc)
-      Just itbl ->  return (itbl, rc)
-
-pauseDebuggee :: Debuggee -> IO a -> IO a
-pauseDebuggee d =
-    bracket_ (void $ request d RequestPause) (void $ request d RequestResume)
-
-getDwarfInfo :: FilePath -> IO Dwarf
-getDwarfInfo fn = do
- (dwarf, warnings) <- Dwarf.Elf.parseElfDwarfADT Dwarf.LittleEndian fn
--- mapM_ print warnings
--- print $ DwarfPretty.dwarf dwarf
- return dwarf
-
-lookupDwarf :: Debuggee -> InfoTablePtr -> Maybe ([FilePath], Int, Int)
-lookupDwarf d (InfoTablePtr w) = do
-  (Dwarf units) <- debuggeeDwarf d
-  asum (map (lookupDwarfUnit (fromBE64 w)) units)
-
-lookupDwarfUnit :: Word64 -> Boxed CompilationUnit -> Maybe ([FilePath], Int, Int)
-lookupDwarfUnit w (Boxed _ cu) = do
-  low <- cuLowPc cu
-  high <- cuHighPc cu
-  guard (low <= w && w <= high)
-  (LNE ds fs ls) <- cuLineNumInfo cu
-  (fp, l, c) <- foldl' (lookupDwarfLine w) Nothing (zip ls (tail ls))
-  let res_fps = if null ds then [T.unpack (cuCompDir cu) </> fp]
-                           else map (\d -> T.unpack (cuCompDir cu) </> T.unpack d </> fp) ds
-  return ( res_fps
-         , l , c)
-
-lookupDwarfSubprogram :: Word64 -> Boxed Def -> Maybe Subprogram
-lookupDwarfSubprogram w (Boxed _ (DefSubprogram s)) = do
-  low <- subprogLowPC s
-  high <- subprogHighPC s
-  guard (low <= w && w <= high)
-  return s
-lookupDwarfSubprogram _ _ = Nothing
-
-lookupDwarfLine :: Word64
-                -> Maybe (FilePath, Int, Int)
-                -> (Dwarf.DW_LNE, Dwarf.DW_LNE)
-                -> Maybe (FilePath, Int, Int)
-lookupDwarfLine w Nothing (d, nd) = do
-  if lnmAddress d <= w && w <= lnmAddress nd
-    then do
-      let (LNEFile file _ _ _) = lnmFiles nd !! (fromIntegral (lnmFile nd) - 1)
-      Just (T.unpack file, fromIntegral (lnmLine nd), fromIntegral (lnmColumn nd))
-    else Nothing
-lookupDwarfLine _ (Just r) _ =  Just r
-
-showFileSnippet :: Debuggee -> ([FilePath], Int, Int) -> IO ()
-showFileSnippet d (fps, l, c) = go fps
-  where
-    go [] = putStrLn ("No files could be found: " ++ show fps)
-    go (fp: fps) = do
-      exists <- doesFileExist fp
-      -- get file modtime
-      if not exists
-        then go fps
-        else do
-          fp `warnIfNewer` (debuggeeFilename d)
-          src <- zip [1..] . lines <$> readFile fp
-          let ctx = take 10 (drop (max (l - 5) 0) src)
-          putStrLn (fp <> ":" <> show l <> ":" <> show c)
-          mapM_ (\(n, l) ->
-           let sn = show n
-           in putStrLn (sn <> replicate (5 - length sn) ' ' <> l)) ctx
-
-dereferenceClosure :: Debuggee -> ClosurePtr -> IO Closure
-dereferenceClosure d c = head <$> dereferenceClosures d [c]
-
-dereferenceClosures  :: Debuggee -> [ClosurePtr] -> IO [Closure]
-dereferenceClosures d cs = do
-    raw_cs <- request d (RequestClosures cs)
-    let its = map getInfoTblPtr raw_cs
-    --print $ map (lookupDwarf d) its
-    raw_its <- request d (RequestInfoTables its)
-    return $ map (uncurry decodeClosure) (zip raw_its (zip cs raw_cs))
-
-dereferenceStack :: Debuggee -> StackCont -> IO Stack
-dereferenceStack d (StackCont stack) = do
-  print stack
-  i <- lookupInfoTable d (coerce stack)
-  let st_it = decodeInfoTable . fst $ i
-  print i
-  print st_it
-  bt <- request d (RequestBitmap (getInfoTblPtr (coerce stack)))
-  let decoded_stack = decodeStack stack st_it bt
-  print decoded_stack
-  return decoded_stack
-
-dereferenceConDesc :: Debuggee -> ClosurePtr -> IO ConstrDesc
-dereferenceConDesc d i = do
-  request d (RequestConstrDesc i)
-
-
-fullTraversal :: Debuggee -> ClosurePtr -> IO UClosure
-fullTraversal d c = do
-  dc <- dereferenceClosure d c
-  print dc
-  MkFix1 <$> tritraverse (dereferenceConDesc d) (fullStackTraversal d) (fullTraversal d)  dc
-
-fullStackTraversal :: Debuggee -> StackCont -> IO UStack
-fullStackTraversal d sc = do
-  ds <- dereferenceStack d sc
-  print ds
-  MkFix2 <$> traverse (fullTraversal d) ds
-
--- | Print a warning if source file (first argument) is newer than the binary (second argument)
-warnIfNewer :: FilePath -> FilePath -> IO ()
-warnIfNewer fpSrc fpBin = do
-    modTimeSource <- getModificationTime fpSrc
-    modTimeBinary <- getModificationTime fpBin
-    if modTimeSource > modTimeBinary
-    then 
-      hPutStrLn stderr $
-        printf "Warning: %s is newer than %s. Code snippets might be wrong!"
-          fpSrc fpBin
-    else
-      return ()

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

+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE BinaryLiterals #-}
+{-# LANGUAGE RankNTypes #-}
+-- The BlockCache stores the currently fetched blocks
+-- and is consulted first to avoid requesting too much
+-- from the debuggee. The BlockCache can either be populated
+-- via a call to RequestBlocks or on demand on a cache miss.
+
+module GHC.Debug.Client.BlockCache(BlockCache, BlockCacheRequest(..)
+                                  , handleBlockReq, emptyBlockCache, bcSize, addBlocks) where
+
+import GHC.Debug.Types.Ptr
+import GHC.Debug.Types
+import qualified Data.HashMap.Strict as HM
+import GHC.Word
+import Data.Hashable
+import Data.IORef
+import Data.Bits
+import Data.List (sort)
+import Data.Binary
+import Control.Tracer
+
+newtype BlockCache = BlockCache (HM.HashMap Word64 RawBlock)
+
+instance Binary BlockCache where
+  get = BlockCache . HM.fromList <$> get
+  put (BlockCache hm) = put (HM.toList hm)
+
+emptyBlockCache :: BlockCache
+emptyBlockCache = BlockCache HM.empty
+
+addBlock :: RawBlock -> BlockCache -> BlockCache
+addBlock rb@(RawBlock (BlockPtr bp) _ _) (BlockCache bc) =
+  BlockCache (HM.insert bp rb bc)
+
+
+addBlocks :: [RawBlock] -> BlockCache -> BlockCache
+addBlocks bc bs = Prelude.foldr addBlock bs bc
+
+lookupClosure :: ClosurePtr -> BlockCache -> Maybe RawBlock
+lookupClosure (ClosurePtr cp) (BlockCache b) =
+  HM.lookup (cp .&. complement blockMask) b
+
+bcSize :: BlockCache -> Int
+bcSize (BlockCache b) = HM.size b
+
+_bcKeys :: BlockCache -> [ClosurePtr]
+_bcKeys (BlockCache b) = sort $ map mkClosurePtr (HM.keys b)
+
+data BlockCacheRequest a where
+  LookupClosure :: ClosurePtr -> BlockCacheRequest RawClosure
+  PopulateBlockCache :: BlockCacheRequest [RawBlock]
+
+deriving instance Show (BlockCacheRequest a)
+deriving instance Eq (BlockCacheRequest a)
+
+instance Hashable (BlockCacheRequest a) where
+  hashWithSalt s (LookupClosure cpt) = s `hashWithSalt` (1 :: Int) `hashWithSalt` cpt
+  hashWithSalt s PopulateBlockCache  = s `hashWithSalt` (2 :: Int)
+
+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
+               Nothing -> do
+                  rb <- do_req (RequestBlock cp)
+                  atomicModifyIORef' ref (\bc' -> (addBlock rb bc', ()))
+                  return rb
+               Just rb -> do
+                 return rb
+  return (extractFromBlock cp rb)
+handleBlockReq tracer do_req ref PopulateBlockCache = do
+  blocks <- do_req RequestAllBlocks
+--  mapM_ (\rb -> print ("NEW", rawBlockAddr rb)) blocks
+  traceWith tracer $ "Populating block cache with " ++ show (length blocks) ++ " blocks"
+  atomicModifyIORef' ref ((,()) . addBlocks blocks)
+  return blocks
+
+
+

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

+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+module GHC.Debug.Client.Monad
+  ( DebugMonad(..)
+  , run
+  , DebugM
+  , Debuggee
+  , traceWrite
+  , runTrace
+    -- * 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
+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
+
+newtype Debuggee = Debuggee { debuggeeEnv :: DebugEnv DebugM }
+
+runTrace :: Debuggee -> DebugM a -> IO a
+runTrace (Debuggee e) act = do
+  (r, ws) <- runDebugTrace e act
+  mapM_ putStrLn ws
+  return r
+
+traceWrite :: DebugMonad m => Show a => a -> m ()
+traceWrite = traceMsg . show
+
+-- | Run a @DebugM a@ in the given environment.
+run :: Debuggee -> DebugM a -> IO a
+run (Debuggee d) = runDebug d
+
+-- | Bracketed version of @debuggeeRun@. Runs a debuggee, connects to it, runs
+-- the action, kills the process, then closes the debuggee.
+withDebuggeeRun :: FilePath  -- ^ path to executable to run as the debuggee
+                -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
+                -> (Debuggee -> IO a)
+                -> IO a
+withDebuggeeRun exeName socketName action = do
+    -- Start the process we want to debug
+    cp <- debuggeeProcess exeName socketName
+    withCreateProcess cp $ \_ _ _ _ -> do
+    -- Now connect to the socket the debuggeeProcess just started
+      withDebuggeeConnect socketName action
+
+-- | Bracketed version of @debuggeeConnect@. Connects to a debuggee, runs the
+-- action, then closes the debuggee.
+withDebuggeeConnect :: FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
+                    -> (Debuggee -> IO a)
+                    -> IO a
+withDebuggeeConnect socketName action = do
+    new_env <- debuggeeConnect socketName
+    action new_env
+      `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"@)
+            -> IO Debuggee
+debuggeeRun exeName socketName = do
+    -- Start the process we want to debug
+    _ <- createProcess =<< debuggeeProcess exeName socketName
+    -- 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.
+debuggeeConnectWithTracer
+                :: Tracer IO String
+                -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
+                -> IO Debuggee
+debuggeeConnectWithTracer tracer socketName = do
+    s <- socket AF_UNIX Stream defaultProtocol
+    connect s (SockAddrUnix socketName)
+    hdl <- socketToHandle s ReadWriteMode
+    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 = 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'.
+snapshotRun :: FilePath -> (Debuggee -> IO a) -> IO a
+snapshotRun fp k = do
+  denv <- snapshotInit fp
+  k denv
+
+-- | Close the connection to the debuggee.
+debuggeeClose :: Debuggee -> IO ()
+debuggeeClose d = run d $ request RequestResume
+
+debuggeeProcess :: FilePath -> FilePath -> IO CreateProcess
+debuggeeProcess exe sockName = do
+  e <- getEnvironment
+  return $
+    (proc exe []) { env = Just (("GHC_DEBUG_SOCKET", sockName) : e) }
+
+outputRequestLog :: Debuggee -> IO ()
+outputRequestLog = printRequestLog @DebugM . debuggeeEnv
+

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

+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+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
+  type DebugEnv m
+  request :: (Show resp, Typeable resp) => Request resp -> m resp
+  requestBlock :: (Show resp, Typeable resp) => BlockCacheRequest resp -> m resp
+  traceMsg :: String -> m ()
+  printRequestLog :: DebugEnv m -> IO ()
+  runDebug :: DebugEnv m -> m a -> IO a
+  runDebugTrace :: DebugEnv m -> m a -> IO (a, [String])
+  newEnv :: Tracer IO String -> Mode -> IO (DebugEnv m)
+
+  saveCache :: FilePath -> m ()
+  loadCache :: FilePath -> m ()
+
+  unsafeLiftIO :: IO a -> m a
+
+
+data Mode = SnapshotMode FilePath | SocketMode Handle

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

+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RecordWildCards #-}
+-- | This module provides a simple implementation, which can be a lot faster if
+-- network latency is not an issue.
+module GHC.Debug.Client.Monad.Simple
+  ( Debuggee
+  , DebugM(..)
+  , runSimple
+  ) where
+
+import Control.Concurrent
+import GHC.Debug.Types
+import qualified Data.HashMap.Strict as HM
+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
+import GHC.Debug.Client.Monad.Class
+
+import Control.Monad.Fix
+import Control.Monad.Reader
+import Data.Binary
+--import Debug.Trace
+
+
+data Debuggee = Debuggee { -- Keep track of how many of each request we make
+                           debuggeeRequestCount :: Maybe (IORef (HM.HashMap CommandId FetchStats))
+                         , debuggeeBlockCache :: IORef BlockCache
+                         , debuggeeRequestCache :: MVar RequestCache
+                         , debuggeeHandle :: Maybe (MVar Handle)
+                         , debuggeeTrace :: Tracer IO String
+                         }
+
+data FetchStats = FetchStats { _networkRequests :: !Int, _cachedRequests :: !Int }
+
+logRequestIO :: Bool -> IORef (HM.HashMap CommandId FetchStats) -> Request resp -> IO ()
+logRequestIO cached hmref req =
+  atomicModifyIORef' hmref ((,()) . HM.alter alter_fn (requestCommandId req))
+
+  where
+    alter_fn = Just . maybe emptyFetchStats upd_fn
+    emptyFetchStats = FetchStats 1 0
+    upd_fn (FetchStats nr cr)
+      | cached = FetchStats nr (cr + 1)
+      | otherwise = FetchStats (nr + 1) cr
+
+logRequest :: Bool -> Request resp -> ReaderT Debuggee IO ()
+logRequest cached req = do
+  mhm <- asks debuggeeRequestCount
+  case mhm of
+    Just hm -> liftIO $ logRequestIO cached hm req
+    Nothing -> return ()
+
+ppRequestLog :: HM.HashMap CommandId FetchStats -> String
+ppRequestLog hm = unlines (map row items)
+  where
+    row (cid, FetchStats net cache) = unwords [show cid ++ ":", show net, show cache]
+    items = sortBy (comparing fst) (HM.toList hm)
+
+data Snapshot = Snapshot {
+                    _version :: Word32
+                  , _rqc :: RequestCache
+                  }
+
+snapshotVersion :: Word32
+snapshotVersion = 0
+
+instance Binary Snapshot where
+  get = do
+    v <- get
+    if v == snapshotVersion
+      then Snapshot v <$> get
+      else fail ("Wrong snapshot version.\nGot: " ++ show v ++ "\nExpected: " ++ show snapshotVersion)
+  put (Snapshot v c1) = do
+    put v
+    put c1
+
+
+instance DebugMonad DebugM where
+  type DebugEnv DebugM = Debuggee
+  request = DebugM . simpleReq
+  requestBlock = blockReq
+  traceMsg s = DebugM $ do
+    Debuggee{..} <- ask
+    liftIO $ traceWith debuggeeTrace s
+
+  printRequestLog e = do
+    case debuggeeRequestCount e of
+      Just hm_ref -> do
+        readIORef hm_ref >>= putStrLn . ppRequestLog
+      Nothing -> putStrLn "No request log in Simple(TM) mode"
+  runDebug = runSimple
+  runDebugTrace e a = (,[]) <$> runDebug e a
+  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
+    Debuggee{..} <- ask
+    _old_rc <- lift $ swapMVar debuggeeRequestCache new_req_cache
+    -- Fill up the block cache with the cached blocks
+    let block_c = initBlockCacheFromReqCache new_req_cache
+    lift $ writeIORef debuggeeBlockCache block_c
+
+  saveCache fp = DebugM $ do
+    Debuggee{..} <- ask
+    Just req_cache <- lift $ tryReadMVar debuggeeRequestCache
+    lift $ encodeFile fp (Snapshot snapshotVersion req_cache)
+
+  unsafeLiftIO f = DebugM $ liftIO f
+
+
+initBlockCacheFromReqCache :: RequestCache -> BlockCache
+initBlockCacheFromReqCache new_req_cache  =
+  addBlocks (lookupBlocks new_req_cache) emptyBlockCache
+
+
+
+runSimple :: Debuggee -> DebugM a -> IO a
+runSimple d (DebugM a) = runReaderT a d
+
+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 trace_msg
+
+mkHandleEnv :: Tracer IO String -> Handle -> IO Debuggee
+mkHandleEnv trace_msg h = mkEnv trace_msg (emptyRequestCache, emptyBlockCache) (Just h)
+
+mkSnapshotEnv :: Tracer IO String -> FilePath -> IO Debuggee
+mkSnapshotEnv trace_msg fp = do
+  Snapshot _ req_c <- decodeFile fp
+  let block_c = initBlockCacheFromReqCache req_c
+  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.
+simpleReq :: Request resp -> ReaderT Debuggee IO resp
+simpleReq req | isWriteRequest req = ask >>= \Debuggee{..} -> liftIO $ withWriteRequest req (error "non-write") $ \wreq -> do
+  case debuggeeHandle of
+    Just h -> do
+      atomicModifyIORef' debuggeeBlockCache (const (emptyBlockCache, ()))
+      modifyMVar_ debuggeeRequestCache (return . clearMovableRequests)
+      doRequest h wreq
+    -- Ignore write requests in snapshot mode
+    Nothing -> return ()
+simpleReq req = do
+  rc_var <- asks debuggeeRequestCache
+  rc <- liftIO $ readMVar rc_var
+  case lookupReq req rc of
+    Just res -> do
+      logRequest True req
+      return res
+    Nothing -> do
+      mh <- asks debuggeeHandle
+      case mh of
+        Nothing -> error ("Cache Miss:" ++ show req)
+        Just h -> do
+          res <- liftIO $ doRequest h req
+          liftIO $ modifyMVar_ rc_var (return . cacheReq req res)
+          logRequest False req
+          return res
+
+blockReq :: BlockCacheRequest resp -> DebugM resp
+blockReq req = DebugM $ do
+  bc  <- asks debuggeeBlockCache
+  tracer  <- asks debuggeeTrace
+  env <- ask
+  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
+                    deriving (MonadFail, Functor, Applicative, Monad, MonadFix)
+
+

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

+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DerivingVia #-}
+module GHC.Debug.Client.Query
+  ( -- * Pause/Resume
+    pause
+  , fork
+  , pauseThen
+  , resume
+  , pausePoll
+  , withPause
+
+  -- * General Requests
+  , precacheBlocks
+  , gcRoots
+  , allBlocks
+  , getSourceInfo
+  , savedObjects
+  , requestCCSMain
+  , version
+
+  -- * Dereferencing functions
+  , dereferenceClosures
+  , dereferenceClosure
+  , dereferenceClosureDirect
+  , dereferenceClosureC
+  , dereferenceToClosurePtr
+  , addConstrDesc
+  , dereferenceStack
+  , dereferencePapPayload
+  , dereferenceConDesc
+  , dereferenceInfoTable
+  , dereferenceSRT
+  , dereferenceCCS
+  , dereferenceCCSDirect
+  , dereferenceCC
+  , dereferenceIndexTable
+  , dereferenceIndexTableDirect
+  ) where
+
+import           Control.Exception
+import           GHC.Debug.Types
+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 Debug.Trace
+
+-- | Pause the debuggee
+pause :: Debuggee -> IO ()
+pause e = do
+  run e $ request (RequestPause Pause)
+
+fork :: Debuggee -> IO ()
+fork e = do
+  run e $ request (RequestPause Fork)
+
+-- | Resume the debuggee
+resume :: Debuggee -> IO ()
+resume e = run e $ request RequestResume
+
+-- | Like pause, but wait for the debuggee to pause itself. It currently
+-- impossible to resume after a pause caused by a poll.?????????? Is that true???? can we not just call resume????
+pausePoll :: Debuggee -> IO ()
+pausePoll e = do
+  run e $ request RequestPoll
+
+-- | Bracketed version of pause/resume.
+withPause :: Debuggee -> IO a -> IO a
+withPause dbg act = bracket_ (pause dbg) (resume dbg) act
+
+
+lookupInfoTable :: RawClosure -> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure)
+lookupInfoTable rc = do
+    let ptr = getInfoTblPtr 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 =
+  pause e >> run e d
+
+
+dereferenceClosureC :: ClosurePtr -> DebugM SizedClosureC
+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
+-- doing. 'dereferenceClosure' will be much faster in general.
+dereferenceClosureDirect :: ClosurePtr -> DebugM SizedClosure
+dereferenceClosureDirect c = do
+    raw_c <- request (RequestClosure c)
+    let it = getInfoTblPtr raw_c
+    raw_it <- request (RequestInfoTable it)
+    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
+
+-- | Deference some StackFrames from a given 'StackCont'
+dereferenceStack :: StackCont -> DebugM StackFrames
+dereferenceStack (StackCont sp stack) = do
+--  req_stack <- request (RequestStack (coerce cp))
+  let get_bitmap o = request (RequestStackBitmap sp o)
+      get_info_table rc = (\(a, _, _) -> a) <$> lookupInfoTable rc
+--  traceShowM ("BAD", printStack stack, rawStackSize stack)
+--  traceShowM ("GOOD", printStack req_stack, rawStackSize req_stack)
+  decodeStack get_info_table get_bitmap stack
+
+-- | Derference the PapPayload from the 'PayloadCont'
+dereferencePapPayload :: PayloadCont -> DebugM PapPayload
+dereferencePapPayload (PayloadCont fp raw) = do
+  bm <- request (RequestFunBitmap (fromIntegral $ length raw) fp)
+  return $ GenPapPayload (evalState (traversePtrBitmap decodeField bm) raw)
+  where
+    getWord = do
+      v <- gets head
+      modify tail
+      return v
+
+    decodeField True  = SPtr . mkClosurePtr <$> getWord
+    decodeField False = SNonPtr <$> getWord
+
+
+dereferenceConDesc :: ConstrDescCont -> DebugM ConstrDesc
+dereferenceConDesc i = request (RequestConstrDesc i)
+
+_noConDesc :: ConstrDescCont -> DebugM ConstrDesc
+_noConDesc c = traceShow c (return emptyConDesc)
+
+emptyConDesc :: ConstrDesc
+emptyConDesc = ConstrDesc "" "" ""
+
+{-
+-- | Print out the number of request made for each request type
+traceRequestLog :: Env u w -> IO ()
+traceRequestLog d = do
+  s <- readIORef (statsRef d)
+  putStrLn (ppStats s)
+
+traceProfile :: Env u w -> IO ()
+traceProfile e = do
+  p <- readIORef (profRef e)
+  print (profile p)
+  -}
+
+-- | Consult the 'BlockCache' for the block which contains a specific
+-- closure, if it's not there then try to fetch the right block, if that
+-- fails, call 'dereferenceClosureDirect'
+dereferenceClosure :: ClosurePtr -> DebugM SizedClosure
+dereferenceClosure cp
+  | not (heapAlloced cp) = dereferenceClosureDirect cp
+  | otherwise = do
+      rc <-  requestBlock (LookupClosure cp)
+      if rawClosureSize rc < 8
+        then do
+          res <- dereferenceClosureDirect cp
+          traceShowM ("Warning!!: block decoding failed, report this as a bug:" ++ show (cp, res))
+          return res
+        else do
+          let it = getInfoTblPtr rc
+          st_it <- request (RequestInfoTable it)
+          decodeClosure (it, st_it) (cp, rc)
+
+-- | Fetch all the blocks from the debuggee and add them to the block cache
+precacheBlocks :: DebugM [RawBlock]
+precacheBlocks = requestBlock PopulateBlockCache
+
+-- | Query the debuggee for the list of GC Roots
+gcRoots :: DebugM [ClosurePtr]
+gcRoots = request RequestRoots
+
+-- | Query the debuggee for all the blocks it knows about
+allBlocks :: DebugM [RawBlock]
+allBlocks = request RequestAllBlocks
+
+-- | Query the debuggee for source information about a specific info table.
+-- This requires your executable to be built with @-finfo-table-map@.
+getSourceInfo :: InfoTablePtr -> DebugM (Maybe SourceInformation)
+getSourceInfo = request . RequestSourceInfo
+
+-- | Query the debuggee for the list of saved objects.
+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 = 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

+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GADTs #-}
+module GHC.Debug.Client.RequestCache(RequestCache
+                                    , cacheReq
+                                    , lookupReq
+                                    , lookupBlocks
+                                    , emptyRequestCache
+                                    , clearMovableRequests
+                                    , putCache
+                                    , getCache ) where
+
+import qualified Data.HashMap.Strict as HM
+import GHC.Debug.Types
+import Unsafe.Coerce
+import Data.Binary
+import Control.Monad
+
+newtype RequestCache = RequestCache (HM.HashMap AnyReq AnyResp)
+
+instance Binary RequestCache where
+  get = getCache
+  put = putCache
+
+cacheReq :: Request resp -> resp -> RequestCache -> RequestCache
+cacheReq req resp (RequestCache rc)
+  -- Don't cache the results of writes, such as pause/unpause
+  | isWriteRequest req = RequestCache rc
+  | otherwise = RequestCache (HM.insert (AnyReq req) (AnyResp resp (putResponseBinary req)) rc)
+
+lookupReq :: forall resp . Request resp -> RequestCache -> Maybe resp
+lookupReq req (RequestCache rc) = coerceResult <$> HM.lookup (AnyReq req) rc
+  where
+    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
+
+-- These get/put functions are a lot like the ones for serialising info
+-- to/from the debuggee but we are careful that each one reads a bounded
+-- amount of input.
+
+getResponseBinary :: Request a -> Get a
+getResponseBinary RequestVersion       = Version <$> get <*> get <*> getProfilingMode <*> get
+getResponseBinary (RequestPause {})    = get
+getResponseBinary RequestResume        = get
+getResponseBinary RequestRoots         = get
+getResponseBinary (RequestClosure {}) = get
+getResponseBinary (RequestInfoTable{}) = getInfoTable
+getResponseBinary (RequestSRT {}) = get
+getResponseBinary (RequestStackBitmap {}) = get
+getResponseBinary (RequestFunBitmap {}) = get
+getResponseBinary (RequestConstrDesc _)  = getConstrDescCache
+getResponseBinary RequestPoll          = get
+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 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 (RequestSRT {}) rcs = put rcs
+putResponseBinary (RequestStackBitmap {}) pbm = put pbm
+putResponseBinary (RequestFunBitmap {}) pbm = put pbm
+putResponseBinary (RequestConstrDesc _) cd  = putConstrDescCache cd
+putResponseBinary RequestPoll         r = put r
+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
+  put a
+  put b
+  put c
+
+getConstrDescCache :: Get ConstrDesc
+getConstrDescCache =
+  ConstrDesc <$> get <*> get <*> get
+
+putLine :: AnyReq -> AnyResp -> Put -> Put
+putLine (AnyReq req) (AnyResp resp p) k = putRequest req >> p resp >> k
+
+getCacheLine :: Get (AnyReq, AnyResp)
+getCacheLine = do
+  AnyReq req <- getRequest
+  resp <- getResponseBinary req
+  return (AnyReq req, AnyResp resp (putResponseBinary req))
+
+putCache :: RequestCache -> Put
+putCache (RequestCache rc) = do
+  put (HM.size rc)
+  HM.foldrWithKey putLine (return ()) rc
+
+getCache :: Get RequestCache
+getCache = do
+  n <- get
+  RequestCache . HM.fromList <$> replicateM n getCacheLine
+
+-- | Clear the part of the cache which will become invalid after pausing
+-- For example, we need to clear blocks, but can keep the info table
+-- caches.
+clearMovableRequests :: RequestCache -> RequestCache
+clearMovableRequests (RequestCache rc) = RequestCache (HM.filterWithKey (\(AnyReq r) _ -> isImmutableRequest r) rc)

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

+module GHC.Debug.Client.Search(module GHC.Debug.Client.Search, HeapGraph(..), HeapGraphEntry(..)) where
+
+import GHC.Debug.Types
+import GHC.Debug.Types.Graph
+import qualified Data.IntMap as IM
+
+-- Find all entries in the HeapGraph matching a specific predicate
+findClosures :: (HeapGraphEntry a -> Bool) -> HeapGraph a -> [HeapGraphEntry a]
+findClosures f = go
+  where
+    go (HeapGraph _ gs) =
+      IM.foldl' (\hges hge -> if f hge then hge:hges else hges) [] gs
+
+findConstructors :: String -> HeapGraph a -> [HeapGraphEntry a]
+findConstructors con_name hg = findClosures predicate hg
+    where
+      predicate h = checkConstrTable (hgeClosure h)
+
+      checkConstrTable (ConstrClosure _ _ _ _ (ConstrDesc _ _ n)) = n == con_name
+      checkConstrTable _ = False
+
+findWithInfoTable :: InfoTablePtr -> HeapGraph a -> [HeapGraphEntry a]
+findWithInfoTable itp = findClosures p
+  where
+    p = (itp ==) . tableId . info . hgeClosure

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 (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 Control.Monad.State
+import Control.Monad.Reader
+import Data.IORef
+
+parCount :: [ClosurePtr] -> DebugM CensusStats
+parCount = traceParFromWithState (justClosuresPar clos) . map (ClosurePtrWithInfo ())
+  where
+    clos :: WorkerId -> ClosurePtr -> SizedClosure -> ()
+              -> DebugM ((), CensusStats, DebugM () -> DebugM ())
+    clos _ cp sc _ = do
+      return ((), mkCS cp (dcSize sc), id)
+
+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 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) mempty
+  where
+    funcs = justClosures closAccum
+
+    closAccum  :: ClosurePtr
+               -> SizedClosure
+               ->  (StateT CensusStats DebugM) ()
+               ->  (StateT CensusStats DebugM) ()
+    closAccum cp s k = do
+      modify' (go cp s)
+      k
+
+    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/Dominators.hs

+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module GHC.Debug.Dominators (computeDominators
+                                   , retainerSize
+                                   , convertToHeapGraph
+                                   , annotateWithRetainerSize ) where
+
+import Data.Maybe       ( catMaybes, fromJust )
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import GHC.Debug.Types.Ptr
+import GHC.Debug.Types.Closures
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Foldable as F
+import qualified Data.Graph.Dom as DO
+import qualified Data.Tree as Tree
+import GHC.Debug.Types.Graph
+
+
+
+-- Dominators
+closurePtrToInt :: ClosurePtr -> Int
+closurePtrToInt (ClosurePtr p) = fromIntegral p
+
+intToClosurePtr :: Int -> ClosurePtr
+intToClosurePtr i = mkClosurePtr (fromIntegral i)
+
+convertToDom :: HeapGraph a -> DO.Rooted
+convertToDom  (HeapGraph groots is) = (0, new_graph)
+  where
+    rootNodes = IS.fromList (map closurePtrToInt (NE.toList groots))
+    new_graph = IM.insert 0 rootNodes (IM.foldlWithKey' collectNodes IM.empty is)
+    collectNodes newMap k h =  IM.insert k (IS.fromList (map closurePtrToInt (catMaybes (allClosures (hgeClosure h))))) newMap
+
+computeDominators :: HeapGraph a -> [Tree.Tree (HeapGraphEntry a)]
+computeDominators hg = map (fmap (fromJust . flip lookupHeapGraph hg . intToClosurePtr)) gentries
+  where
+    gentries = case DO.domTree (convertToDom hg) of
+                Tree.Node 0 es -> es
+                _ -> error "Dominator tree must contain 0"
+
+retainerSize :: HeapGraph Size -> [Tree.Tree (HeapGraphEntry (Size, RetainerSize))]
+retainerSize hg = map bottomUpSize doms
+  where
+    doms = computeDominators hg
+
+annotateWithRetainerSize :: HeapGraph Size -> HeapGraph (Size, RetainerSize)
+annotateWithRetainerSize h@(HeapGraph rs _) =
+  HeapGraph rs (foldMap convertToHeapGraph (retainerSize h))
+
+bottomUpSize :: Tree.Tree (HeapGraphEntry Size) -> Tree.Tree (HeapGraphEntry (Size, RetainerSize))
+bottomUpSize (Tree.Node rl sf) =
+  let ts = map bottomUpSize sf
+      s'@(Size s) =  hgeData rl
+      RetainerSize children_size = foldMap (snd . hgeData . Tree.rootLabel) ts
+      inclusive_size :: RetainerSize
+      !inclusive_size = RetainerSize  (s + children_size)
+      rl' = rl { hgeData = (s', inclusive_size) }
+  in Tree.Node rl' ts
+
+convertToHeapGraph ::  Tree.Tree (HeapGraphEntry a) -> IM.IntMap (HeapGraphEntry a)
+convertToHeapGraph t = IM.fromList ([(fromIntegral cp, c) | c <- F.toList t, let ClosurePtr cp = hgeClosurePtr c ])
+
+
+