diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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.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, diff --git a/src/GHC/Debug/Client.hs b/src/GHC/Debug/Client.hs --- a/src/GHC/Debug/Client.hs +++ b/src/GHC/Debug/Client.hs @@ -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 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 @@ -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 diff --git a/src/GHC/Debug/Client/Monad/Simple.hs b/src/GHC/Debug/Client/Monad/Simple.hs --- a/src/GHC/Debug/Client/Monad/Simple.hs +++ b/src/GHC/Debug/Client/Monad/Simple.hs @@ -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 diff --git a/src/GHC/Debug/Client/Query.hs b/src/GHC/Debug/Client/Query.hs --- a/src/GHC/Debug/Client/Query.hs +++ b/src/GHC/Debug/Client/Query.hs @@ -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) diff --git a/src/GHC/Debug/Client/RequestCache.hs b/src/GHC/Debug/Client/RequestCache.hs --- a/src/GHC/Debug/Client/RequestCache.hs +++ b/src/GHC/Debug/Client/RequestCache.hs @@ -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 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 @@ -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 ()) diff --git a/src/GHC/Debug/ObjectEquiv.hs b/src/GHC/Debug/ObjectEquiv.hs --- a/src/GHC/Debug/ObjectEquiv.hs +++ b/src/GHC/Debug/ObjectEquiv.hs @@ -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)) 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 @@ -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 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 @@ -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 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 @@ -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 diff --git a/src/GHC/Debug/Snapshot.hs b/src/GHC/Debug/Snapshot.hs --- a/src/GHC/Debug/Snapshot.hs +++ b/src/GHC/Debug/Snapshot.hs @@ -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) () 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 @@ -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 ()) 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,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' 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 @@ -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