ghc-debug-client 0.7.0.0 → 0.8.0.0

raw patch · 12 files changed

+610/−276 lines, 12 filesdep +transformersdep ~basedep ~containersdep ~ghc-debug-commonnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependency ranges changed: base, containers, ghc-debug-common, ghc-debug-convention, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−1
• ghc-debug-client.cabal +13/−11
• src/GHC/Debug/Async.hs +85/−0
• src/GHC/Debug/Client/BlockCache.hs +31/−14
• src/GHC/Debug/Count.hs +39/−9
• src/GHC/Debug/ParTrace.hs +168/−81
• src/GHC/Debug/Profile.hs +48/−64
• src/GHC/Debug/Retainers.hs +67/−23
• src/GHC/Debug/Strings.hs +69/−49
• src/GHC/Debug/Thunks.hs +57/−9
• src/GHC/Debug/Trace.hs +5/−7
• src/GHC/Debug/TypePointsFrom.hs +9/−8

@@ -1,5 +1,24 @@ # Revision history for ghc-debug-client +## 0.8.0.0 -- 2026-03-26++* Support non-moving segements and other large block groups+* Fix lower bound for text+* Improve thread safety and cancellation in parallel trace+* Update dependencies for ghc 9.14+* Add missing transformers bounds+* Extract ghc-debug-client async interface into separate module+* Implement asynchronous heap traversal for arr words+* Implement stringAnalysis in terms of its async variant+* Fix unused import warnings and remove commented out code+* Implement incremental results for thunk analysis+* Implement incremental string analysis action+* Implement parallel two level closure census+* Introduce async result interface for sequential trace+* Honour search limit in incremental search+* Stream results of the retainer query to ghc-debug-brick+* Allow thunk analysis to be expanded+ ## 0.7.0.0 -- 2025-05-20  * Relax version bounds@@ -16,7 +35,6 @@   implemented in your own library if you want to use them. * Update with support for ghc-9.4 and ghc-9.6. * Add support for debugging over a TCP socket (`withDebuggeeConnectTCP`)-  ## 0.4.0.1 -- 2023-03-09 

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                ghc-debug-client-version:             0.7.0.0+version:             0.8.0.0 synopsis:            Useful functions for writing heap analysis tools which use                      ghc-debug. description:         Useful functions for writing heap analysis tools which use@@ -8,15 +8,16 @@ 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+author:              Ben Gamari, Matthew Pickering, David Eichmann, Hannes Siebenhandl+maintainer:          hannes@well-typed.com copyright:           (c) 2019-2021 Ben Gamari, Matthew Pickering category:            Development build-type:          Simple-extra-source-files:  CHANGELOG.md+extra-doc-files:     CHANGELOG.md  library-  exposed-modules:     GHC.Debug.Client,+  exposed-modules:     GHC.Debug.Async,+                       GHC.Debug.Client,                        GHC.Debug.CostCentres,                        GHC.Debug.Retainers,                        GHC.Debug.GML,@@ -40,13 +41,13 @@                        GHC.Debug.Client.Monad.Class,                        GHC.Debug.Client.Monad.Simple -  build-depends:       base >=4.16 && < 4.22,+  build-depends:       base >=4.16 && <4.23,                        network >= 2.6 ,-                       containers ^>= 0.6,+                       containers >= 0.6 && <0.9,                        unordered-containers ^>= 0.2.13,-                       ghc-debug-common == 0.7.0.0,-                       ghc-debug-convention == 0.7.0.0,-                       text >= 2.1 && < 3,+                       ghc-debug-common == 0.8.0.0,+                       ghc-debug-convention == 0.8.0.0,+                       text >= 2.1.2 && < 3,                        process ^>= 1.6,                        filepath >= 1.4 && < 1.6,                        directory ^>= 1.3,@@ -63,7 +64,8 @@                        stm ^>= 2.5,                        vector ^>= 0.13.1 ,                        bytestring >= 0.11,-                       contra-tracer ^>= 0.2.0+                       contra-tracer ^>= 0.2.0,+                       transformers >= 0.5 && < 0.7,    hs-source-dirs:      src   default-language:    Haskell2010

@@ -0,0 +1,85 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+-- | Async API for heap traversals or computations that can be executed+-- asynchronously.+--+-- Async variations of heap traverals produce a result of 'AsyncTraceT' or 'AsyncTrace'+-- which can be periodically queried for progress.+-- This useful for implementing responsive UIs, as the user doesn't have to wait for the+-- heap traversal to finish before seeing the result.+module GHC.Debug.Async (+  -- * Async API+  AsyncTraceT(..),+  AsyncTrace,+  mkAsyncTrace,+  withAsyncTrace,+  waitForAsyncTraceResultM,+  AsyncTraceResult(..),+  expectAsyncTraceResultIsDone,+  expectAsyncTraceResultIsDoneM,+) where++import GHC.Debug.Client.Monad+import GHC.Stack.Types (HasCallStack)+import Data.IORef++data AsyncTraceResult s = Done s  -- ^ The traversal has finished, the result is the accumulated state.+                        | Running s -- ^ The traversal is running, the current result+                        | NotStarted -- ^ The traversal has not started yet.+                        deriving (Foldable, Traversable, Functor, Show)++data AsyncTraceT m s = AsyncTrace+  { asyncResult :: IO (AsyncTraceResult s)+  -- ^ The current status of the computation.+  -- This should not be blocking indefinitely.+  , asyncWait :: m ()+  -- ^ Wait for the result to complete.+  -- Once completed, 'asyncResult' must contain a 'Done' value.+  } deriving (Functor)++type AsyncTrace = AsyncTraceT DebugM++mkAsyncTrace :: IO (AsyncTraceResult s) -> m () -> AsyncTraceT m s+mkAsyncTrace res waitRes = AsyncTrace+  { asyncResult = res+  , asyncWait = waitRes+  }++waitForAsyncTraceResultM :: DebugMonad m => AsyncTraceT m s -> m s+waitForAsyncTraceResultM asyncTrace = do+  asyncWait asyncTrace+  expectAsyncTraceResultIsDoneM $ asyncResult asyncTrace++expectAsyncTraceResultIsDone :: HasCallStack => IO (AsyncTraceResult a) -> IO a+expectAsyncTraceResultIsDone read_results = do+  res <- read_results+  case res of+    Done s -> return s+    NotStarted -> error "expectAsyncTraceResultIsDone: NotStarted"+    Running _ -> error "expectAsyncTraceResultIsDone: Running"++expectAsyncTraceResultIsDoneM :: (HasCallStack, DebugMonad m) => IO (AsyncTraceResult a) -> m a+expectAsyncTraceResultIsDoneM = unsafeLiftIO . expectAsyncTraceResultIsDone++-- | Simplified API, provide an action that be used to peek at the current progress of the traversal+-- and an action that is executed asynchronously. It is the responsibility of the caller to make sure that+-- the asynchronous action updates the progress.+withAsyncTrace :: forall a m . DebugMonad m => IO a -> m () -> m (AsyncTraceT m a)+withAsyncTrace read_results runHeapTrace = do+  progressVar <- unsafeLiftIO $ newIORef NotStarted++  let+    reportProgress :: IO (AsyncTraceResult a)+    reportProgress = do+      progress <- readIORef progressVar+      traverse (\_ -> read_results) progress++    performAction :: m ()+    performAction = do+        unsafeLiftIO $ writeIORef progressVar (Running ())+        runHeapTrace+        unsafeLiftIO $ writeIORef progressVar (Done ())++  pure $ mkAsyncTrace reportProgress performAction

