ghc-debug-client (empty) → 0.1.0.0

raw patch · 25 files changed

+2705/−0 lines, 25 filesdep +asyncdep +basedep +binarysetup-changed

Dependencies added: async, base, binary, bitwise, containers, directory, dom-lt, eventlog2html, filepath, ghc-debug-common, ghc-debug-convention, ghc-prim, hashable, haxl, language-dot, monoidal-containers, mtl, network, process, psqueues, stm, text, unordered-containers

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• ghc-debug-client.cabal +68/−0
• src/GHC/Debug/Client.hs +124/−0
• src/GHC/Debug/Client/BlockCache.hs +82/−0
• src/GHC/Debug/Client/Monad.hs +127/−0
• src/GHC/Debug/Client/Monad/Class.hs +26/−0
• src/GHC/Debug/Client/Monad/Haxl.hs +183/−0
• src/GHC/Debug/Client/Monad/Simple.hs +186/−0
• src/GHC/Debug/Client/Query.hs +185/−0
• src/GHC/Debug/Client/RequestCache.hs +111/−0
• src/GHC/Debug/Client/Search.hs +25/−0
• src/GHC/Debug/Count.hs +46/−0
• src/GHC/Debug/Dominators.hs +65/−0
• src/GHC/Debug/Fragmentation.hs +139/−0
• src/GHC/Debug/GML.hs +120/−0
• src/GHC/Debug/ObjectEquiv.hs +178/−0
• src/GHC/Debug/ParTrace.hs +258/−0
• src/GHC/Debug/Profile.hs +211/−0
• src/GHC/Debug/Profile/Types.hs +21/−0
• src/GHC/Debug/Retainers.hs +77/−0
• src/GHC/Debug/Snapshot.hs +46/−0
• src/GHC/Debug/Trace.hs +103/−0
• src/GHC/Debug/TypePointsFrom.hs +287/−0

@@ -0,0 +1,5 @@+# Revision history for ghc-debug-client++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright (c) 2019, Ben Gamari++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ben Gamari nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,68 @@+cabal-version:       3.0+name:                ghc-debug-client+version:             0.1.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, 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++library+  exposed-modules:     GHC.Debug.Client,+                       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.TypePointsFrom,+                       GHC.Debug.Snapshot,+                       GHC.Debug.Dominators,+                       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.Haxl,+                       GHC.Debug.Client.Monad.Simple++  build-depends:       base >=4.16 && < 4.17,+                       network >= 2.6 ,+                       containers ^>= 0.6,+                       unordered-containers ^>= 0.2.13,+                       ghc-debug-common ^>= 0.1,+                       ghc-debug-convention ^>= 0.1,+                       text ^>= 1.2.4,+                       process ^>= 1.6,+                       filepath ^>= 1.4,+                       directory ^>= 1.3,+                       bitwise ^>= 1.0,+                       haxl ^>= 2.3,+                       hashable ^>= 1.3,+                       mtl ^>= 2.2,+                       eventlog2html >= 0.8.3,+                       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++  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  ApplicativeDo+  ghc-options:         -Wall

@@ -0,0 +1,124 @@+{- | 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 "") h)+@++-}+module GHC.Debug.Client+  ( -- * 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+  , dereferenceClosures+  , dereferenceStack+  , dereferencePapPayload+  , dereferenceConDesc+  , dereferenceInfoTable++  , Quadtraversable(..)++  -- * 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+  , HG.StackHI+  , HG.PapHI+  , HG.HeapGraphIndex+  ) where++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)++derefFuncM :: HG.DerefFunction DebugM Size+derefFuncM c = do+  c' <- dereferenceClosure c+  quadtraverse dereferencePapPayload dereferenceConDesc 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+

@@ -0,0 +1,82 @@+{-# 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++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 :: (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 do_req ref PopulateBlockCache = do+  blocks <- do_req RequestAllBlocks+--  mapM_ (\rb -> print ("NEW", rawBlockAddr rb)) blocks+  print ("CACHING", length blocks)+  atomicModifyIORef' ref ((,()) . addBlocks blocks)+  return blocks+++

@@ -0,0 +1,127 @@+{-# 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+  , debuggeeRun+  , debuggeeConnect+  , debuggeeClose+  -- * Snapshot run+  , snapshotInit+  , snapshotRun+    -- * Logging+  , outputRequestLog+  ) where++import Control.Exception (finally)+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.Haxl as H+import qualified GHC.Debug.Client.Monad.Simple as S+import System.IO++-- Modify this to switch between the haxl/non-haxl implementations+-- type DebugM = H.DebugM+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++-- | 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++-- | Connect to a debuggee on the given socket. Use @debuggeeClose@ when you're done.+debuggeeConnect :: FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)+                -> IO Debuggee+debuggeeConnect socketName = do+    s <- socket AF_UNIX Stream defaultProtocol+    connect s (SockAddrUnix socketName)+    hdl <- socketToHandle s ReadWriteMode+    new_env <- newEnv @DebugM (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)++-- | 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+

@@ -0,0 +1,26 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+module GHC.Debug.Client.Monad.Class where++import Data.Typeable+import GHC.Debug.Client.BlockCache+import GHC.Debug.Types+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 :: Mode -> IO (DebugEnv m)++  saveCache :: FilePath -> m ()+  loadCache :: FilePath -> m ()++  unsafeLiftIO :: IO a -> m a+++data Mode = SnapshotMode FilePath | SocketMode Handle

@@ -0,0 +1,183 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module GHC.Debug.Client.Monad.Haxl+  ( Debuggee(..)+  , Request(..)+  , DebugM+  , Env(..)+  ) where++import GHC.Debug.Types+import qualified Data.HashMap.Strict as HM+import System.IO+import Control.Concurrent++import GHC.Debug.Client.BlockCache+import GHC.Debug.Client.Monad.Class++import Haxl.Core hiding (Request, env)+import Data.Typeable++import Data.IORef++data Debuggee = Debuggee { -- Keep track of how many of each request we make+                           debuggeeRequestCount :: IORef (HM.HashMap CommandId Int)+                         , debuggeeBatchMode :: BatchMode+                         }++data BatchMode = Batch | OneByOne deriving (Eq, Show)++instance DebugMonad (GenHaxl Debuggee String) where+  type DebugEnv (GenHaxl Debuggee String) = Env Debuggee String+  request = dataFetch+  requestBlock = dataFetch+  traceMsg = tellWrite+  printRequestLog = traceRequestLog+  runDebug = runHaxl+  runDebugTrace = runHaxlWithWrites+  newEnv args =+    case args of+      SnapshotMode _e -> error "Loading from snapshot not supported"+      SocketMode h -> mkEnv h++  saveCache = error "TODO"+  loadCache = error "TODO"+  unsafeLiftIO = error "TODO"++type DebugM = GenHaxl Debuggee String+++{- MP:+- In some profiles it seemed that the caching step was causing quite a bit+- of overhead, but still using the cache is about 2-3x faster than without+- a cache. (ie using `doRequest` directly or `uncachedRequest`.+-}++-- | Send a request to a 'Debuggee' paused with 'withPause'.+--request :: (Show resp, Typeable resp) => Request resp -> DebugM resp+--request = dataFetch+++instance StateKey Request where+  data State Request = RequestState (MVar Handle)++instance DataSourceName Request where+  dataSourceName Proxy = "ghc-debug"++instance ShowP Request where+  showp = show++{-+-- | Group together RequestClosures and RequestInfoTables to avoid+-- some context switching.+groupFetches :: MVar Handle -> [([ClosurePtr], ResultVar [RawClosure])] -> [([InfoTablePtr], ResultVar [(StgInfoTableWithPtr, RawInfoTable)])] -> [BlockedFetch Request] -> [BlockedFetch Request] -> IO ()+groupFetches h cs is todo [] = dispatch h cs is (reverse todo)+groupFetches h cs is todo (b@(BlockedFetch r resp) : bs) =+  case r of+    RequestInfoTables is' -> groupFetches h cs ((is', resp):is) todo bs+    RequestClosures cs' -> groupFetches h ((cs', resp):cs) is todo bs+    _ -> groupFetches h cs is (b:todo) bs++dispatch :: MVar Handle+         -> [([ClosurePtr], ResultVar [RawClosure])]+         -> [([InfoTablePtr], ResultVar [(StgInfoTableWithPtr, RawInfoTable)])]+         -> [BlockedFetch Request]+         -> IO ()+dispatch h cs its other = do+  mapM_ do_one other+  -- These can be used to inspect how much batching is happening+--  print ("BATCHED_CLOSURES", length cs, map fst cs)+--  print (length its, map fst its)+  do_many RequestClosures cs+  do_many RequestInfoTables its+  where+    do_one (BlockedFetch req resp) = do+      res <- doRequest h req+      putSuccess resp res++    do_many :: ([a] -> Request [b]) -> [([a], ResultVar [b])] -> IO ()+    do_many _ [] = return ()+    do_many mk_req ms = do+      let req = mk_req (concatMap fst ms)+      results <- doRequest h req+      recordResults results ms++++-- | Write the correct number of results to each result var+recordResults :: [a] -> [([b], ResultVar [a])] -> IO ()+recordResults [] [] = return ()+recordResults res ((length -> n, rvar):xs) =+  putSuccess rvar here >> recordResults later xs+  where+    (here, later) = splitAt n res+recordResults _ _ = error ("Impossible recordResults")+-}++_singleFetches :: MVar Handle -> [BlockedFetch Request] -> IO ()+_singleFetches h bs = mapM_ do_one bs+      where+        do_one (BlockedFetch req resp) = do+          res <- doRequest h req+          putSuccess resp res++instance DataSource Debuggee Request where+  fetch (RequestState h) _fs u =+    -- Grouping together fetches only shaves off about 0.01s on the simple+    -- benchmark+    SyncFetch $+      case debuggeeBatchMode u of+        --Batch -> groupFetches h [] [] []+        _ -> _singleFetches h++++instance StateKey BlockCacheRequest where+  data State BlockCacheRequest = BCRequestState (IORef BlockCache) (MVar Handle)++instance DataSourceName BlockCacheRequest where+  dataSourceName Proxy = "block-cache"++instance ShowP BlockCacheRequest where+  showp = show+++instance DataSource u BlockCacheRequest where+  fetch (BCRequestState ref h) _fs _u =+    SyncFetch (mapM_ do_one)+    where+      do_one :: BlockedFetch BlockCacheRequest -> IO ()+      do_one (BlockedFetch bcr resp) = do+        res <- handleBlockReq (doRequest h) ref bcr+        putSuccess resp res++++mkEnv :: Handle -> IO (Env Debuggee String)+mkEnv hdl = do+  requestMap <- newIORef HM.empty+  bc <- newIORef emptyBlockCache+  mhdl <- newMVar hdl+  let ss = stateSet (BCRequestState bc mhdl) (stateSet (RequestState mhdl) stateEmpty)+  new_env <- initEnv ss (Debuggee requestMap Batch)+  -- Turn on data fetch stats with report = 3+  let new_flags = defaultFlags { report = 0 }+  return $ new_env { Haxl.Core.flags = new_flags }++-- | 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)

