ghc-debug-client 0.3.0.0 → 0.4.0.0

raw patch · 16 files changed

+98/−44 lines, 16 filesdep ~eventlog2htmldep ~ghc-debug-commondep ~ghc-debug-conventionPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: eventlog2html, ghc-debug-common, ghc-debug-convention

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• ghc-debug-client.cabal +4/−4
• src/GHC/Debug/Client.hs +7/−2
• src/GHC/Debug/Client/BlockCache.hs +5/−4
• src/GHC/Debug/Client/Monad/Simple.hs +2/−1
• src/GHC/Debug/Client/Query.hs +16/−4
• src/GHC/Debug/Client/RequestCache.hs +2/−0
• src/GHC/Debug/Count.hs +2/−1
• src/GHC/Debug/ObjectEquiv.hs +5/−4
• src/GHC/Debug/ParTrace.hs +10/−4
• src/GHC/Debug/Profile.hs +8/−6
• src/GHC/Debug/Retainers.hs +9/−8
• src/GHC/Debug/Snapshot.hs +1/−1
• src/GHC/Debug/Strings.hs +3/−1
• src/GHC/Debug/Trace.hs +14/−3
• src/GHC/Debug/TypePointsFrom.hs +1/−1

@@ -1,5 +1,14 @@ # Revision history for ghc-debug-client +## 0.4 -- 2022-12-14++* Add support for tracing SRTs. This is quite an invasive change which adds a new+  pointer type to the DebugClosure type. This change is reflected in the API for+  parTrace and traceFrom.++* The `Quadtraverse` abstraction is generalised to `Quintraverse` to account for+  this new type parameter.+ ## 0.3 -- 2022-10-06  * Abstract away tracing functions to allow configuration of progress reporting.

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                ghc-debug-client-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Useful functions for writing heap analysis tools which use                      ghc-debug. description:         Useful functions for writing heap analysis tools which use@@ -42,8 +42,8 @@                        network >= 2.6 ,                        containers ^>= 0.6,                        unordered-containers ^>= 0.2.13,-                       ghc-debug-common == 0.3.0.0,-                       ghc-debug-convention == 0.3.0.0,+                       ghc-debug-common == 0.4.0.0,+                       ghc-debug-convention == 0.4.0.0,                        text ^>= 1.2.4,                        process ^>= 1.6,                        filepath ^>= 1.4,@@ -51,7 +51,7 @@                        bitwise ^>= 1.0,                        hashable >= 1.3 && < 1.5,                        mtl ^>= 2.2,-                       eventlog2html >= 0.8.3,+                       eventlog2html >= 0.8.3 && < 0.9.3,                        binary ^>= 0.8,                        psqueues ^>= 0.2,                        dom-lt ^>= 0.2,

@@ -49,13 +49,16 @@   , savedObjects   , precacheBlocks   , dereferenceClosure+  , dereferenceToClosurePtr+  , addConstrDesc   , dereferenceClosures   , dereferenceStack   , dereferencePapPayload   , dereferenceConDesc   , dereferenceInfoTable+  , dereferenceSRT -  , Quadtraversable(..)+  , Quintraversable(..)    -- * Building a Heap Graph   , buildHeapGraph@@ -94,11 +97,13 @@ import           GHC.Debug.Client.Query import qualified GHC.Debug.Types.Graph as HG import Data.List.NonEmpty (NonEmpty)+import Data.Bitraversable+import Control.Monad  derefFuncM :: HG.DerefFunction DebugM Size derefFuncM c = do   c' <- dereferenceClosure c-  quadtraverse dereferencePapPayload dereferenceConDesc dereferenceStack pure c'+  quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure c'  -- | Build a heap graph starting from the given root. The first argument -- controls how many levels to recurse. You nearly always want to set this

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