@@ -13,41 +13,46 @@  import GHC.Debug.Types.Ptr import GHC.Debug.Types-import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap.Strict as IM import GHC.Word import Data.Hashable import Data.IORef import Data.Bits-import Data.List (sort)+import Data.List (foldl') import Data.Binary import Control.Tracer+import Control.Monad (guard)+import Data.Bifunctor -newtype BlockCache = BlockCache (HM.HashMap Word64 RawBlock)+newtype BlockCache = BlockCache (IM.IntMap RawBlock)  instance Binary BlockCache where-  get = BlockCache . HM.fromList <$> get-  put (BlockCache hm) = put (HM.toList hm)+  get = BlockCache . IM.fromList <$> get+  put (BlockCache hm) = put (IM.toList hm)  emptyBlockCache :: BlockCache-emptyBlockCache = BlockCache HM.empty+emptyBlockCache = BlockCache IM.empty  addBlock :: RawBlock -> BlockCache -> BlockCache addBlock rb@(RawBlock (BlockPtr bp) _ _) (BlockCache bc) =-  BlockCache (HM.insert bp rb bc)+  BlockCache (IM.insert (fromIntegral bp) rb bc)   addBlocks :: [RawBlock] -> BlockCache -> BlockCache-addBlocks bc bs = Prelude.foldr addBlock bs bc+addBlocks bc bs = foldl' (flip addBlock) bs bc  lookupClosure :: ClosurePtr -> BlockCache -> Maybe RawBlock-lookupClosure (ClosurePtr cp) (BlockCache b) =-  HM.lookup (cp .&. complement blockMask) b+lookupClosure cp@(ClosurePtr cpAddr) (BlockCache b) = do+  -- See: Note [Block groups and the block cache]+  (_, rb) <- IM.lookupLE (fromIntegral cpAddr) b+  guard $ rawBlockContains cp rb+  pure rb  bcSize :: BlockCache -> Int-bcSize (BlockCache b) = HM.size b+bcSize (BlockCache b) = IM.size b  _bcKeys :: BlockCache -> [ClosurePtr]-_bcKeys (BlockCache b) = sort $ map mkClosurePtr (HM.keys b)+_bcKeys (BlockCache b) = map (mkClosurePtr . fromIntegral) (IM.keys b) -- keys of an IntMap are sorted  data BlockCacheRequest a where   LookupClosure :: ClosurePtr -> BlockCacheRequest RawClosure@@ -79,5 +84,17 @@   atomicModifyIORef' ref ((,()) . addBlocks blocks)   return blocks --+-- Note [Block groups and the block cache]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Block groups on the haskell heap normally only consist of one block,+-- but can be longer, eg, for large/pinned objects, compact regions, or for+-- segments on the nonmoving heap.+--+-- The stub always returns an entire block group as a RawBlock. This means+-- we have to be careful when looking up the enclosing block of a closure.+-- It is not enough to use the block mask, since only the head block of each+-- group is held in the cache. And the block mask may give us a non-head block.+-- Instead we find the block group with the greatest starting address less than+-- or equal to the closure pointer.+-- If the enclosing block is cached, then it will be this one.

@@ -1,24 +1,29 @@-module GHC.Debug.Count where+module GHC.Debug.Count (parCount, count, asyncCount, asyncParCount) where +import GHC.Debug.Async import           GHC.Debug.Types import GHC.Debug.Client.Monad import           GHC.Debug.Profile import           GHC.Debug.Trace import           GHC.Debug.ParTrace hiding (TraceFunctionsIO(..))-import GHC.Debug.ParTrace (TraceFunctionsIO(TraceFunctionsIO)) import Control.Monad.State-+import Control.Monad.Reader+import Data.IORef  parCount :: [ClosurePtr] -> DebugM CensusStats-parCount = traceParFromM funcs . map (ClosurePtrWithInfo ())+parCount = traceParFromWithState (justClosuresPar clos) . map (ClosurePtrWithInfo ())   where-    nop = const (return mempty)-    nop2 = const (return mempty)-    funcs = TraceFunctionsIO nop nop nop clos (const (const (return mempty))) nop2 nop (const nop2)+    clos :: WorkerId -> ClosurePtr -> SizedClosure -> ()+              -> DebugM ((), CensusStats, DebugM () -> DebugM ())+    clos _ cp sc _ = do+      return ((), mkCS cp (dcSize sc), id) -    clos :: ClosurePtr -> SizedClosure -> ()+asyncParCount :: [ClosurePtr] -> DebugM (AsyncTrace CensusStats)+asyncParCount cps = asyncTraceParFromWithState (justClosuresPar clos) (map (ClosurePtrWithInfo ()) cps)+  where+    clos :: WorkerId -> ClosurePtr -> SizedClosure -> ()               -> DebugM ((), CensusStats, DebugM () -> DebugM ())-    clos cp sc _ = do+    clos _ cp sc _ = do       return ((), mkCS cp (dcSize sc), id)  -- | Simple statistics about a heap, total objects, size and maximum object@@ -38,3 +43,28 @@      go :: ClosurePtr -> SizedClosure -> CensusStats -> CensusStats     go cp sc cs = mkCS cp (dcSize sc) <> cs+++data CountResult = CountResult { countCensus :: !CensusStats } deriving (Show)++-- | An async version of count which the request can be inspected whilst the action is running.+asyncCount :: [ClosurePtr] -> DebugM (IO CountResult, DebugM ())+asyncCount cps = do+  cr <- unsafeLiftIO $ newIORef (CountResult mempty)+  let runCensus = runReaderT (traceFromM funcs cps) cr+  return (readIORef cr, runCensus)++  where+    funcs = justClosures closAccum++    closAccum  :: ClosurePtr+               -> SizedClosure+               ->  (ReaderT (IORef CountResult) DebugM) ()+               ->  (ReaderT (IORef CountResult) DebugM) ()+    closAccum cp s k = do+      cr <- ask+      lift $ unsafeLiftIO $ modifyIORef' cr (go cp s)+      k++    go :: ClosurePtr -> SizedClosure -> CountResult -> CountResult+    go cp sc cr = cr { countCensus = mkCS cp (dcSize sc) <> countCensus cr }

@@ -1,13 +1,7 @@-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DerivingVia #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-orphans #-}-+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoApplicativeDo #-} -- | 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@@ -16,24 +10,34 @@ -- 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+module GHC.Debug.ParTrace ( traceParFromM+                          , tracePar+                          , traceParFromWithState+                          , asyncTraceParFromWithState+                          , justClosuresPar+                          , WorkerId(..)+                          , TraceFunctionsIO(..)+                          , ClosurePtrWithInfo(..)+                          ) where -import qualified Data.IntMap as IM-import Data.Array.BitArray.IO hiding (map)-import Control.Monad.Reader-import Control.Monad-import Data.Word-import GHC.Debug.Client.Monad.Simple+import GHC.Debug.Async import GHC.Debug.Client.Monad.Class+import GHC.Debug.Client.Monad.Simple+import GHC.Debug.Client.Query+import GHC.Debug.Types+ import Control.Concurrent.Async-import Data.IORef-import Control.Exception.Base import Control.Concurrent.STM+import Control.Exception.Base+import Control.Monad+import Control.Monad.Reader+import Data.Array.BitArray.IO hiding (map) import Data.Bitraversable-import Data.Coerce ( coerce )+import Data.Coerce (coerce)+import Data.IORef+import qualified Data.IntMap as IM+import qualified Data.Map as Map+import Data.Word import GHC.Conc (numCapabilities)  threads :: Int@@ -48,9 +52,8 @@ -- * Outer map, segmented by MBlock --  * Inner map, blocks for that MBlock --    * Inner IOBitArray, visited information for that block-data ThreadState s = ThreadState+data ThreadState = ThreadState   { visitedPtrs :: IM.IntMap (IM.IntMap (IOBitArray Word16))-  , globalState :: IORef s   }  newtype ThreadInfo a = ThreadInfo (InChan (ClosurePtrWithInfo a))@@ -75,37 +78,35 @@       mbk = fromIntegral raw_mbk `div` 8   in (mbk, bk, fromIntegral offset) -getMBlockKey :: ClosurePtr -> Int+getMBlockKey :: ClosurePtr -> WorkerId getMBlockKey cp =   let BlockPtr raw_bk = applyMBlockMask cp   -- Not sure why I had to divide this by 4, but I did.-  in (fromIntegral raw_bk `div` fromIntegral mblockMask `div` 4) `mod` threads+  in WorkerId ((fromIntegral raw_bk `div` fromIntegral mblockMask `div` 4) `mod` threads)  sendToChan :: TraceState a -> ClosurePtrWithInfo a -> DebugM () sendToChan  ts cpi@(ClosurePtrWithInfo _ cp) = DebugM $ liftIO $ do   let st = visited ts-      mkey = getMBlockKey cp+      WorkerId mkey = getMBlockKey cp   case IM.lookup mkey st of     Nothing -> error $ "Not enough chans:" ++ show mkey ++ show threads     Just (ThreadInfo ic) -> atomically $ writeTChan ic cpi sendToChan ts cpi@(CCSPtrWithInfo ccsPtr) = DebugM $ liftIO $ do   let st = visited ts-      mkey = getMBlockKey (coerce ccsPtr)+      WorkerId mkey = getMBlockKey (coerce ccsPtr)   case IM.lookup mkey st of     Nothing -> error $ "Not enough chans:" ++ show mkey ++ show threads     Just (ThreadInfo ic) -> atomically $ writeTChan ic cpi -initThread :: Monoid s =>-              Int-           -> TraceFunctionsIO a s-           -> DebugM (ThreadInfo a, STM Bool, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))+initThread :: WorkerId+           -> TraceFunctionsIO a ()+           -> DebugM (ThreadInfo a, STM Bool, (ClosurePtrWithInfo a -> DebugM ()) -> IO ()) initThread n k = DebugM $ do   e <- ask   ic <- liftIO $ newTChanIO   let oc = ic-  ref <- liftIO $ newIORef mempty   worker_active <- liftIO $ newTVarIO True-  let start go = unsafeLiftIO $ async $ runSimple e $ workerThread n k worker_active ref go oc+  let start go = runSimple e $ workerThread n k worker_active go oc       finished = do         active <- not <$> readTVar worker_active         empty  <- isEmptyTChan ic@@ -113,10 +114,14 @@    return (ThreadInfo ic, finished, start) -workerThread :: forall s a . Monoid s => Int -> TraceFunctionsIO a s -> TVar Bool -> IORef s -> (ClosurePtrWithInfo a -> DebugM ()) -> OutChan (ClosurePtrWithInfo a) -> DebugM s-workerThread n k worker_active ref go oc = DebugM $ do+workerThread :: forall a . WorkerId -> TraceFunctionsIO a () -> TVar Bool -> (ClosurePtrWithInfo a -> DebugM ()) -> OutChan (ClosurePtrWithInfo a) -> DebugM ()+workerThread n k worker_active go oc = DebugM $ do   d <- ask-  r <- liftIO $ newIORef (ThreadState IM.empty ref)+  r <- liftIO $ newIORef $+    ThreadState+      { visitedPtrs = IM.empty+      }+   liftIO $ runSimple d (loop r)   where     loop r = do@@ -132,8 +137,7 @@         -- state for the thread. Each thread has a reference to all over         -- threads, so the exception is only raised when ALL threads are         -- waiting for work.-        Left AsyncCancelled -> do-          unsafeLiftIO $ readIORef ref+        Left AsyncCancelled -> return ()         Right cpi -> deref r cpi >> loop r      deref r (ClosurePtrWithInfo a cp) = do@@ -143,12 +147,10 @@           unsafeLiftIO $ writeIORef r m'           if b             then do-              s <- visitedClosVal k cp a-              unsafeLiftIO $ modifyIORef' ref (s <>)+              visitedClosVal k n cp a             else do               sc <- dereferenceClosure cp-              (a', s, cont) <- closTrace k cp sc a-              unsafeLiftIO $ modifyIORef' ref (s <>)+              (a', (), cont) <- closTrace k n cp sc a               cont (() <$ hextraverse (goCCS r) (gosrt r a') (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)     deref r (CCSPtrWithInfo cp) = do         m <- unsafeLiftIO $ readIORef r@@ -157,12 +159,10 @@           unsafeLiftIO $ writeIORef r m'           if b             then do-              s <- visitedCcsVal k cp-              unsafeLiftIO $ modifyIORef' ref (s <>)+              visitedCcsVal k n cp             else do               ccs' <- dereferenceCCS cp-              s <- ccsTrace k cp ccs'-              unsafeLiftIO $ modifyIORef' ref (s <>)+              ccsTrace k n cp ccs'               () <$ bitraverse (goCCS r) goCC ccs'      goc r c@(ClosurePtrWithInfo _i cp) =@@ -175,12 +175,12 @@     -- types as they are not as common.     gos r a st = do       st' <- dereferenceStack st-      stackTrace k st'+      stackTrace k n st'       () <$ bitraverse (gosrt r a) (goc r . ClosurePtrWithInfo a) st'      gocd d = do       cd <- dereferenceConDesc d-      conDescTrace k cd+      conDescTrace k n cd      goCCS r cp =         let mkey = getMBlockKey (coerce cp)@@ -193,12 +193,12 @@      gop r a p = do       p' <- dereferencePapPayload p-      papTrace k p'+      papTrace k n p'       () <$ traverse (goc r . ClosurePtrWithInfo a) p'      gosrt r a p = do       p' <- dereferenceSRT p-      srtTrace k p'+      srtTrace k n p'       () <$ traverse (goc r . ClosurePtrWithInfo a) p'  @@ -218,30 +218,104 @@       unless res (writeArray bm offset True)       return (m, res) -checkVisit :: ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)+checkVisit :: ClosurePtr -> ThreadState -> IO (ThreadState, Bool) checkVisit cp st = do   let (mbk, bk, offset) = getKeyTriple cp-      ThreadState v ref = st+      ThreadState v = st   case IM.lookup mbk v of     Nothing -> do       (st', res) <- handleBlockLevel bk offset IM.empty-      return (ThreadState (IM.insert mbk st' v) ref, res)+      return (ThreadState (IM.insert mbk st' v) , res)     Just bm -> do       (st', res) <- handleBlockLevel bk offset bm-      return (ThreadState (IM.insert mbk st' v) ref, res)+      return (ThreadState (IM.insert mbk st' v) , res) ++newtype WorkerId = WorkerId Int deriving (Eq, Ord)+ data TraceFunctionsIO a s =-      TraceFunctionsIO { papTrace :: !(GenPapPayload ClosurePtr -> DebugM ())-      , srtTrace :: !(GenSrtPayload ClosurePtr -> DebugM ())-      , stackTrace :: !(GenStackFrames SrtCont ClosurePtr -> DebugM ())-      , closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))-      , visitedClosVal :: !(ClosurePtr -> a -> DebugM s)-      , visitedCcsVal :: !(CCSPtr -> DebugM s)-      , conDescTrace :: !(ConstrDesc -> DebugM ())-      , ccsTrace :: !(CCSPtr -> CCSPayload -> DebugM s)+      TraceFunctionsIO { papTrace :: !(WorkerId -> GenPapPayload ClosurePtr -> DebugM ())+      , srtTrace :: !(WorkerId -> GenSrtPayload ClosurePtr -> DebugM ())+      , stackTrace :: !(WorkerId -> GenStackFrames SrtCont ClosurePtr -> DebugM ())+      , closTrace :: !(WorkerId -> ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))+      , visitedClosVal :: !(WorkerId -> ClosurePtr -> a -> DebugM s)+      , visitedCcsVal :: !(WorkerId -> CCSPtr -> DebugM s)+      , conDescTrace :: !(WorkerId -> ConstrDesc -> DebugM ())+      , ccsTrace :: !(WorkerId -> CCSPtr -> CCSPayload -> DebugM s)       } +justClosuresPar :: Monoid s =>+                   (WorkerId -> ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))+                -> TraceFunctionsIO a s+justClosuresPar clos = TraceFunctionsIO+  { papTrace = nop+  , srtTrace = nop+  , stackTrace = nop+  , closTrace = clos+  , visitedClosVal = const (const (const (return mempty)))+  , visitedCcsVal = const (const (return mempty))+  , conDescTrace = nop+  , ccsTrace = const (const (const (return mempty)))+  }+  where+    nop = const (const (return ())) +-- | Accumulate state from each node+stateAccumulator  :: Semigroup s => Map.Map WorkerId (IORef s)+                  -> TraceFunctionsIO a s+                  -> TraceFunctionsIO a ()+stateAccumulator refs f =+    TraceFunctionsIO+      { papTrace = papTrace f+      , srtTrace = srtTrace f+      , stackTrace = stackTrace f+      , closTrace = \wid cp sc a -> do+          let ref = refs Map.! wid+          closTrace f wid cp sc a >>= \ (a', s, cont) -> do+            unsafeLiftIO $ modifyIORef' ref (s <>)+            return (a', (), cont)+++      , visitedClosVal = \wid cp a -> do+          let ref = refs Map.! wid+          visitedClosVal f wid cp a >>= \ s -> do+            unsafeLiftIO $ modifyIORef' ref (s <>)+            return ()+      , visitedCcsVal = \wid ccs -> do+          let ref = refs Map.! wid+          visitedCcsVal f wid ccs >>= \ s -> do+            unsafeLiftIO $ modifyIORef' ref (s <>)+            return ()+      , conDescTrace = conDescTrace f+      , ccsTrace = \wid ccs ccs' -> do+          let ref = refs Map.! wid+          ccsTrace f wid ccs ccs' >>= \ s -> do+            unsafeLiftIO $ modifyIORef' ref (s <>)+            return ()+      }++-- | Perform a parallel trace, accumulating state as we go, which can be queried whilst+-- the traversal is running.+asyncTraceParFromWithState :: Monoid s+                           => TraceFunctionsIO a s+                           -- ^ The tracing function for dealing with closures.+                           -> [ClosurePtrWithInfo a]+                           -> DebugM (AsyncTrace s)+                           -- An IO action which can be used to query the current result of the trace, and an action to run the trace.+asyncTraceParFromWithState f cps = do+  refs <- Map.fromList <$> mapM (\i -> (WorkerId i,) <$> unsafeLiftIO (newIORef mempty)) [0 .. threads - 1]+  -- Collect the results+  let read_results = mconcat <$> mapM (\(_wid, ref) -> readIORef ref) (Map.toList refs)+  withAsyncTrace read_results (traceParFromM (stateAccumulator refs f) cps)++-- | A parallel traversal which accumulates state when visiting closures.+traceParFromWithState :: Monoid s => TraceFunctionsIO a s+                        -> [ClosurePtrWithInfo a]+                        -> DebugM s+traceParFromWithState f cps = do+  asyncTrace <- asyncTraceParFromWithState f cps+  waitForAsyncTraceResultM asyncTrace+ -- | A generic heap traversal function which will use a small amount of -- memory linear in the heap size. Using this function with appropriate -- accumulation functions you should be able to traverse quite big heaps in@@ -256,21 +330,34 @@ -- As performance depends highly on contention, snapshot mode is much more -- amenable to parallelisation where the time taken for requests is much -- lower.-traceParFromM :: Monoid s => TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s+traceParFromM :: TraceFunctionsIO a () -> [ClosurePtrWithInfo a] -> DebugM () traceParFromM k cps = do   traceMsg ("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]+  -- Set up the worker threads.+  let workerThreadIds = [0 .. threads - 1]+      setupWorker wid = do+        (ti, working, start) <- initThread (WorkerId wid) k+        return ((fromIntegral wid, ti), working, start)+  (init_mblocks, work_actives, start) <- unzip3 <$> mapM setupWorker workerThreadIds   let ts_map = IM.fromList init_mblocks-      go  = sendToChan (TraceState ts_map)-  as <- sequence (map ($ go) start )-  mapM_ go cps-  wait_finish <- unsafeLiftIO $ async (waitFinish work_actives)-  unsafeLiftIO $ waitAny $ (() <$ wait_finish) : (map ((<$) ()) as)-  unsafeLiftIO $ mconcat <$> mapM cancel as-  unsafeLiftIO $ mconcat <$> mapM wait as+      go = sendToChan (TraceState ts_map) +  -- Start the work!+  -- First, we start populating the main queue with tasks.+  -- Then, we start the worker threads concurrenly, which ensures they all get cancelled+  -- if one of the worker threads crash in any way.+  -- At last, we wait for completion in a coordinated fashion.+  dbg <- DebugM ask+  unsafeLiftIO $+    withAsync (mapConcurrently_ ($ go) start) $ \ workerPool -> do+      runSimple dbg $ mapM_ go cps+      -- We have to wait at least for+      withAsync (waitFinish work_actives) $ \ allWorkersFinished -> do+        result <- waitEitherCancel allWorkersFinished workerPool+        case result of+          Left () -> pure ()+          Right () -> throwIO $ ErrorCall $ "traceParFromM: Worker threads terminated"+ waitFinish :: [STM Bool] -> IO () waitFinish working = atomically (checkDone working)   where@@ -285,26 +372,26 @@ tracePar :: [ClosurePtr] -> DebugM () tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ())   where-    nop = const (return ())+    nop = const (const (return ()))     funcs = TraceFunctionsIO       { papTrace = nop       , srtTrace = nop       , stackTrace = stack       , closTrace = clos-      , visitedClosVal = const (const (return ()))+      , visitedClosVal = const (const (const (return ())))       , visitedCcsVal = nop       , conDescTrace = nop-      , ccsTrace = const (const (return ()))+      , ccsTrace = const (const (const (return ())))       } -    stack :: GenStackFrames SrtCont ClosurePtr -> DebugM ()-    stack fs =+    stack :: WorkerId -> GenStackFrames SrtCont ClosurePtr -> DebugM ()+    stack _ fs =       let stack_frames = getFrames fs       in mapM_ (getSourceInfo . tableId . frame_info) stack_frames -    clos :: ClosurePtr -> SizedClosure -> ()-              -> DebugM ((), (), DebugM () -> DebugM ())-    clos _cp sc _ = do+    clos :: WorkerId -> ClosurePtr -> SizedClosure -> ()+              -> DebugM ((),  (), DebugM () -> DebugM ())+    clos _ _cp sc _ = do       let itb = info (noSize sc)       _traced <- getSourceInfo (tableId itb)       return ((), (), id)

@@ -1,11 +1,6 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-}@@ -14,7 +9,9 @@ {- | Functions for performing whole heap census in the style of the normal - heap profiling -} module GHC.Debug.Profile( censusClosureType+                        , censusClosureTypeAsync                         , census2LevelClosureType+                        , census2LevelClosureTypeAsync                         , closureCensusBy                         , CensusByClosureType                         , writeCensusByClosureType@@ -36,14 +33,13 @@                         , nameText                         ) where +import GHC.Debug.Async 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.Strict import Data.List (sortBy) import Data.Ord import Data.Text (pack, Text)@@ -56,13 +52,6 @@ import qualified Data.Set as Set import qualified Data.Vector as V ---import Control.Concurrent---import Eventlog.Types---import Eventlog.Data---import Eventlog.Total---import Eventlog.HtmlTemplate---import Eventlog.Args (defaultArgs, Option(..))- type CensusByClosureType = Map.Map (ProfileKey, ProfileKeyArgs) CensusStats  -- | Perform a heap census in the same style as the -hT profile.@@ -78,6 +67,20 @@           v =  mkCS cp siz       return $ Just ((closureToProfileKey (noSize d), NoArgs), v) +-- | Perform a heap census in the same style as the -hT profile.+-- censusClosureTypeAsync :: [ClosurePtr] -> DebugM (AsyncTrace _)+censusClosureTypeAsync :: [ClosurePtr] -> DebugM (AsyncTrace CensusByClosureType)+censusClosureTypeAsync rroots = closureCensusByAsync go rroots+  where+    go :: ClosurePtr -> SizedClosure+       -> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats))+    go cp s = do+      d <- hextraverse pure pure pure dereferenceConDesc pure pure s+      let siz :: Size+          siz = dcSize d+          v =  mkCS cp siz+      return $ Just ((closureToProfileKey (noSize d), NoArgs), v)+ closureToKey :: DebugClosure ccs srt a ConstrDesc c d -> Text closureToKey d =   case d of@@ -157,25 +160,23 @@                 => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))                 -> [ClosurePtr] -> DebugM (Map.Map k v) closureCensusBy f cps = do+  asyncTrace <- closureCensusByAsync f cps+  waitForAsyncTraceResultM asyncTrace++closureCensusByAsync :: forall k v . (Semigroup v, Ord k)+                => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))+                -> [ClosurePtr] -> DebugM (AsyncTrace (Map.Map k v))+closureCensusByAsync f cps = do   () <$ precacheBlocks-  MMap.getMonoidalMap <$> traceParFromM funcs (map (ClosurePtrWithInfo ()) cps)+  asyncTrace <- asyncTraceParFromWithState (justClosuresPar closAccum) (map (ClosurePtrWithInfo ()) cps)+  pure $ MMap.getMonoidalMap <$> asyncTrace   where-    funcs = TraceFunctionsIO {-               papTrace = const (return ())-              , srtTrace = const (return ())-              , stackTrace = const (return ())-              , closTrace = closAccum-              , visitedClosVal = const (const (return MMap.empty))-              , visitedCcsVal = const (return MMap.empty)-              , conDescTrace = const (return ())-              , ccsTrace = const (const (return mempty))-            }     -- Add cos-    closAccum  :: ClosurePtr+    closAccum  :: WorkerId -> ClosurePtr                -> SizedClosure                -> ()                -> DebugM ((), MMap.MonoidalMap k v, a -> a)-    closAccum cp s () = do+    closAccum _ cp s () = do       r <- f cp s       return . (\s' -> ((), s', id)) $ case r of         Just (k, v) -> MMap.singleton k v@@ -185,22 +186,28 @@ -- 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+census2LevelClosureType cps =+  waitForAsyncTraceResultM =<< census2LevelClosureTypeAsync cps++census2LevelClosureTypeAsync :: [ClosurePtr] -> DebugM (AsyncTrace CensusByClosureType)+census2LevelClosureTypeAsync cps = do+  asyncTrace <- asyncTraceParFromWithState funcs (map (() `ClosurePtrWithInfo`) cps)+  pure $ MMap.getMonoidalMap <$> asyncTrace   where-    funcs = justClosures closAccum+    funcs = justClosuresPar closAccum     -- Add cos-    closAccum  :: ClosurePtr-               -> SizedClosure-               -> (StateT CensusByClosureType DebugM) ()-               -> (StateT CensusByClosureType DebugM) ()-    closAccum cp s k = do-      s' <- lift $ hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure s-      pts <- lift $ mapM dereferenceClosure (allClosures (noSize s'))-      pts' <- lift $ mapM (hextraverse pure pure pure dereferenceConDesc pure pure) pts-+    -- closAccum  :: WorkerId+    --             -> ClosurePtr+    --             -> SizedClosure+    --             -> ()+    --             -> DebugM ((), CensusByClosureType, DebugM () -> DebugM ())+    closAccum _workerId cp s () = do+      s' <- hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure s+      pts <- mapM dereferenceClosure (allClosures (noSize s'))+      pts' <- mapM (hextraverse pure pure pure dereferenceConDesc pure pure) pts -      modify' (go cp s' pts')-      k+      pure ((), go cp s' pts', id)+      -- pure unsafeLiftIO $ modifyIORef' ref (go cp s' pts')      closureArgsToKeyArgs (ProfileClosureDesc k) kargs =       if k `Set.member` mutArrConstants && Set.size (Set.fromList kargs) == 1@@ -213,7 +220,7 @@       let !k = closureToProfileKey (noSize d)           kargs = map (closureToProfileKey . noSize) args           !keyArgs = closureArgsToKeyArgs k kargs-      in Map.insertWith (<>) (k, keyArgs) (mkCS cp (dcSize d))+      in MMap.singleton (k, keyArgs) (mkCS cp (dcSize d))      -- We handle these closure types differently as they can list each entry as an arg.     -- That leads to huge results, so we try to compress these closure types if and only if@@ -230,27 +237,6 @@       , SMALL_MUT_ARR_PTRS_FROZEN_CLEAN       ] -{---- | 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 <- hextraverse 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)@@ -315,5 +301,3 @@   writeFile "profile/ht.html" html   return ()   -}--