@@ -0,0 +1,186 @@+{-# 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 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)+                         }++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 = DebugM . liftIO . putStrLn+  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 m = case m of+               SnapshotMode f -> mkSnapshotEnv f+               SocketMode h -> mkHandleEnv 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  =+  case lookupReq RequestAllBlocks new_req_cache of+        Just bs -> addBlocks bs emptyBlockCache+        Nothing -> 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+  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++mkHandleEnv :: Handle -> IO Debuggee+mkHandleEnv h = mkEnv (emptyRequestCache, emptyBlockCache) (Just h)++mkSnapshotEnv :: FilePath -> IO Debuggee+mkSnapshotEnv fp = do+  Snapshot _ req_c <- decodeFile fp+  let block_c = initBlockCacheFromReqCache req_c+  mkEnv (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+  env <- ask+  liftIO $ handleBlockReq (\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)++

@@ -0,0 +1,185 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DerivingVia #-}+module GHC.Debug.Client.Query+  ( -- * Pause/Resume+    pause+  , fork+  , pauseThen+  , resume+  , pausePoll+  , withPause++  -- * General Requests+  , precacheBlocks+  , gcRoots+  , allBlocks+  , getSourceInfo+  , savedObjects+  , version++  -- * Dereferencing functions+  , dereferenceClosures+  , dereferenceClosure+  , dereferenceClosureDirect+  , dereferenceClosureC+  , dereferenceStack+  , dereferencePapPayload+  , dereferenceConDesc+  , dereferenceInfoTable++  ) where++import           Control.Exception+import           GHC.Debug.Types+import           GHC.Debug.Decode+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++-- | 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+    (itbl, rit) <- request (RequestInfoTable ptr)+    return (itbl,rit, rc)++pauseThen :: Debuggee -> DebugM b -> IO b+pauseThen e d =+  pause e >> run e d+++dereferenceClosureC :: ClosurePtr -> DebugM SizedClosureC+dereferenceClosureC cp = do+  c <- dereferenceClosure cp+  quadtraverse pure 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)+    return $ decodeClosure raw_it (c, raw_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)+      let it = getInfoTblPtr rc+      st_it <- request (RequestInfoTable it)+      return $ decodeClosure 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++-- | Query the debuggee for the protocol version+version :: DebugM Word32+version = request RequestVersion++dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable+dereferenceInfoTable it = decodedTable . fst <$> request (RequestInfoTable it)+

@@ -0,0 +1,111 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+module GHC.Debug.Client.RequestCache(RequestCache+                                    , cacheReq+                                    , lookupReq+                                    , 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+import Data.Binary.Put+import Data.Binary.Get++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++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       = getWord32be+getResponseBinary (RequestPause {})    = get+getResponseBinary RequestResume        = get+getResponseBinary RequestRoots         = get+getResponseBinary (RequestClosure {}) = get+getResponseBinary (RequestInfoTable itps) =+      (\(it, r) -> (StgInfoTableWithPtr itps it, r)) <$> getInfoTable+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++putResponseBinary :: Request a -> a -> Put+putResponseBinary RequestVersion w = putWord32be w+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 (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++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)

@@ -0,0 +1,25 @@+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

@@ -0,0 +1,46 @@+module GHC.Debug.Count 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+++parCount :: [ClosurePtr] -> DebugM CensusStats+parCount = traceParFromM funcs . map (ClosurePtrWithInfo ())+  where+    nop = const (return ())+    funcs = TraceFunctionsIO nop nop clos (const (const (return mempty))) nop++    clos :: ClosurePtr -> SizedClosure -> ()+              -> DebugM ((), CensusStats, DebugM () -> DebugM ())+    clos _cp sc _ = do+      return ((), mkCS (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)+  where+    funcs = TraceFunctions {+               papTrace = const (return ())+              , stackTrace = const (return ())+              , closTrace = closAccum+              , visitedVal = const (return ())+              , conDescTrace = const (return ())++            }++    closAccum  :: ClosurePtr+               -> SizedClosure+               ->  (StateT CensusStats DebugM) ()+               ->  (StateT CensusStats DebugM) ()+    closAccum _cp s k = do+      modify' (go s)+      k++    go :: SizedClosure -> CensusStats -> CensusStats+    go sc cs = mkCS (dcSize sc) <> cs

@@ -0,0 +1,65 @@+{-# 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 ])+++

@@ -0,0 +1,139 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Functions for analysing memory fragmentation+module GHC.Debug.Fragmentation (summariseBlocks+                                     , censusByMBlock+                                      , printMBlockCensus+                                      , censusByBlock+                                      , printBlockCensus+                                      , censusPinnedBlocks+                                      , PinnedCensusStats(..)++                                      , findBadPtrs+                                      , histogram+                                      ) where++import GHC.Debug.Profile+import GHC.Debug.Client+import GHC.Debug.Types+--import GHC.Debug.Client.Monad++import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.List (nub, sortBy)+import Data.Ord+import Data.Word++-- | Print a summary of the given raw blocks+-- This is useful to see how many MBlocks and how many pinned blocks there+-- are.+summariseBlocks :: [RawBlock] -> IO ()+summariseBlocks bs = do+  putStrLn ("TOTAL BLOCKS: " ++ show (length bs))+  putStrLn ("PINNED BLOCKS: " ++ show (length $ filter isPinnedBlock bs))+  putStrLn ("MBLOCK: " ++ show n_mblocks)+  putStrLn ("PINNED MBLOCKS: " ++ show n_pmblocks)+  where+    n_mblocks :: Int+    n_mblocks = length (nub (map (blockMBlock . rawBlockAddr) bs))++    n_pmblocks = length (nub (map (blockMBlock . rawBlockAddr) (filter isPinnedBlock bs)))++-- | Perform a heap census by which MBlock each closure lives in+censusByMBlock :: [ClosurePtr] -> DebugM (Map.Map BlockPtr CensusStats)+censusByMBlock = closureCensusBy go+  where+    go cp d =+      let s :: Size+          s = dcSize d+          v =  mkCS s++          k :: BlockPtr+          k = applyMBlockMask cp+      in if heapAlloced cp+           then return $ Just (k, v)+           -- Ignore static things+           else return $ Nothing++-- | Perform a census based on which block each closure resides in.+censusByBlock :: [ClosurePtr] -> DebugM (Map.Map BlockPtr CensusStats)+censusByBlock = closureCensusBy go+  where+    go cp d =+      let s :: Size+          s = dcSize d+          v =  mkCS s++          k = applyBlockMask cp+      in if heapAlloced cp+           then return $ Just (k, v)+           -- Ignore static things+           else return Nothing++newtype PinnedCensusStats =+          PinnedCensusStats (CensusStats, [(ClosurePtr, SizedClosure)])+          deriving (Semigroup)++-- | Only census the given (pinned) blocks+censusPinnedBlocks :: [RawBlock]+                   -> [ClosurePtr]+                   -> DebugM (Map.Map BlockPtr PinnedCensusStats)+censusPinnedBlocks bs = closureCensusBy go+  where+    pbs = Set.fromList (map rawBlockAddr (filter isPinnedBlock bs))+    go :: ClosurePtr -> SizedClosure+          -> DebugM (Maybe (BlockPtr, PinnedCensusStats))+    go cp d =+      let v :: CensusStats+          v = mkCS (dcSize d)++          bp = applyBlockMask cp++      in return $ if bp `Set.member` pbs+           then Just (bp, PinnedCensusStats (v, [(cp, d)]))+           -- Ignore static things+           else Nothing+++-- | Given a pinned block census, find the ARR_WORDS objects which are in the+-- blocks which are < 10 % utilised. The return list is sorted by how many+-- times each distinct ARR_WORDS appears on the heap.+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+          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)+          dups = map swap (reverse $ sortBy (comparing snd) (Map.toList (Map.fromListWith (<>) all_arr_words)))+      in dups++displayArrWords :: SizedClosure -> String+displayArrWords d =+    case noSize d of+      ArrWordsClosure { arrWords } -> show (arrWordsBS arrWords)+      _ -> error "Not ARR_WORDS"++printMBlockCensus, printBlockCensus ::  Map.Map BlockPtr CensusStats -> IO ()+printMBlockCensus = histogram mblockMaxSize . Map.elems+-- | Print out a block census+printBlockCensus = histogram blockMaxSize . Map.elems++-- | Print either a MBlock or Block census as a histogram+histogram :: Word64 -> [CensusStats] -> IO ()+histogram maxSize m =+  mapM_ (putStrLn . displayLine) (bin 0 (map calcPercentage (sortBy (comparing cssize) m )))+  where+    calcPercentage (CS _ (Size tot) _) =+      ((fromIntegral tot/ fromIntegral maxSize) * 100 :: Double)++    displayLine (l, h, n) = show l ++ "%-" ++ show h ++ "%: " ++ show n++    bin _ [] = []+    bin k xs = case now of+                 [] -> bin (k + 10) later+                 _ -> (k, k+10, length now) : bin (k + 10) later+      where+        (now, later) = span ((<= k + 10)) xs+

@@ -0,0 +1,120 @@+module GHC.Debug.GML (writeTpfToGML, addSourceInfo, typePointsFromToGML) where++import GHC.Debug.TypePointsFrom as TPF+import GHC.Debug.Types (SourceInformation(..))+import GHC.Debug.Types.Closures (Size(..))+import GHC.Debug.Profile.Types (CensusStats(..), Count(..))+import GHC.Debug.Client.Monad+import GHC.Debug.Client.Query (getSourceInfo, gcRoots)++import Data.Map as Map+import Data.Int (Int32)+import Data.Semigroup+import qualified Data.Map.Monoidal.Strict as MMap+import qualified Data.Foldable as F++import System.IO++type SourceInfoMap = Map.Map TPF.Key SourceInformation++typePointsFromToGML :: FilePath -> Debuggee -> IO ()+typePointsFromToGML path e = do+  (tpf, infoMap) <- run e $ do+    roots <- gcRoots+    tpf <- TPF.typePointsFrom roots+    si <- addSourceInfo tpf+    return (tpf, si)+  writeTpfToGML path tpf infoMap++-- | Exports TypePointsFrom graph to a GML file+addSourceInfo :: TypePointsFrom -> DebugM SourceInfoMap+addSourceInfo tpf = do+    -- Generate a map of InfoTablePtr to SourceInformation pairs+    let ptrs = MMap.keys . TPF.nodes $ tpf+    infos <- mapM getSourceInfo ptrs++    let kvPairs :: [(TPF.Key, SourceInformation)]+        kvPairs = do+          (k, Just si) <- zip ptrs infos+          return (k, si)++        infoMap :: SourceInfoMap+        infoMap = Map.fromList kvPairs++    return (infoMap)+++writeTpfToGML :: FilePath -> TPF.TypePointsFrom -> SourceInfoMap -> IO ()+writeTpfToGML path tpf infoMap = do+  outHandle <- openFile path WriteMode+  writeGML outHandle+  hClose outHandle+  where+    ixMap :: Map.Map TPF.Key Int32+    ixMap = Map.fromList $ zip ((MMap.keys . nodes) tpf) [1..]++    lookupId :: TPF.Key -> Int32+    lookupId key' = case Map.lookup key' ixMap of+      Nothing -> error "This shouldn't happen, see function ixMap"+      Just i -> i++    writeGML :: Handle -> IO ()+    writeGML outHandle = do+      let nodesKvPairs = MMap.assocs . TPF.nodes $ tpf+          edgesKvPairs = MMap.assocs . TPF.edges $ tpf++      -- Beginning of GML file+      hPutStrLn stderr $ "Writing to file " <> path <> "..."+      writeOpenGML++      F.forM_ nodesKvPairs (uncurry writeNode)+      F.forM_ edgesKvPairs (uncurry writeEdge)++      writeCloseGML+      hPutStrLn stderr $ "Finished writing to GML file..."+      -- End of GML file+      where+        write = hPutStr outHandle++        writeOpenGML =+          write $ "graph[\n"+            <> "comment \"this is a graph in GML format\"\n"+            <> "directed 1\n"++        writeCloseGML =+          write $ "]\n"++        writeNode :: TPF.Key -> CensusStats -> IO ()+        writeNode key' cs =+          write $ "node [\n"+            <> "id " <> showPtr key' <> "\n"+            <> gmlShowCensus cs+            <> gmlShowSourceInfo key'+            <> "]\n"++        writeEdge :: TPF.Edge -> CensusStats -> IO ()+        writeEdge edge cs =+          write $ "edge [\n"+            <> "source " <> (showPtr . TPF.edgeSource) edge <> "\n"+            <> "target " <> (showPtr . TPF.edgeTarget) edge <> "\n"+            <> gmlShowCensus cs+            <> "]\n"++        gmlShowCensus :: CensusStats -> String+        gmlShowCensus (CS (Count c) (Size s) (Max (Size m))) =+          "count " <> show c <> "\n"+          <> "size " <> show s <> "\n"+          <> "max " <> show m <> "\n"++        gmlShowSourceInfo :: TPF.Key -> String+        gmlShowSourceInfo key = case Map.lookup key infoMap of+          Nothing -> mempty+          Just si -> "infoName \"" <> infoName si <> "\"\n"+            <> "infoClosureType \"" <> (show . infoClosureType) si <> "\"\n"+            <> "infoType \"" <> infoType si <> "\"\n"+            <> "infoLabel \"" <> infoLabel si <> "\"\n"+            <> "infoModule \"" <> infoModule si <> "\"\n"+            <> "infoPosition \"" <> infoPosition si <> "\"\n"++        showPtr :: TPF.Key -> String+        showPtr = show . lookupId

@@ -0,0 +1,178 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ViewPatterns #-}+-- | Attempt to find duplicate objects on the heap. The analysis is not+-- exact but attempts to find closures which are identical, and could be+-- shared.+module GHC.Debug.ObjectEquiv(objectEquiv, objectEquivAnalysis, printObjectEquiv, EquivMap) where++import GHC.Debug.Client.Monad+import GHC.Debug.Client+import GHC.Debug.Trace+import GHC.Debug.Profile+import GHC.Debug.Types.Graph (ppClosure)+import GHC.Debug.Types(ClosurePtr(..))++import Control.Monad.State+import Data.List (sortBy)+import Data.Ord+import Debug.Trace+import qualified Data.OrdPSQ as PS+import qualified Data.IntMap.Strict as IM+import Data.List.NonEmpty(NonEmpty(..))++type CensusByObjectEquiv = IM.IntMap CensusStats++-- | How big to allow the priority queue to grow to+limit :: Int+limit = 100_000+-- | How many times an object must appear per 100 000 closures to be+-- "interesting" and kept for the future.+of_interest :: Int+of_interest = 1000++-- Pick a representative ClosurePtr for each object+type EquivMap = PS.OrdPSQ PtrClosure -- Object+                           Int+                           ClosurePtr -- Representative of equivalence class++type Equiv2Map = IM.IntMap -- Pointer+                  ClosurePtr -- Representative of equivalence class++data ObjectEquivState = ObjectEquivState  {+                            emap   :: !EquivMap+                          , emap2 :: !Equiv2Map+                          , _census :: !CensusByObjectEquiv+                          }+-- Don't need to add identity mapping in emap2 because lookup failure is+-- the identity anyway.+addEquiv :: ClosurePtr -> PtrClosure -> ObjectEquivState -> ObjectEquivState+addEquiv cp pc (trimMap -> o) =+                  let (res, new_m) = PS.alter g pc (emap o)+                      new_emap2 = case res of+                                     Left _ -> emap2 o+                                     -- Only remap objects which have a hit+                                     -- in the cache+                                     Right new_cp -> addNewMap cp new_cp (emap2 o)+                  in ( o { emap = new_m+                      , emap2 = new_emap2 })+  where+    g Nothing = (Left cp, Just (0, cp))+    g (Just (p, v)) = (Right v, Just (p + 1, v))++addNewMap :: ClosurePtr -> ClosurePtr -> Equiv2Map -> Equiv2Map+addNewMap (ClosurePtr cp) equiv_cp o = IM.insert (fromIntegral cp) equiv_cp o++-- Trim down map to keep objects which have only been seen 100 times or+-- more within the last 10 000 seen objects+trimMap :: ObjectEquivState -> ObjectEquivState+trimMap o = if checkSize o > limit+              then let new_o = o { emap = snd $ PS.atMostView of_interest (emap o) }+                   in traceShow (checkSize new_o) new_o+                   -- TODO: Here would be good to also keep everything+                   -- which is referenced by the kept closures, otherwise+                   -- you end up with duplicates in the map++              else o++-- | O(1) due to psqueues implementation+checkSize :: ObjectEquivState -> Int+checkSize (ObjectEquivState e1 _ _) = PS.size e1++type PtrClosure = DebugClosureWithSize 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 ())++            }+    -- Add cos+    closAccum  :: ClosurePtr+               -> SizedClosure+               -> (StateT ObjectEquivState DebugM) ()+               -> (StateT ObjectEquivState DebugM) ()+    closAccum cp s k = do+      -- Step 0: Check to see whether there is already an equivalence class+      -- 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+      -- 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'+      -- Step 3: Have we seen a closure like this one before?+      modify' (addEquiv cp s'')++{-+        -- Yes, we have seen something of identical shape+        -- 1. Update equivalence maps to map this closure into the right+        -- equivalence class+        Just new_cp -> do+          n <- checkSize <$> lift get+          traceShowM n+          lift $ modify' (addNewMap cp new_cp)+          return new_cp+          --+        -- No, never seen something like this before+        -- Add the mapping to emap+        Nothing -> do+          lift $ modify' (addNewEquiv cp s'')+          return cp+          -}++      -- Step 4: Update the census, now we know the equivalence class of+      -- the object+      --lift $ modify' (go new_cp s'')+      -- Step 5: Call the continuation to carry on with the analysis+      k++    rep_c cp@(ClosurePtr k) = do+      m <- gets emap2+      case IM.lookup (fromIntegral k) m of+        -- There is an equivalence class already+        Just cp' -> return cp'+        -- No equivalence class yet+        Nothing -> return cp++printObjectEquiv :: EquivMap -> IO ()+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)]+  mapM_ (putStrLn . showLine) res+--  writeFile "profile/profile_out.txt" (unlines $ "key, total, count, max, avg" : (map showLine res))++objectEquivAnalysis :: DebugM (EquivMap, HeapGraph Size)+objectEquivAnalysis = do+  precacheBlocks+  rs <- gcRoots+  traceWrite (length rs)+  r1 <- emap <$> censusObjectEquiv rs+  let elems = snd $ PS.atMostView of_interest r1+      cmp (_, b,_) = b+      cps = map (\(_, _, cp) -> cp) (sortBy (flip (comparing cmp)) (PS.toList elems))+  -- Use this code if we are returning ClosurePtr not SourceInformation+  r2 <- case cps of+    [] -> error "None"+    (c:cs) -> multiBuildHeapGraph (Just 10) (c :| cs)+  return (r1, r2)++objectEquiv :: Debuggee -> IO ()+objectEquiv = runAnalysis objectEquivAnalysis $ \(rmap, hg) -> do+                                                    printObjectEquiv rmap+                                                    putStrLn $ ppHeapGraph show hg

@@ -0,0 +1,258 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE NumericUnderscores #-}+{-# 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+-- future.+--+-- 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++import           GHC.Debug.Types+import           GHC.Debug.Client.Query++import qualified Data.IntMap as IM+import Data.Array.BitArray.IO hiding (map)+import Control.Monad.Reader+import Data.Word+import GHC.Debug.Client.Monad.Simple+import Control.Concurrent.Async+import Data.IORef+import Control.Exception.Base+import Debug.Trace+import Control.Concurrent.STM++threads :: Int+threads = 64++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)++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+++-- | Map from Thread -> Information about the thread+type ThreadMap a = IM.IntMap (ThreadInfo a)++newtype TraceState a = TraceState { visited :: (ThreadMap a) }+++getKeyTriple :: ClosurePtr -> (Int, Int, Word16)+getKeyTriple cp =+  let BlockPtr raw_bk = applyBlockMask cp+      bk = fromIntegral raw_bk `div` 8+      offset = getBlockOffset cp `div` 8+      BlockPtr raw_mbk = applyMBlockMask cp+      mbk = fromIntegral raw_mbk `div` 8+  in (mbk, bk, fromIntegral offset)++getMBlockKey :: ClosurePtr -> Int+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++sendToChan :: TraceState a -> ClosurePtrWithInfo a -> DebugM ()+sendToChan  ts cpi@(ClosurePtrWithInfo _ cp) = DebugM $ liftIO $ do+  let st = visited ts+      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++initThread :: Monoid s =>+              Int+           -> TraceFunctionsIO a s+           -> DebugM (ThreadInfo a, STM Bool, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))+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+      finished = do+        active <- not <$> readTVar worker_active+        empty  <- isEmptyTChan ic+        return (active && empty)++  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+  d <- ask+  r <- liftIO $ newIORef (ThreadState IM.empty ref)+  liftIO $ runSimple d (loop r)+  where+    loop r = do+      mcp <- unsafeLiftIO $ try $ do+              atomically $ writeTVar worker_active False+              atomically $ do+                v <- readTChan oc+                writeTVar worker_active True+                return v+      case mcp of+        -- The thread gets blocked on readChan when the work is finished so+        -- when this happens, catch the exception and return the accumulated+        -- 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+        Right cpi -> deref r cpi >> loop r++    deref r (ClosurePtrWithInfo a cp) = do+        m <- unsafeLiftIO $ readIORef r+        do+          (m', b) <- unsafeLiftIO $ checkVisit cp m+          unsafeLiftIO $ writeIORef r m'+          if b+            then do+              s <- visitedVal k cp a+              unsafeLiftIO $ modifyIORef' ref (s <>)+            else do+              sc <- dereferenceClosure cp+              (a', s, cont) <- closTrace k cp sc a+              unsafeLiftIO $ modifyIORef' ref (s <>)+              cont (() <$ quadtraverse (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)++    goc r c@(ClosurePtrWithInfo _i cp) =+      let mkey = getMBlockKey cp+      in if (mkey == n)+          then deref r c+          else go c++    -- Just do the other dereferencing in the same thread for other closure+    -- types as they are not as common.+    gos r a st = do+      st' <- dereferenceStack st+      stackTrace k st'+      () <$ traverse (goc r . ClosurePtrWithInfo a) st'++    gocd d = do+      cd <- dereferenceConDesc d+      conDescTrace k cd++    gop r a p = do+      p' <- dereferencePapPayload p+      papTrace k p'+      () <$ traverse (goc r . ClosurePtrWithInfo a) p'+++handleBlockLevel :: IM.Key+                    -> Word16+                    -> IM.IntMap (IOBitArray Word16)+                    -> IO (IM.IntMap (IOBitArray Word16), Bool)++handleBlockLevel bk offset m = do+  case IM.lookup bk m of+    Nothing -> do+      na <- newArray (0, fromIntegral (blockMask `div` 8)) False+      writeArray na offset True+      return (IM.insert bk na m, False)+    Just bm -> do+      res <- readArray bm offset+      unless res (writeArray bm offset True)+      return (m, res)++checkVisit :: ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)+checkVisit cp st = do+  let (mbk, bk, offset) = getKeyTriple cp+      ThreadState v ref = 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)+    Just bm -> do+      (st', res) <- handleBlockLevel bk offset bm+      return (ThreadState (IM.insert mbk st' v) ref, res)++++++data TraceFunctionsIO a s =+      TraceFunctionsIO { papTrace :: !(GenPapPayload ClosurePtr -> DebugM ())+      , stackTrace :: !(GenStackFrames ClosurePtr -> DebugM ())+      , closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))+      , visitedVal :: !(ClosurePtr -> a -> DebugM s)+      , conDescTrace :: !(ConstrDesc -> DebugM ())+      }+++-- | A generic heap traversal function which will use a small amount of+-- memory linear in the heap size. Using this function with appropiate+-- 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 functions given in 'TraceFunctionsIO' content for the handle+-- connecting for the debuggee (which is protected by an 'MVar'). With no+-- contention, and precached blocks, the workload can be very evenly+-- distributed leading to high core utilisation.+--+-- As performance depends highly on contention, snapshot mode is much more+-- amenable to parrelisation where the time taken for requests is much+-- lower.+traceParFromM :: Monoid s => TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s+traceParFromM k cps = do+  traceM ("SPAWNING: " ++ show threads)+  (init_mblocks, work_actives, start)  <- unzip3 <$> mapM (\b -> do+                                    (ti, working, start) <- initThread 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+  unsafeLiftIO $ waitFinish work_actives+  unsafeLiftIO $ mapM_ cancel as+  unsafeLiftIO $ mconcat <$> mapM wait as++waitFinish :: [STM Bool] -> IO ()+waitFinish working = atomically (checkDone working)+  where+    checkDone [] = return ()+    checkDone (x:xs) = do+      b <- x+      -- The variable tracks whether the thread thinks it's finished (no+      -- active work and empty chan)+      if b then checkDone xs else retry++-- | A parellel tracing function.+tracePar :: [ClosurePtr] -> DebugM ()+tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ())+  where+    nop = const (return ())+    funcs = TraceFunctionsIO nop nop clos (const (const (return ()))) nop++    clos :: ClosurePtr -> SizedClosure -> ()+              -> DebugM ((), (), DebugM () -> DebugM ())+    clos _cp sc _ = do+      let itb = info (noSize sc)+      _traced <- getSourceInfo (tableId itb)+      return ((), (), id)++

@@ -0,0 +1,211 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RecordWildCards #-}+{- | Functions for performing whole heap census in the style of the normal+- heap profiling -}+module GHC.Debug.Profile( profile+                        , censusClosureType+                        , census2LevelClosureType+                        , closureCensusBy+                        , CensusByClosureType+                        , writeCensusByClosureType+                        , CensusStats(..)+                        , mkCS+                        , Count(..)+                        , closureToKey ) where++import GHC.Debug.Client.Monad+import GHC.Debug.Client+import GHC.Debug.Trace+import GHC.Debug.ParTrace+import GHC.Debug.Profile.Types++import qualified Data.Map.Strict as Map+import Control.Monad.State+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.Semigroup+import qualified Data.Text as T+import qualified Data.Map.Monoidal.Strict as MMap++++type CensusByClosureType = Map.Map Text 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+      let siz :: Size+          siz = dcSize d+          v =  mkCS siz+      return $ Just (closureToKey (noSize d), v)++++closureToKey :: DebugClosure 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))))+++-- | General function for performing a heap census in constant memory+closureCensusBy :: forall k v . (Semigroup v, Ord k)+                => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))+                -> [ClosurePtr] -> DebugM (Map.Map k v)+closureCensusBy f cps = do+  () <$ precacheBlocks+  MMap.getMonoidalMap <$> traceParFromM funcs (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+               -> SizedClosure+               -> ()+               -> DebugM ((), MMap.MonoidalMap k v, a -> a)+    closAccum cp s () = do+      r <- f cp s+      return . (\s' -> ((), s', id)) $ case r of+        Just (k, v) -> MMap.singleton k v+        Nothing -> MMap.empty++-- | Perform a 2-level census where the keys are the type of the closure+-- in addition to the type of ptrs of the closure. This can be used to+-- distinguish between lists of different type for example.+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 ())++            }+    -- Add cos+    closAccum  :: ClosurePtr+               -> SizedClosure+               -> (StateT CensusByClosureType DebugM) ()+               -> (StateT CensusByClosureType DebugM) ()+    closAccum _ s k = do+      s' <- lift $ quadtraverse dereferencePapPayload dereferenceConDesc dereferenceStack pure s+      pts <- lift $ mapM dereferenceClosure (allClosures (noSize s'))+      pts' <- lift $ mapM (quadtraverse pure dereferenceConDesc pure pure) pts+++      modify' (go 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))++{-+-- | Parallel heap census+parCensus :: [RawBlock] -> [ClosurePtr] -> DebugM (Map.Map Text CensusStats)+parCensus bs cs =  do+  MMap.getMonoidalMap <$> (traceParFromM bs funcs (map (ClosurePtrWithInfo ()) cs))++  where+    nop = const (return ())+    funcs = TraceFunctionsIO nop nop clos  (const (const (return mempty))) nop++    clos :: ClosurePtr -> SizedClosure -> ()+              -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ())+    clos _cp sc () = do+      d <- quadtraverse pure dereferenceConDesc pure pure sc+      let s :: Size+          s = dcSize sc+          v =  mkCS s+      return $ ((), MMap.singleton (closureToKey (noSize d)) v, id)+      -}+++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)+++-- | Peform a profile at the given interval (in seconds), the result will+-- be rendered after each iteration using @eventlog2html@.+profile :: FilePath -> Int -> Debuggee -> IO ()+profile outpath interval e = loop [(0, Map.empty)] 0+  where+    loop :: [(Int, CensusByClosureType)] -> Int -> IO ()+    loop ss i = do+      threadDelay (interval * 1_000_000)+      pause e+      r <- runTrace e $ do+        precacheBlocks+        rs <- gcRoots+        traceWrite (length rs)+        census2LevelClosureType rs+      resume e+      writeCensusByClosureType outpath r+      let new_data = ((i + 1) * interval, r) : ss+      renderProfile new_data+      loop new_data (i + 1)+++mkFrame :: (Int, CensusByClosureType) -> Frame+mkFrame (t, m) = Frame (fromIntegral t / 10e6) (Map.foldrWithKey (\k v r -> mkSample k v : r) [] m)++mkSample :: Text -> CensusStats -> Sample+mkSample k (CS _ (Size v) _) =+  Sample (Bucket k) (fromIntegral v)++mkProfData :: [(Int, CensusByClosureType)] -> ProfData+mkProfData raw_fs =+  let fs = map mkFrame raw_fs+      (counts, totals) = total fs+      -- Heap profiles don't contain any other information than the simple bucket name+      binfo = Map.mapWithKey (\(Bucket k) (t,s,g) -> BucketInfo k Nothing t s g) totals+  -- Heap profiles do not support traces+      header = Header "ghc-debug" "" (Just HeapProfBreakdownClosureType) "" "" "" counts Nothing+  in ProfData header binfo mempty fs [] (HeapInfo [] [] []) mempty++renderProfile :: [(Int, CensusByClosureType)] -> IO ()+renderProfile ss = do+  let pd = mkProfData ss+  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 ()++

@@ -0,0 +1,21 @@+{-# LANGUAGE DerivingVia #-}+module GHC.Debug.Profile.Types where++import           GHC.Debug.Types+import Data.Monoid+import Data.Semigroup++newtype Count = Count Int+                deriving (Semigroup, Monoid, Num) via Sum Int+                deriving (Show, Ord, Eq)++data CensusStats = CS { cscount :: !Count, cssize :: !Size, csmax :: !(Max Size) } deriving (Show, Eq)++mkCS :: Size -> CensusStats+mkCS i = CS (Count 1) i (Max i)++instance Monoid CensusStats where+  mempty = CS mempty mempty (Max (Size 0))++instance Semigroup CensusStats where+  (CS a b c) <> (CS a1 b1 c1) = CS (a <> a1) (b <> b1) (c <> c1)

@@ -0,0 +1,77 @@+-- | Functions for computing retainers+module GHC.Debug.Retainers(findRetainersOf, findRetainers, addLocationToStack, displayRetainerStack) where++import GHC.Debug.Client+import Control.Monad.State+import GHC.Debug.Trace+import GHC.Debug.Types.Graph++import qualified Data.Set as Set+import Control.Monad.RWS++addOne :: [ClosurePtr] -> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])+addOne _ (Just 0, cp) = (Just 0, cp)+addOne cp (n, cps)    = (subtract 1 <$> n, cp:cps)++findRetainersOf :: Maybe Int+                -> [ClosurePtr]+                -> [ClosurePtr]+                -> DebugM [[ClosurePtr]]+findRetainersOf limit cps bads = findRetainers limit cps (\cp _ -> return (cp `Set.member` bad_set))+  where+    bad_set = Set.fromList bads++-- | From the given roots, find any path to one of the given pointers.+-- Note: This function can be quite slow! The first argument is a limit to+-- how many paths to find. You should normally set this to a small number+-- such as 10.+findRetainers :: Maybe Int -> [ClosurePtr] -> (ClosurePtr -> SizedClosure -> DebugM Bool) -> DebugM [[ClosurePtr]]+findRetainers limit rroots p = (\(_, r, _) -> snd r) <$> runRWST (traceFromM funcs rroots) [] (limit, [])+  where+    funcs = TraceFunctions {+               papTrace = const (return ())+              , stackTrace = const (return ())+              , closTrace = closAccum+              , visitedVal = const (return ())+              , conDescTrace = const (return ())++            }+    -- Add clos+    closAccum  :: ClosurePtr+               -> SizedClosure+               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()+               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()+    closAccum cp sc k = do+      b <- lift $ p cp sc+      if b+        then do+          ctx <- ask+          modify' (addOne (cp: ctx))+          -- Don't call k, there might be more paths to the pointer but we+          -- probably just care about this first one.+        else do+          (lim, _) <- get+          case lim of+            Just 0 -> return ()+            _ -> local (cp:) k++addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureC, Maybe SourceInformation)]+addLocationToStack r = do+  cs <- dereferenceClosures r+  cs' <- mapM (quadtraverse pure dereferenceConDesc pure pure) cs+  locs <- mapM getSourceLoc cs'+  return $ (zip cs' locs)+  where+    getSourceLoc c = getSourceInfo (tableId (info (noSize c)))++displayRetainerStack :: [(String, [(SizedClosureC, Maybe SourceInformation)])] -> IO ()+displayRetainerStack rs = do+      let disp (d, l) =+            (ppClosure ""  (\_ -> show) 0 . noSize $ d) ++  " <" ++ maybe "nl" tdisplay l ++ ">"+            where+              tdisplay sl = infoType sl ++ ":" ++ infoModule sl ++ ":" ++ infoPosition sl+          do_one k (l, stack) = do+            putStrLn (show k ++ "-------------------------------------")+            print l+            mapM (putStrLn . disp) stack+      zipWithM_ do_one [0 :: Int ..] rs

@@ -0,0 +1,46 @@+-- | Functions for creating and running snapshots.+module GHC.Debug.Snapshot ( -- * Generating snapshots+                            snapshot+                          , makeSnapshot+                          -- * Using a snapshot+                          , snapshotRun+                          -- * Low level+                          , traceFrom ) where++import GHC.Debug.Trace+import GHC.Debug.ParTrace+import GHC.Debug.Client.Monad+import GHC.Debug.Client+import Control.Monad.Identity+import Control.Monad.Trans++-- | Make a snapshot of the current heap and save it to the given file.+snapshot :: FilePath -> DebugM ()+snapshot fp = do+  precacheBlocks+  rs <- gcRoots+  _so <- savedObjects+  tracePar rs+  saveCache fp++-- | Traverse the tree from GC roots, to populate the caches+-- with everything necessary.+traceFrom :: [ClosurePtr] -> DebugM ()+traceFrom cps = runIdentityT (traceFromM funcs cps)+  where+    nop = const (return ())+    funcs = TraceFunctions nop nop clos (const (return ())) nop++    clos :: ClosurePtr -> SizedClosure -> (IdentityT DebugM) ()+              ->  (IdentityT DebugM) ()+    clos _cp sc k = do+      let itb = info (noSize sc)+      _traced <- lift $ getSourceInfo (tableId itb)+      k++-- | Pause the process and create a snapshot of+-- the heap. The snapshot can then be loaded with+-- 'snapshotRun' in order to perform offline analysis.+makeSnapshot :: Debuggee -> FilePath -> IO ()+makeSnapshot e fp = runAnalysis (snapshot fp) (const (return ())) e+

@@ -0,0 +1,103 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE BangPatterns #-}+-- | Functions to support the constant space traversal of a heap.+module GHC.Debug.Trace ( traceFromM, TraceFunctions(..) ) where++import           GHC.Debug.Types+import GHC.Debug.Client.Monad+import           GHC.Debug.Client.Query++import qualified Data.IntMap as IM+import Data.Array.BitArray.IO+import Control.Monad.Reader+import Data.IORef+import Data.Word+import System.IO++newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16))++data TraceState = TraceState { visited :: !VisitedSet, n :: !Int }+++getKeyPair :: ClosurePtr -> (Int, Word16)+getKeyPair cp =+  let BlockPtr raw_bk = applyBlockMask cp+      bk = fromIntegral raw_bk `div` 8+      offset = getBlockOffset cp `div` 8+  in (bk, fromIntegral offset)++checkVisit :: ClosurePtr -> IORef TraceState -> IO Bool+checkVisit cp mref = do+  st <- readIORef mref+  let VisitedSet v = visited st+      num_visited = n st+      (bk, offset) = getKeyPair cp+  case IM.lookup bk v of+    Nothing -> do+      na <- newArray (0, fromIntegral (blockMask `div` 8)) False+      writeArray na offset True+      writeIORef mref (TraceState (VisitedSet (IM.insert bk na v)) (num_visited + 1))+      when (num_visited `mod` 10_000 == 0) $ hPutStrLn stderr ("Traced: " ++ show num_visited)+      return False+    Just bm -> do+      res <- readArray bm offset+      unless res (writeArray bm offset True)+      return res++++data TraceFunctions m =+      TraceFunctions { papTrace :: !(GenPapPayload ClosurePtr -> m DebugM ())+      , stackTrace :: !(GenStackFrames ClosurePtr -> m DebugM ())+      , closTrace :: !(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())+      , visitedVal :: !(ClosurePtr -> (m DebugM) ())+      , conDescTrace :: !(ConstrDesc -> m DebugM ())+      }+++++type C m = (MonadTrans m, Monad (m DebugM))++-- | A generic heap traversal function which will use a small amount of+-- memory linear in the heap size. Using this function with appropiate+-- accumulation functions you should be able to traverse quite big heaps in+-- not a huge amount of memory.+traceFromM :: C m => TraceFunctions m-> [ClosurePtr] -> m DebugM ()+traceFromM k cps = do+  st <- lift (unsafeLiftIO (newIORef (TraceState (VisitedSet IM.empty) 1)))+  runReaderT (mapM_ (traceClosureFromM k) cps) st+{-# INLINE traceFromM #-}+{-# INLINE traceClosureFromM #-}++traceClosureFromM :: C m+                  => TraceFunctions m+                  -> ClosurePtr+                  -> ReaderT (IORef TraceState) (m DebugM) ()+traceClosureFromM !k = go+  where+    go cp = do+      mref <- ask+      b <- lift $ lift $ unsafeLiftIO (checkVisit cp mref)+      if b+        then lift $ visitedVal k cp+        else do+        sc <- lift $ lift $ dereferenceClosure cp+        ReaderT $ \st -> closTrace k cp sc+         (runReaderT (() <$ quadtraverse gop gocd gos go sc) st)+++    gos st = do+      st' <- lift $ lift $ dereferenceStack st+      lift $ stackTrace k st'+      () <$ traverse go st'++    gocd d = do+      cd <- lift $ lift $ dereferenceConDesc d+      lift $ conDescTrace k cd++    gop p = do+      p' <- lift $ lift $ dereferencePapPayload p+      lift $ papTrace k p'+      () <$ traverse go p'

@@ -0,0 +1,287 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ViewPatterns #-}+{- | Type Points From analysis in the style of+- Cork: Dynamic Memory Leak Detectionfor Garbage-Collected Languages+- https://dl.acm.org/doi/10.1145/1190216.1190224+- -}+module GHC.Debug.TypePointsFrom( typePointsFrom+                               , detectLeaks+                               , TypePointsFrom(..)+                               , getNodes+                               , getEdges+                               , edgeSource+                               , edgeTarget+                               , Key+                               , Edge(..)+                               , getKey+                               ) where++import GHC.Debug.Client.Monad+import GHC.Debug.Client+import Control.Monad.State+import GHC.Debug.ParTrace+import GHC.Debug.Types.Ptr+import qualified Data.Map.Monoidal.Strict as Map+import Data.Map (Map)+import qualified Data.Map.Internal as M+import GHC.Debug.Profile+import Control.Monad.Identity+import Control.Concurrent+import Data.List (sortOn)+import Language.Dot+import qualified Data.Set as S+++type Key = InfoTablePtr++data Edge = Edge !Key !Key deriving (Eq, Ord, Show)++edgeSource :: Edge -> Key+edgeTarget :: Edge -> Key+edgeSource (Edge k1 _) = k1+edgeTarget (Edge _ k2) = k2++data TypePointsFrom = TypePointsFrom { nodes :: !(Map.MonoidalMap Key CensusStats)+                                      , edges :: !(Map.MonoidalMap Edge CensusStats)+                                      } deriving (Show)++getNodes :: TypePointsFrom -> Map Key CensusStats+getEdges :: TypePointsFrom -> Map Edge CensusStats+getNodes = Map.getMonoidalMap . nodes+getEdges = Map.getMonoidalMap . edges++instance Monoid TypePointsFrom where+  mempty = TypePointsFrom mempty mempty++instance Semigroup TypePointsFrom where+  (TypePointsFrom a1 a2) <> (TypePointsFrom b1 b2) = TypePointsFrom (a1 <> b1) (a2 <> b2)++singletonTPF :: Key -> CensusStats -> [(Edge, CensusStats)] -> TypePointsFrom+singletonTPF k s es = TypePointsFrom (Map.singleton k s)+                                  (Map.fromList es)++-- | Perform a "type points from" heap census+typePointsFrom :: [ClosurePtr] -> DebugM TypePointsFrom+typePointsFrom cs = traceParFromM funcs (map (ClosurePtrWithInfo Root) cs)++  where+    nop = const (return ())+    funcs = TraceFunctionsIO nop nop clos visit nop++    visit :: ClosurePtr -> Context -> DebugM TypePointsFrom+    visit cp ctx = do+      sc <- dereferenceClosure cp+      let k = tableId $ info (noSize sc)+          v = mkCS (dcSize sc)+          parent_edge = case ctx of+                          Root -> []+                          Parent pk -> [(Edge k pk, v)]+      return $ TypePointsFrom Map.empty (Map.fromList parent_edge)++++    clos :: ClosurePtr -> SizedClosure -> Context+              -> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())+    clos _cp sc ctx = do+      let k = tableId $ info (noSize sc)+      let s :: Size+          s = dcSize sc+          v =  mkCS s++          -- Edges point from the object TO what retains it+          parent_edge = case ctx of+                          Root -> []+                          Parent pk -> [(Edge k pk, v)]++      return (Parent k, singletonTPF k v parent_edge, id)+++data Context = Root | Parent Key+++-- | Repeatedly call 'typesPointsFrom' and perform the leak detection+-- analysis.+detectLeaks :: Int -> Debuggee -> IO ()+detectLeaks interval e = loop Nothing (M.empty, M.empty) 0+  where+    loop :: Maybe TypePointsFrom -> RankMaps -> Int -> IO ()+    loop prev_census rms i = do+      print i+      threadDelay (interval * 1_000_000)+      pause e+      (gs, r, new_rmaps) <- runTrace e $ do+        _ <- precacheBlocks+        rs <- gcRoots+        traceWrite (length rs)+        res <- typePointsFrom rs+        let !new_rmaps = case prev_census of+                           Nothing -> rms+                           Just pcensus -> updateRankMap rms pcensus res+        let cands = chooseCandidates (fst new_rmaps)+        traceWrite (length cands)+        gs <- mapM (findSlice (snd new_rmaps)) (take 10 cands)+        return (gs, res, new_rmaps)+      resume e+      zipWithM_ (\n g -> writeFile ("slices/"+                                      ++ show @Int i ++ "-"+                                      ++ show @Int n ++ ".dot")+                                   (renderDot g)) [0..] gs+      loop (Just r) new_rmaps (i + 1)+++-- Analysis code+--+getKey :: InfoTablePtr -> DebugM String+getKey itblp = do+    loc <- getSourceInfo itblp+    itbl <- dereferenceInfoTable itblp+    case loc of+      Nothing -> getKeyFallback itblp itbl+      Just s -> return $ show (tipe itbl) ++ ":" ++ renderSourceInfo s++getKeyFallback itbp itbl = do+    case tipe itbl of+      t | CONSTR <= t && t <= CONSTR_NOCAF   -> do+        ConstrDesc a b c <- dereferenceConDesc itbp+        return $ a ++ ":" ++ b ++ ":" ++ c+      _ -> return $ show (tipe itbl)++type Rank = Double+type Decay = Double++data RankInfo = RankInfo !Rank !Int deriving Show++getRank :: RankInfo -> Rank+getRank (RankInfo r _) = r++default_decay :: Decay+default_decay = 0.15++rank_threshold :: Double+rank_threshold = 100++min_iterations :: Int+min_iterations = 2++applyRankFilter :: RankInfo -> Bool+applyRankFilter (RankInfo r i) = r >= rank_threshold && i >= min_iterations++-- | Lookup suitable candidates from the RankMap+-- , Chooses values based on 'rank_threshold' and 'min_iterations'+lookupRM :: Key -> RankMap Edge -> [(Edge, RankInfo)]+lookupRM k m = M.assocs filtered_map+  where+    -- TODO, work out how to use these functions O(log n)+    --smaller =  traceShow (M.size m) (M.dropWhileAntitone ((/= k) . edgeSource) $ m)+    --res_map = traceShow (M.size smaller) (M.takeWhileAntitone ((== k) . edgeSource) smaller)+    (res_map, _) = M.partitionWithKey (\e _ -> (== k) . edgeSource $ e) m+    filtered_map = M.filter (\(RankInfo r _) -> r > 0) res_map++mkDotId :: InfoTablePtr -> Id+mkDotId (InfoTablePtr w) = IntegerId (fromIntegral w)++findSlice :: RankMap Edge -> Key -> DebugM Graph+findSlice rm k = Graph StrictGraph DirectedGraph (Just (mkDotId k)) <$> evalStateT (go 3 k) S.empty++  where++    go :: Int -> InfoTablePtr -> StateT (S.Set InfoTablePtr) DebugM [Statement]+    go n cur_k = do+      visited_set <- get+      -- But don't stop going deep until we've seen a decent number of+      -- nodes+      if S.member cur_k visited_set || (n <= 0 && S.size visited_set >= 20)+        then return []+        else do+          label <- lift $ getKey cur_k+          let next_edges = take 20 (lookupRM cur_k rm)+              -- Decoding very wide is bad+              edge_stmts = map mkEdge next_edges+              node_stmt = NodeStatement (NodeId (mkDotId cur_k) Nothing) [AttributeSetValue (StringId "label") (StringId label) ]+              mkEdge (Edge _ e, ri) = EdgeStatement [ENodeId NoEdge (NodeId (mkDotId cur_k) Nothing), ENodeId DirectedEdge (NodeId (mkDotId e) Nothing)] [AttributeSetValue (StringId "label") (StringId (show (getRank ri))) ]++          modify' (S.insert cur_k)+          ss <- concat <$> mapM (go (n-1) . edgeTarget . fst) next_edges+          return $ node_stmt : edge_stmts ++ ss++renderSourceInfo :: SourceInformation -> String+renderSourceInfo s = escapeQuotes (infoName s ++ ":" ++ infoType s ++ ":" ++ infoPosition s)++escapeQuotes :: String -> String+escapeQuotes [] = []+escapeQuotes ('"':xs) = '\\' : '"' : escapeQuotes xs+escapeQuotes (x:xs) = x:escapeQuotes xs+++chooseCandidates :: RankMap Key -> [Key]+chooseCandidates = map fst . reverse . sortOn (getRank . snd) . M.assocs . M.filter applyRankFilter++type RankMap k = M.Map k RankInfo++type RankMaps = (RankMap Key, RankMap Edge)++type RankUpdateMap k = M.Map k RankUpdateInfo++type RankUpdateInfo = Int -> Double -> Double++-- | Update the current rank predictions based on the difference between+-- two censuses.+updateRankMap :: (RankMap Key, RankMap Edge)+              -> TypePointsFrom+              -> TypePointsFrom+              -> (RankMap Key, RankMap Edge)+updateRankMap (rm_n, rm_e) t1 t2 = (ns, es)+  where+    !(rnodes, redges) = ratioRank t1 t2+    missingL = M.dropMissing+    missingR = M.mapMissing (\_ f -> RankInfo (f 0 0) 1)+    matched = M.zipWithMatched (\_ (RankInfo r iters) f -> RankInfo (f iters r) (iters + 1))++    !ns = runIdentity $ M.mergeA missingL missingR matched rm_n rnodes+    !es = runIdentity $ M.mergeA missingL missingR matched rm_e redges+++compareSize :: CensusStats -> CensusStats -> Maybe (Int -> Double -> Double)+compareSize (cssize -> Size s1) (cssize -> Size s2) =+  if fromIntegral s2 > (1 - default_decay) * fromIntegral s1+    -- Calculate "Q"+    then if s1 > s2+          -- Shrinking phase, penalise rank+          then Just (\phases rank ->+                      rank+                        - ((fromIntegral (phases + 1))+                            * ((fromIntegral s1 / fromIntegral s2) - 1)))+          else Just (\phases rank ->+                        rank ++                          ((fromIntegral (phases + 1))+                            * ((fromIntegral s2 / fromIntegral s1) - 1)))+    else Nothing++-- | Compute how to update the ranks based on the difference between two+-- censuses.+ratioRank :: TypePointsFrom -> TypePointsFrom -> (RankUpdateMap Key, RankUpdateMap Edge)+ratioRank t1 t2 = (candidates, redges)+  where+    ns1 = getNodes t1+    ns2 = getNodes t2++    es1 = getEdges t1+    es2 = getEdges t2+    missingL = M.dropMissing+    missingR = M.dropMissing+    matched = M.zipWithMaybeMatched (\_ cs1 cs2 -> compareSize cs1 cs2)+    !candidates = runIdentity $ M.mergeA missingL missingR matched ns1 ns2++    !redges = runIdentity $ M.mergeA missingL missingR matched es1 es2+++