diff --git a/common/src/GHC/Debug/Types/Ptr.hs b/common/src/GHC/Debug/Types/Ptr.hs index 4575243c9e03b1419988489751537aa45c24f124..d507f7794dfae665a325eda0dadd70b67652a2dd 100644 --- a/common/src/GHC/Debug/Types/Ptr.hs +++ b/common/src/GHC/Debug/Types/Ptr.hs @@ -22,6 +22,7 @@ module GHC.Debug.Types.Ptr( -- * InfoTables -- * Closures , ClosurePtr(..,ClosurePtr) , mkClosurePtr + , readClosurePtr , RawClosure(..) , rawClosureSize , getInfoTblPtr @@ -79,7 +80,7 @@ import Data.Binary.Get import Data.Binary.Put import System.Endian -import Numeric (showHex) +import Numeric (showHex, readHex) import Data.Coerce import Data.Bits import GHC.Stack @@ -119,6 +120,12 @@ pattern ClosurePtr p <- UntaggedClosurePtr p mkClosurePtr :: Word64 -> ClosurePtr mkClosurePtr = untagClosurePtr . UntaggedClosurePtr +readClosurePtr :: String -> Maybe ClosurePtr +readClosurePtr ('0':'x':s) = case readHex s of + [(res, "")] -> Just (mkClosurePtr res) + _ -> Nothing +readClosurePtr _ = Nothing + instance Binary ClosurePtr where put (ClosurePtr p) = putWord64be (toBE64 p) get = mkClosurePtr . fromBE64 <$> getWord64be diff --git a/ghc-debug-brick/src/Lib.hs b/ghc-debug-brick/src/Lib.hs index eec4b925aa781862d589b41fa14ee387f42ad464..a351b3464ad0591a75d8b4d479eb25c984fcafd0 100644 --- a/ghc-debug-brick/src/Lib.hs +++ b/ghc-debug-brick/src/Lib.hs @@ -69,6 +69,7 @@ module Lib -- * Retainers , retainersOfConstructor + , retainersOfAddress , retainersOfConstructorExact -- * Snapshot @@ -84,6 +85,7 @@ module Lib , StackCont , PayloadCont , ClosurePtr + , readClosurePtr , HG.StackHI , HG.PapHI , HG.HeapGraphIndex @@ -226,6 +228,13 @@ snapshot dbg fp = do createDirectoryIfMissing True dir GD.makeSnapshot dbg (dir </> fp) +retainersOfAddress :: Maybe [ClosurePtr] -> Debuggee -> [ClosurePtr] -> IO [[Closure]] +retainersOfAddress mroots dbg address = do + run dbg $ do + roots <- maybe GD.gcRoots return mroots + stack <- GD.findRetainersOf (Just 100) roots address + traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack + retainersOfConstructor :: Maybe [ClosurePtr] -> Debuggee -> String -> IO [[Closure]] retainersOfConstructor mroots dbg con_name = do run dbg $ do diff --git a/ghc-debug-brick/src/Main.hs b/ghc-debug-brick/src/Main.hs index 8ca4bb4764c9bebb6b6f3e01527941c802c452b3..00fd5132cef629b9471dd582441e7faafd523589 100644 --- a/ghc-debug-brick/src/Main.hs +++ b/ghc-debug-brick/src/Main.hs @@ -108,6 +108,7 @@ myAppDraw (AppState majorState') = , txt "Find Retainers (^f)" , txt "Find Retainers (Exact) (^e)" , txt "Find Closures (Exact) (^c)" + , txt "Find Address (^p)" , txt "Take Snapshot (^x)" , txt "Exit (ESC)" ]) @@ -481,6 +482,9 @@ handleMainWindowEvent _dbg os@(OperationalState treeMode' _footerMode _curRoots VtyEvent (Vty.EvKey (KChar 'c') [Vty.MCtrl]) -> continue $ os & footerMode .~ (FooterInput FSearch emptyTextCursor) + VtyEvent (Vty.EvKey (KChar 'p') [Vty.MCtrl]) -> + continue $ os & footerMode .~ (FooterInput FAddress emptyTextCursor) + VtyEvent (Vty.EvKey (KChar 'w') [Vty.MCtrl]) -> continue $ os & footerMode .~ (FooterInput FProfile emptyTextCursor) @@ -540,12 +544,23 @@ dispatchFooterInput dbg FSearch tc os = do cps <- map head <$> (liftIO $ retainersOfConstructor Nothing dbg (T.unpack (rebuildTextCursor tc))) let cps' = (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps' - let new_roots = map (second toPtr) cps' - root_details = res - tree = mkIOTree dbg Nothing res getChildren id + let tree = mkIOTree dbg Nothing res getChildren id continue (os & resetFooter & treeMode .~ Searched tree ) +dispatchFooterInput dbg FAddress tc os = do + let address = T.unpack (rebuildTextCursor tc) + case readClosurePtr address of + Just cp -> do + cps <- map head <$> (liftIO $ retainersOfAddress Nothing dbg [cp]) + let cps' = (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps + res <- liftIO $ mapM (completeClosureDetails dbg Nothing) cps' + let tree = mkIOTree dbg Nothing res getChildren id + continue (os & resetFooter + & treeMode .~ Searched tree + ) + Nothing -> continue (os & resetFooter) + dispatchFooterInput dbg FProfile tc os = do liftIO $ profile dbg (T.unpack (rebuildTextCursor tc)) continue (os & resetFooter) diff --git a/ghc-debug-brick/src/Model.hs b/ghc-debug-brick/src/Model.hs index ff2a421376dfbe72acbc76e45d10789c2164efd6..cc519fcea949c498b4d4350bf443fca41c295e8c 100644 --- a/ghc-debug-brick/src/Model.hs +++ b/ghc-debug-brick/src/Model.hs @@ -111,9 +111,10 @@ data FooterMode = FooterInfo | FooterMessage Text | FooterInput FooterInputMode TextCursor -data FooterInputMode = FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot +data FooterInputMode = FAddress | FSearch | FProfile | FRetainer | FRetainerExact | FSnapshot formatFooterMode :: FooterInputMode -> Text +formatFooterMode FAddress = "address (0x..): " formatFooterMode FSearch = "search: " formatFooterMode FProfile = "filename: " formatFooterMode FRetainer = "constructor name: "