@@ -1,8 +1,11 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-} -- | Functions for computing retainers module GHC.Debug.Retainers-  ( findRetainers+  ( SearchLimit+  , findRetainers+  , findRetainersIncremental   , findRetainersOf   , findRetainersOfConstructor   , findRetainersOfConstructorExact@@ -29,10 +32,28 @@ import Control.Monad.RWS import Data.Word -addOne :: a -> (Maybe Int, [a]) -> (Maybe Int, [a])-addOne _ (Just 0, cp) = (Just 0, cp)-addOne cp (n, cps)    = (subtract 1 <$> n, cp : cps)+-- | Optional limit for the number of results of a search.+-- If no search limit is given, the search is unlimited.+type SearchLimit = Maybe Int +-- | Check the search limit, and if it has been reached, then stop the execution.+ifSearchLimitNotReached :: (MonadState s m) => (s -> SearchLimit) -> m () -> m ()+ifSearchLimitNotReached getLimit act = do+  limit <- get+  case getLimit limit of+    Just 0 -> pure ()+    Nothing ->+      act+    Just _ ->+      act++-- | Indicate that a result value has been found and the search limit, if there is any,+-- needs to be updated.+addedOneSearchResult :: (MonadState s m) => ((SearchLimit -> SearchLimit) -> s -> s) -> m ()+addedOneSearchResult updateLimit = do+  st <- get+  put (updateLimit (subtract 1 <$>) st)+ data EraRange   = EraRange { startEra :: Word64, endEra :: Word64} -- inclusive   deriving (Eq, Ord, Show)@@ -97,7 +118,7 @@     pure (not r1)   PureFilter b -> pure b -findRetainersOf :: Maybe Int+findRetainersOf :: SearchLimit                 -> [ClosurePtr]                 -> [ClosurePtr]                 -> DebugM [[ClosurePtr]]@@ -106,19 +127,19 @@   where     bad_set = Set.fromList bads -findRetainersOfConstructor :: Maybe Int+findRetainersOfConstructor :: SearchLimit                            -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]] findRetainersOfConstructor limit rroots con_name =   findRetainers limit (ConstructorDescFilter ((== con_name) . name)) rroots  findRetainersOfConstructorExact-  :: Maybe Int+  :: SearchLimit   -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]] findRetainersOfConstructorExact limit rroots clos_name =   findRetainers limit (InfoSourceFilter ((== clos_name) . infoName)) rroots  findRetainersOfEra-  :: Maybe Int+  :: SearchLimit   -> EraRange   -> [ClosurePtr] -> DebugM [[ClosurePtr]] findRetainersOfEra limit eras rroots =@@ -127,7 +148,7 @@     filter = ProfHeaderFilter (`profHeaderInEraRange` (Just eras))  findRetainersOfArrWords-  :: Maybe Int+  :: SearchLimit   -> [ClosurePtr] -> Size -> DebugM [[ClosurePtr]] findRetainersOfArrWords limit rroots lim =   findRetainers limit filter rroots@@ -137,7 +158,7 @@                        (SizeFilter (>= lim))  findRetainersOfInfoTable-  :: Maybe Int+  :: SearchLimit   -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]] findRetainersOfInfoTable limit rroots info_ptr =   findRetainers limit (InfoPtrFilter (== info_ptr)) rroots@@ -146,7 +167,7 @@ -- 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+findRetainers :: SearchLimit   -> ClosureFilter   -> [ClosurePtr] -> DebugM [[ClosurePtr]] findRetainers limit filter rroots = (\(_, r, _) -> snd r) <$> runRWST (traceFromM funcs rroots) [] (limit, [])@@ -155,21 +176,44 @@     -- Add clos     closAccum  :: ClosurePtr                -> SizedClosure-               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()-               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()+               -> RWST [ClosurePtr] () (SearchLimit, [[ClosurePtr]]) DebugM ()+               -> RWST [ClosurePtr] () (SearchLimit, [[ClosurePtr]]) DebugM ()     closAccum _ (noSize -> WeakClosure {}) _ = return ()-    closAccum cp sc k = do+    closAccum cp sc k = ifSearchLimitNotReached (\ (searchLimit, _) -> searchLimit) $ do       ctx <- ask       b <- lift $ matchesFilter filter cp sc ctx-      if b-      then do-        modify' (addOne (cp: ctx))-        local (cp:) k-      else do-        (lim, _) <- get-        case lim of-          Just 0 -> return ()-          _ -> local (cp:) k+      when b $ do+        addOne (cp: ctx)+        addedOneSearchResult ( \ upd (searchLimit, r) -> ( upd searchLimit, r))+      local (cp:) k++    addOne :: [ClosurePtr] -> RWST [ClosurePtr] () (SearchLimit, [[ClosurePtr]]) DebugM ()+    addOne cp = do+      modify' (\ (searchLimit, cps) -> ( searchLimit, cp : cps))++-- |  From the given roots, find retainer paths to closures which satisfy the filter.+-- The callback is called immediately when each sample is found.+findRetainersIncremental :: SearchLimit+  -> ClosureFilter+  -> [ClosurePtr]+  -> ([ClosurePtr] -> DebugM ()) -- ^ What to do with each sample when we find it.+  -> DebugM ()+findRetainersIncremental limit filter rroots add_new_sample = () <$ execRWST (traceFromM funcs rroots) [] limit+  where+    funcs = justClosures closAccum+    -- Add clos+    closAccum  :: ClosurePtr+               -> SizedClosure+               -> RWST [ClosurePtr] () SearchLimit DebugM ()+               -> RWST [ClosurePtr] () SearchLimit DebugM ()+    closAccum _ (noSize -> WeakClosure {}) _ = return ()+    closAccum cp sc k = ifSearchLimitNotReached id $ do+      ctx <- ask+      b <- lift $ matchesFilter filter cp sc ctx+      when b $ do+        lift $ add_new_sample (cp : ctx)+        addedOneSearchResult ($)+      local (cp:) k  addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureP, Maybe SourceInformation)] addLocationToStack r = do

