diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/ghc-debug-client.cabal b/ghc-debug-client.cabal --- a/ghc-debug-client.cabal +++ b/ghc-debug-client.cabal @@ -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 diff --git a/src/GHC/Debug/Async.hs b/src/GHC/Debug/Async.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Async.hs @@ -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 diff --git a/src/GHC/Debug/Client/BlockCache.hs b/src/GHC/Debug/Client/BlockCache.hs --- a/src/GHC/Debug/Client/BlockCache.hs +++ b/src/GHC/Debug/Client/BlockCache.hs @@ -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. diff --git a/src/GHC/Debug/Count.hs b/src/GHC/Debug/Count.hs --- a/src/GHC/Debug/Count.hs +++ b/src/GHC/Debug/Count.hs @@ -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 } diff --git a/src/GHC/Debug/ParTrace.hs b/src/GHC/Debug/ParTrace.hs --- a/src/GHC/Debug/ParTrace.hs +++ b/src/GHC/Debug/ParTrace.hs @@ -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) diff --git a/src/GHC/Debug/Profile.hs b/src/GHC/Debug/Profile.hs --- a/src/GHC/Debug/Profile.hs +++ b/src/GHC/Debug/Profile.hs @@ -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 () -} - - diff --git a/src/GHC/Debug/Retainers.hs b/src/GHC/Debug/Retainers.hs --- a/src/GHC/Debug/Retainers.hs +++ b/src/GHC/Debug/Retainers.hs @@ -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 diff --git a/src/GHC/Debug/Strings.hs b/src/GHC/Debug/Strings.hs --- a/src/GHC/Debug/Strings.hs +++ b/src/GHC/Debug/Strings.hs @@ -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 diff --git a/src/GHC/Debug/Thunks.hs b/src/GHC/Debug/Thunks.hs --- a/src/GHC/Debug/Thunks.hs +++ b/src/GHC/Debug/Thunks.hs @@ -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) diff --git a/src/GHC/Debug/Trace.hs b/src/GHC/Debug/Trace.hs --- a/src/GHC/Debug/Trace.hs +++ b/src/GHC/Debug/Trace.hs @@ -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' - - - diff --git a/src/GHC/Debug/TypePointsFrom.hs b/src/GHC/Debug/TypePointsFrom.hs --- a/src/GHC/Debug/TypePointsFrom.hs +++ b/src/GHC/Debug/TypePointsFrom.hs @@ -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