@@ -184,8 +184,9 @@ blockReq :: BlockCacheRequest resp -> DebugM resp blockReq req = DebugM $ do   bc  <- asks debuggeeBlockCache+  tracer  <- asks debuggeeTrace   env <- ask-  liftIO $ handleBlockReq (\r -> runReaderT (simpleReq r) env) bc req+  liftIO $ handleBlockReq tracer (\r -> runReaderT (simpleReq r) env) bc req  newtype DebugM a = DebugM (ReaderT Debuggee IO a)                    -- Only derive the instances that DebugMonad needs

@@ -25,11 +25,13 @@   , dereferenceClosure   , dereferenceClosureDirect   , dereferenceClosureC+  , dereferenceToClosurePtr+  , addConstrDesc   , dereferenceStack   , dereferencePapPayload   , dereferenceConDesc   , dereferenceInfoTable-+  , dereferenceSRT   ) where  import           Control.Exception@@ -78,10 +80,18 @@   dereferenceClosureC :: ClosurePtr -> DebugM SizedClosureC-dereferenceClosureC cp = do-  c <- dereferenceClosure cp-  quadtraverse pure dereferenceConDesc pure pure c+dereferenceClosureC cp = addConstrDesc =<< dereferenceClosure cp +addConstrDesc :: SizedClosure -> DebugM SizedClosureC+addConstrDesc c =+  quintraverse pure pure dereferenceConDesc pure pure c++-- Derefence other structures so we just have 'ClosurePtr' at leaves.+dereferenceToClosurePtr :: SizedClosure -> DebugM SizedClosureP+dereferenceToClosurePtr c = do+  quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc pure pure c++ -- | Decode a closure corresponding to the given 'ClosurePtr' -- You should not use this function directly unless you know what you are -- doing. 'dereferenceClosure' will be much faster in general.@@ -195,3 +205,5 @@ dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable dereferenceInfoTable it = decodedTable . fst <$> request (RequestInfoTable it) +dereferenceSRT :: InfoTablePtr -> DebugM SrtPayload+dereferenceSRT it = GenSrtPayload <$> request (RequestSRT it)

@@ -48,6 +48,7 @@ getResponseBinary (RequestClosure {}) = get getResponseBinary (RequestInfoTable itps) =       (\(it, r) -> (StgInfoTableWithPtr itps it, r)) <$> getInfoTable+getResponseBinary (RequestSRT {}) = get getResponseBinary (RequestStackBitmap {}) = get getResponseBinary (RequestFunBitmap {}) = get getResponseBinary (RequestConstrDesc _)  = getConstrDescCache@@ -64,6 +65,7 @@ putResponseBinary RequestRoots  rs     = put rs putResponseBinary (RequestClosure {}) rcs = put rcs putResponseBinary (RequestInfoTable {}) (_, r) = putInfoTable r+putResponseBinary (RequestSRT {}) rcs = put rcs putResponseBinary (RequestStackBitmap {}) pbm = put pbm putResponseBinary (RequestFunBitmap {}) pbm = put pbm putResponseBinary (RequestConstrDesc _) cd  = putConstrDescCache cd