@@ -1,31 +1,41 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-module GHC.Debug.Strings ( stringProgram, arrWordsProgram-                         , arrWordsAnalysis, stringAnalysis, decodeString) where+module GHC.Debug.Strings (+    -- * Show analysis+    stringProgram,+    arrWordsProgram,+    -- * Analsis scripts+    CensusByByteString,+    arrWordsAnalysis,+    arrWordsAnalysisAsync,+    CensusByStrings,+    stringAnalysis,+    stringAnalysisAsync,+    decodeString,+    ) where -import GHC.Debug.Client-import GHC.Debug.Types.Ptr-import GHC.Debug.Trace-import GHC.Debug.Profile.Types import Control.Monad.RWS-import qualified Data.Foldable as F--import qualified Data.Text as T-import qualified Data.Text.IO as T--import qualified Data.Map as Map-import qualified Data.Set as S+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.Reader as ReaderT import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS (length) import Data.Char-import Data.Ord+import qualified Data.Foldable as F+import Data.IORef import Data.List+import qualified Data.Map as Map+import Data.Ord+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.IO as T+import GHC.Debug.Async (AsyncTrace, withAsyncTrace, waitForAsyncTraceResultM)+import GHC.Debug.Client+import GHC.Debug.Client.Monad.Class (unsafeLiftIO)+import GHC.Debug.Profile.Types+import GHC.Debug.Trace+import GHC.Debug.Types.Ptr+import Control.Monad.Identity  -- | Find all the strings and then print out how many duplicates there are stringProgram :: Debuggee -> IO ()@@ -45,30 +55,29 @@   printResult (Map.mapWithKey (\k s -> Count (fromIntegral (sizeOf k) * (S.size s))) res)   return () -  {--  let anal n = do-        let cools = fromJust (Map.lookup n res)-        print cools-        stacks <- run e $ do-          roots <- gcRoots-          rets <- findRetainersOf (Just (S.size cools)) roots (S.toList cools)-          rets' <- traverse (\c -> (show (head c),) <$> (addLocationToStack' c)) rets-          return rets'-        displayRetainerStack' stacks-        -}+type CensusByStrings = Map.Map String (S.Set ClosurePtr)  -- | Find the parents of Bin nodes-stringAnalysis :: [ClosurePtr] -> DebugM (Map.Map String (S.Set ClosurePtr))-stringAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) False (Map.empty)+stringAnalysis :: [ClosurePtr] -> DebugM CensusByStrings+stringAnalysis rroots =+  waitForAsyncTraceResultM =<< stringAnalysisAsync rroots++-- | Find the parents of Bin nodes+--+stringAnalysisAsync :: [ClosurePtr] -> DebugM (AsyncTrace CensusByStrings)+stringAnalysisAsync rroots = do+  stringCensus <- unsafeLiftIO $ newIORef Map.empty+  withAsyncTrace (readIORef stringCensus) (ReaderT.runReaderT (traceFromM (funcs stringCensus) rroots) False)   where-    funcs = justClosures closAccum+    funcs stringCensus = justClosures (closAccum stringCensus)      -- First time we have visited a closure-    closAccum  :: ClosurePtr-               -> SizedClosure-               -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()-               -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()-    closAccum cp sc k = do+    closAccum  :: IORef CensusByStrings+                -> ClosurePtr+                -> SizedClosure+                -> ReaderT Bool DebugM ()+                -> ReaderT Bool DebugM ()+    closAccum ref cp sc k = do       case noSize sc of         ConstrClosure _ _ _ _ cd -> do           cd' <- lift $ dereferenceConDesc cd@@ -79,7 +88,7 @@         _  -> local (const False) k       where         process :: ClosurePtr -> SizedClosure-                -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()+                -> ReaderT Bool DebugM ()         process p_cp clos = do           clos' <- lift $ hextraverse pure pure pure dereferenceConDesc return return (noSize clos)           checked <- lift $ check_bin clos'@@ -90,7 +99,7 @@                 then local (const True) k                 else do                   ds <- lift $ decodeString p_cp-                  modify' (Map.insertWith (<>) ds (S.singleton p_cp))+                  lift $ unsafeLiftIO $ modifyIORef' ref (Map.insertWith (<>) ds (S.singleton p_cp))                   local (const True) k             else local (const False) k @@ -111,6 +120,7 @@           check_bin clos'         check_bin _ = return False + decodeString :: ClosurePtr -> DebugM String decodeString cp = do   cp' <- dereferenceClosure cp@@ -139,20 +149,30 @@     top10 = take 1000 $ reverse (sortBy (comparing snd) (Map.toList m))     total = F.fold (Map.elems m) +type CensusByByteString = Map.Map ByteString (S.Set ClosurePtr)+ -- | Find how many distinct ArrWords there are-arrWordsAnalysis :: [ClosurePtr] -> DebugM (Map.Map ByteString (S.Set ClosurePtr))-arrWordsAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) () (Map.empty)+arrWordsAnalysis :: [ClosurePtr] -> DebugM CensusByByteString+arrWordsAnalysis rroots =+  waitForAsyncTraceResultM =<< arrWordsAnalysisAsync rroots++arrWordsAnalysisAsync :: [ClosurePtr] -> DebugM (AsyncTrace CensusByByteString)+arrWordsAnalysisAsync rroots = do+  byteStringCensus <- unsafeLiftIO $ newIORef Map.empty+  withAsyncTrace (readIORef byteStringCensus) (runIdentityT (traceFromM (funcs byteStringCensus) rroots))   where-    funcs = justClosures closAccum+    funcs ref = justClosures (closAccum ref)      -- First time we have visited a closure-    closAccum  :: ClosurePtr-               -> SizedClosure-               -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()-               -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()-    closAccum cp sc k = do+    closAccum  ::+      IORef CensusByByteString ->+      ClosurePtr ->+      SizedClosure ->+      IdentityT DebugM () ->+      IdentityT DebugM ()+    closAccum ref cp sc k = do           case (noSize sc) of             ArrWordsClosure _ _ _ p ->  do-              modify' (Map.insertWith (<>) (arrWordsBS p) (S.singleton cp))+              lift $ unsafeLiftIO $ modifyIORef' ref (Map.insertWith (<>) (arrWordsBS p) (S.singleton cp))               k             _ -> k

@@ -1,15 +1,21 @@ module GHC.Debug.Thunks where -import GHC.Debug.Types+import Control.Monad.Identity (IdentityT(..))+import Control.Monad.RWS.Strict+import qualified Data.Map.Strict as Map+import qualified Data.Map.Monoidal.Strict as MMap++import GHC.Debug.Async import GHC.Debug.Client.Monad+import GHC.Debug.Client.Query import GHC.Debug.Profile.Types-import qualified Data.Map.Strict as Map-import Control.Monad.RWS import GHC.Debug.Trace-import GHC.Debug.Client.Query+import GHC.Debug.Types+import qualified GHC.Debug.ParTrace as Par +type ThunkCensusBySourceLocation = Map.Map (Maybe SourceInformation) CensusStats -thunkAnalysis :: [ClosurePtr] -> DebugM (Map.Map (Maybe SourceInformation) Count)+thunkAnalysis :: [ClosurePtr] -> DebugM ThunkCensusBySourceLocation thunkAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) () (Map.empty)   where     funcs = justClosures closAccum@@ -18,12 +24,54 @@      closAccum  :: ClosurePtr                -> SizedClosure-               -> (RWST () () (Map.Map (Maybe SourceInformation) Count) DebugM) ()-               -> (RWST () () (Map.Map (Maybe SourceInformation) Count) DebugM) ()-    closAccum _ sc k = do+               -> (RWST () () ThunkCensusBySourceLocation DebugM) ()+               -> (RWST () () ThunkCensusBySourceLocation DebugM) ()+    closAccum cp sc k = do           case (noSize sc) of             ThunkClosure {} ->  do               loc <- lift $ getSourceLoc sc-              modify' (Map.insertWith (<>) loc (Count 1))+              modify' (Map.insertWith (<>) loc (mkCS cp 1))               k             _ -> k++thunkAnalysisIncremental :: [ClosurePtr] -> (Maybe SourceInformation -> CensusStats -> DebugM ()) -> DebugM ()+thunkAnalysisIncremental rroots add_new_sample = runIdentityT $ traceFromM funcs rroots+  where+    funcs = justClosures closAccum++    getSourceLoc c = getSourceInfo (tableId (info (noSize c)))++    closAccum  :: ClosurePtr+                -> SizedClosure+                -> IdentityT DebugM ()+                -> IdentityT DebugM ()+    closAccum cp sc k = do+      case noSize sc of+        ThunkClosure {} ->  do+          loc <- lift $ getSourceLoc sc+          lift $ add_new_sample loc (mkCS cp 1)+          k+        _ -> k++thunkAnalysisAsync :: [ClosurePtr] -> DebugM (AsyncTrace ThunkCensusBySourceLocation)+thunkAnalysisAsync rroots = do+  asyncTrace <- Par.asyncTraceParFromWithState funcs (map (Par.ClosurePtrWithInfo ()) rroots)+  pure $ fmap MMap.getMonoidalMap asyncTrace+  where+    funcs = Par.justClosuresPar closAccum++    getSourceLoc c = getSourceInfo (tableId (info (noSize c)))++    closAccum ::+      Par.WorkerId ->+      ClosurePtr ->+      SizedClosure ->+      () ->+      DebugM ((), MMap.MonoidalMap (Maybe SourceInformation) CensusStats, DebugM () -> DebugM ())+    closAccum _ cp sc _ = do+          case (noSize sc) of+            ThunkClosure {} ->  do+              loc <- getSourceLoc sc+              pure ((), MMap.singleton loc (mkCS cp 1), id)+            _ ->+              pure ((), MMap.empty, id)