@@ -13,7 +13,7 @@ parCount = traceParFromM funcs . map (ClosurePtrWithInfo ())   where     nop = const (return ())-    funcs = TraceFunctionsIO nop nop clos (const (const (return mempty))) nop+    funcs = TraceFunctionsIO nop nop nop clos (const (const (return mempty))) nop      clos :: ClosurePtr -> SizedClosure -> ()               -> DebugM ((), CensusStats, DebugM () -> DebugM ())@@ -27,6 +27,7 @@   where     funcs = TraceFunctions {                papTrace = const (return ())+              , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum               , visitedVal = const (return ())

@@ -86,7 +86,7 @@ checkSize :: ObjectEquivState -> Int checkSize (ObjectEquivState e1 _ _) = PS.size e1 -type PtrClosure = DebugClosureWithSize PapPayload ConstrDesc StackFrames ClosurePtr+type PtrClosure = DebugClosureWithSize SrtPayload PapPayload ConstrDesc StackFrames ClosurePtr  -- | General function for performing a heap census in constant memory censusObjectEquiv :: [ClosurePtr] -> DebugM ObjectEquivState@@ -94,6 +94,7 @@   where     funcs = TraceFunctions {                papTrace = const (return ())+              , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum               , visitedVal = const (return ())@@ -110,10 +111,10 @@       -- for this cp       -- Step 1: Decode a bit more of the object, so we can see all the       -- pointers.-      s' <- lift $ quadtraverse dereferencePapPayload dereferenceConDesc dereferenceStack pure s+      s' <- lift $ quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc dereferenceStack pure s       -- Step 2: Replace all the pointers in the closure by things they are       -- equivalent to we have already seen.-      s''  <- quadtraverse (traverse rep_c) pure (traverse rep_c) rep_c s'+      s''  <- quintraverse (traverse rep_c) (traverse rep_c) pure (traverse rep_c) rep_c s'       -- Step 3: Have we seen a closure like this one before?       modify' (addEquiv cp s'') @@ -153,7 +154,7 @@   let cmp (_, b,_) = b       res = sortBy (flip (comparing cmp)) (PS.toList c)       showLine (k, p, v) =-        concat [show v, ":", show p,":", ppClosure "" (\_ -> show) 0 (noSize k)]+        concat [show v, ":", show p,":", ppClosure (\_ -> show) 0 (noSize k)]   mapM_ (putStrLn . showLine) res --  writeFile "profile/profile_out.txt" (unlines $ "key, total, count, max, avg" : (map showLine res)) 

@@ -134,7 +134,7 @@               sc <- dereferenceClosure cp               (a', s, cont) <- closTrace k cp sc a               unsafeLiftIO $ modifyIORef' ref (s <>)-              cont (() <$ quadtraverse (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)+              cont (() <$ quintraverse (gosrt r a') (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)      goc r c@(ClosurePtrWithInfo _i cp) =       let mkey = getMBlockKey cp@@ -158,7 +158,12 @@       papTrace k p'       () <$ traverse (goc r . ClosurePtrWithInfo a) p' +    gosrt r a p = do+      p' <- dereferenceSRT p+      srtTrace k p'+      () <$ traverse (goc r . ClosurePtrWithInfo a) p' + handleBlockLevel :: IM.Key                     -> Word16                     -> IM.IntMap (IOBitArray Word16)@@ -193,7 +198,8 @@  data TraceFunctionsIO a s =       TraceFunctionsIO { papTrace :: !(GenPapPayload ClosurePtr -> DebugM ())-      , stackTrace :: !(GenStackFrames ClosurePtr -> DebugM ())+      , srtTrace :: !(GenSrtPayload ClosurePtr -> DebugM ())+      , stackTrace :: !(GenStackFrames SrtCont ClosurePtr -> DebugM ())       , closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))       , visitedVal :: !(ClosurePtr -> a -> DebugM s)       , conDescTrace :: !(ConstrDesc -> DebugM ())@@ -243,9 +249,9 @@ tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ())   where     nop = const (return ())-    funcs = TraceFunctionsIO nop stack clos (const (const (return ()))) nop+    funcs = TraceFunctionsIO nop nop stack clos (const (const (return ()))) nop -    stack :: GenStackFrames ClosurePtr -> DebugM ()+    stack :: GenStackFrames SrtCont ClosurePtr -> DebugM ()     stack fs =       let stack_frames = getFrames fs       in mapM_ (getSourceInfo . tableId . frame_info) stack_frames

@@ -42,7 +42,7 @@ import Data.Semigroup import qualified Data.Text as T import qualified Data.Map.Monoidal.Strict as MMap-+import Data.Bitraversable   type CensusByClosureType = Map.Map Text CensusStats@@ -54,7 +54,7 @@     go :: ClosurePtr -> SizedClosure        -> DebugM (Maybe (Text, CensusStats))     go _ s = do-      d <- quadtraverse pure dereferenceConDesc pure pure s+      d <- quintraverse pure pure dereferenceConDesc pure pure s       let siz :: Size           siz = dcSize d           v =  mkCS siz@@ -62,7 +62,7 @@   -closureToKey :: DebugClosure a ConstrDesc c d -> Text+closureToKey :: DebugClosure srt a ConstrDesc c d -> Text closureToKey d =   case d of      ConstrClosure { constrDesc = ConstrDesc a b c }@@ -80,6 +80,7 @@   where     funcs = TraceFunctionsIO {                papTrace = const (return ())+              , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum               , visitedVal = const (const (return MMap.empty))@@ -105,6 +106,7 @@   where     funcs = TraceFunctions {                papTrace = const (return ())+              , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum               , visitedVal = const (return ())@@ -117,9 +119,9 @@                -> (StateT CensusByClosureType DebugM) ()                -> (StateT CensusByClosureType DebugM) ()     closAccum _ s k = do-      s' <- lift $ quadtraverse dereferencePapPayload dereferenceConDesc dereferenceStack pure s+      s' <- lift $ quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure s       pts <- lift $ mapM dereferenceClosure (allClosures (noSize s'))-      pts' <- lift $ mapM (quadtraverse pure dereferenceConDesc pure pure) pts+      pts' <- lift $ mapM (quintraverse pure pure dereferenceConDesc pure pure) pts         modify' (go s' pts')@@ -145,7 +147,7 @@     clos :: ClosurePtr -> SizedClosure -> ()               -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ())     clos _cp sc () = do-      d <- quadtraverse pure dereferenceConDesc pure pure sc+      d <- quintraverse pure dereferenceConDesc pure pure sc       let s :: Size           s = dcSize sc           v =  mkCS s

@@ -54,6 +54,7 @@   where     funcs = TraceFunctions {                papTrace = const (return ())+              , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum               , visitedVal = const (return ())@@ -81,28 +82,28 @@             Just 0 -> return ()             _ -> local (cp:) k -addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureC, Maybe SourceInformation)]+addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureP, Maybe SourceInformation)] addLocationToStack r = do   cs <- dereferenceClosures r-  cs' <- mapM (quadtraverse pure dereferenceConDesc pure pure) cs+  cs' <- mapM dereferenceToClosurePtr cs   locs <- mapM getSourceLoc cs'   return $ (zip cs' locs)   where     getSourceLoc c = getSourceInfo (tableId (info (noSize c))) -addLocationToStack' :: [ClosurePtr] -> DebugM [(ClosurePtr, SizedClosureC, Maybe SourceInformation)]+addLocationToStack' :: [ClosurePtr] -> DebugM [(ClosurePtr, SizedClosureP, Maybe SourceInformation)] addLocationToStack' r = do   cs <- dereferenceClosures r-  cs' <- mapM (quadtraverse pure dereferenceConDesc pure pure) cs+  cs' <- mapM dereferenceToClosurePtr cs   locs <- mapM getSourceLoc cs'   return $ (zip3 r cs' locs)   where     getSourceLoc c = getSourceInfo (tableId (info (noSize c))) -displayRetainerStack :: [(String, [(SizedClosureC, Maybe SourceInformation)])] -> IO ()+displayRetainerStack :: [(String, [(SizedClosureP, Maybe SourceInformation)])] -> IO () displayRetainerStack rs = do       let disp (d, l) =-            (ppClosure ""  (\_ -> show) 0 . noSize $ d) ++  " <" ++ maybe "nl" tdisplay l ++ ">"+            (ppClosure  (\_ -> show) 0 . noSize $ d) ++  " <" ++ maybe "nl" tdisplay l ++ ">"             where               tdisplay sl = infoName sl ++ ":" ++ infoType sl ++ ":" ++ infoModule sl ++ ":" ++ infoPosition sl           do_one k (l, stack) = do@@ -111,10 +112,10 @@             mapM (putStrLn . disp) stack       zipWithM_ do_one [0 :: Int ..] rs -displayRetainerStack' :: [(String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])] -> IO ()+displayRetainerStack' :: [(String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])] -> IO () displayRetainerStack' rs = do       let disp (p, d, l) =-            show p ++ ": " ++ (ppClosure ""  (\_ -> show) 0 . noSize $ d) ++  " <" ++ maybe "nl" tdisplay l ++ ">"+            show p ++ ": " ++ (ppClosure  (\_ -> show) 0 . noSize $ d) ++  " <" ++ maybe "nl" tdisplay l ++ ">"             where               tdisplay sl = infoName sl ++ ":" ++ infoType sl ++ ":" ++ infoModule sl ++ ":" ++ infoPosition sl           do_one k (l, stack) = do

@@ -30,7 +30,7 @@ traceFrom cps = runIdentityT (traceFromM funcs cps)   where     nop = const (return ())-    funcs = TraceFunctions nop nop clos (const (return ())) nop+    funcs = TraceFunctions nop nop nop clos (const (return ())) nop      clos :: ClosurePtr -> SizedClosure -> (IdentityT DebugM) ()               ->  (IdentityT DebugM) ()

@@ -63,6 +63,7 @@   where     funcs = TraceFunctions {                papTrace = const (return ())+              , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum               , visitedVal = const (return ())@@ -88,7 +89,7 @@         process :: ClosurePtr -> SizedClosure                 -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()         process p_cp clos = do-          clos' <- lift $ quadtraverse pure dereferenceConDesc return return (noSize clos)+          clos' <- lift $ quintraverse pure pure dereferenceConDesc return return (noSize clos)           checked <- lift $ check_bin clos'           if checked             then do@@ -141,6 +142,7 @@   where     funcs = TraceFunctions {                papTrace = const (return ())+              , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum               , visitedVal = const (return ())

@@ -2,7 +2,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE BangPatterns #-} -- | Functions to support the constant space traversal of a heap.-module GHC.Debug.Trace ( traceFromM, TraceFunctions(..) ) where+module GHC.Debug.Trace ( traceFromM, TraceFunctions(..), justClosures ) where  import           GHC.Debug.Types import GHC.Debug.Client.Monad@@ -47,15 +47,21 @@  data TraceFunctions m =       TraceFunctions { papTrace :: !(GenPapPayload ClosurePtr -> m DebugM ())-      , stackTrace :: !(GenStackFrames ClosurePtr -> m DebugM ())+      , srtTrace   :: !(GenSrtPayload ClosurePtr -> m DebugM ())+      , stackTrace :: !(GenStackFrames SrtCont ClosurePtr -> m DebugM ())       , closTrace :: !(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())       , visitedVal :: !(ClosurePtr -> (m DebugM) ())       , conDescTrace :: !(ConstrDesc -> m DebugM ())       } +justClosures :: C m => (ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()) -> TraceFunctions m+justClosures f = TraceFunctions nop nop nop f nop nop+  where+    nop = const (return ())   + type C m = (MonadTrans m, Monad (m DebugM))  -- | A generic heap traversal function which will use a small amount of@@ -85,7 +91,7 @@         else do         sc <- lift $ lift $ dereferenceClosure cp         ReaderT $ \st -> closTrace k cp sc-         (runReaderT (() <$ quadtraverse gop gocd gos go sc) st)+         (runReaderT (() <$ quintraverse gosrt gop gocd gos go sc) st)       gos st = do@@ -100,4 +106,9 @@     gop p = do       p' <- lift $ lift $ dereferencePapPayload p       lift $ papTrace k p'+      () <$ traverse go p'++    gosrt p = do+      p' <- lift $ lift $ dereferenceSRT p+      lift $ srtTrace k p'       () <$ traverse go p'

@@ -75,7 +75,7 @@    where     nop = const (return ())-    funcs = TraceFunctionsIO nop nop clos visit nop+    funcs = TraceFunctionsIO nop nop nop clos visit nop      visit :: ClosurePtr -> Context -> DebugM TypePointsFrom     visit cp ctx = do