@@ -2,6 +2,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Functions to support the constant space traversal of a heap. module GHC.Debug.Trace ( traceFromM, TraceFunctions(..), justClosures ) where @@ -70,17 +71,17 @@ -- 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 :: C m => TraceFunctions m -> [ClosurePtr] -> m DebugM ()+{-# INLINE traceFromM #-} 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) ()+{-# INLINE traceClosureFromM #-} traceClosureFromM !k = go   where     go cp = do@@ -117,13 +118,10 @@      goccs p = do       mref <- ask-      (mnum_visited, b) <- lift $ lift $ unsafeLiftIO (checkVisit (coerce p) mref)+      (_mnum_visited, b) <- lift $ lift $ unsafeLiftIO (checkVisit (coerce p) mref)       if b         then return ()         else do           p' <- lift $ lift $ dereferenceCCS p           lift $ ccsTrace k p p'           () <$ bitraverse goccs pure p'---

@@ -72,15 +72,16 @@  -- | Perform a "type points from" heap census typePointsFrom :: [ClosurePtr] -> DebugM TypePointsFrom-typePointsFrom cs = traceParFromM funcs (map (ClosurePtrWithInfo Root) cs)+typePointsFrom cs = traceParFromWithState funcs (map (ClosurePtrWithInfo Root) cs)    where-    nop = const (return mempty)-    nop2 = const (return mempty)-    funcs = TraceFunctionsIO nop nop nop clos visit nop2 nop (const nop2)+    nop2 :: forall a b s . Monoid s => a -> b -> DebugM s+    nop2 = const (const (return mempty))+    nop3 = const (const (const (return mempty)))+    funcs = TraceFunctionsIO nop2 nop2 nop2 clos visit nop2 nop2 nop3 -    visit :: ClosurePtr -> Context -> DebugM TypePointsFrom-    visit cp ctx = do+    visit :: WorkerId -> ClosurePtr -> Context -> DebugM TypePointsFrom+    visit _ cp ctx = do       sc <- dereferenceClosure cp       let k = tableId $ info (noSize sc)           v = mkCS cp (dcSize sc)@@ -91,9 +92,9 @@   -    clos :: ClosurePtr -> SizedClosure -> Context+    clos :: WorkerId -> ClosurePtr -> SizedClosure -> Context               -> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())-    clos cp sc ctx = do+    clos _ cp sc ctx = do       let k = tableId $ info (noSize sc)       let s :: Size           s = dcSize sc