diff --git a/ghc-debug-brick/src/Lib.hs b/ghc-debug-brick/src/Lib.hs index 6703acbba9cc706a9f3cd8e4dc4d3a5c8639b205..8f616859e0ca9d3216d9c9f03a765cf6899205e1 100644 --- a/ghc-debug-brick/src/Lib.hs +++ b/ghc-debug-brick/src/Lib.hs @@ -12,6 +12,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE NamedFieldPuns #-} module Lib ( -- * Running/Connecting to a debuggee Debuggee @@ -51,6 +52,7 @@ module Lib , infoSourceLocation , GD.dereferenceClosure , run + , ccsReferences -- * Common initialisation , initialTraversal @@ -78,6 +80,8 @@ module Lib -- * Types , Ptr(..) , CCSPtr + , CCPayload + , GenCCSPayload , toPtr , dereferencePtr , ConstrDesc(..) @@ -268,6 +272,8 @@ type Closure = DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont data ListItem ccs srt a b c d = ListData | ListOnlyInfo InfoTablePtr + | ListCCS CCSPtr (GenCCSPayload CCSPtr CCPayload) + | ListCC CCPayload | ListFullClosure (DebugClosure ccs srt a b c d) data DebugClosure ccs srt p cd s c @@ -279,54 +285,39 @@ data DebugClosure ccs srt p cd s c { _stackPtr :: StackCont , _stackStack :: GD.GenStackFrames srt c } - | CCS - { _ccsPtr :: CCSPtr - , _ccPayload :: GenCCSPayload CCSPtr CCPayload - } deriving Show toPtr :: DebugClosure ccs srt p cd s c -> Ptr toPtr (Closure cp _) = CP cp toPtr (Stack sc _) = SP sc -toPtr (CCS ccsp _ ) = CCSP ccsp -data Ptr = CP ClosurePtr | SP StackCont | CCSP CCSPtr deriving (Eq, Ord) +data Ptr = CP ClosurePtr | SP StackCont deriving (Eq, Ord) dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) dereferencePtr dbg (CP cp) = run dbg (Closure <$> pure cp <*> GD.dereferenceClosure cp) dereferencePtr dbg (SP sc) = run dbg (Stack <$> pure sc <*> GD.dereferenceStack sc) -dereferencePtr dbg (CCSP ccsp) = run dbg (CCS <$> pure ccsp <*> go) - where - go = do - ccs <- GD.dereferenceCCS ccsp - bitraverse pure GD.dereferenceCC ccs instance Hextraversable DebugClosure where hextraverse p f g h i j (Closure cp c) = Closure cp <$> hextraverse p f g h i j c hextraverse _ p _ _ _ h (Stack sp s) = Stack sp <$> bitraverse p h s - hextraverse _ _ _ _ _ _ (CCS sp s) = pure $ CCS sp s closureShowAddress :: DebugClosure ccs srt p cd s c -> String closureShowAddress (Closure c _) = show c closureShowAddress (Stack (StackCont s _) _) = show s -closureShowAddress (CCS c _) = show c -- | Get the exclusive size (not including any referenced closures) of a closure. closureExclusiveSize :: DebugClosure ccs srt p cd s c -> Size closureExclusiveSize (Stack{}) = Size (-1) -closureExclusiveSize (CCS{}) = Size (-1) closureExclusiveSize (Closure _ c) = (GD.dcSize c) closureSourceLocation :: Debuggee -> DebugClosure ccs srt p cd s c -> IO (Maybe SourceInformation) -closureSourceLocation _ (CCS{}) = return Nothing closureSourceLocation _ (Stack _ _) = return Nothing closureSourceLocation e (Closure _ c) = run e $ do request (RequestSourceInfo (tableId (info (noSize c)))) closureInfoPtr :: DebugClosure ccs srt p cd s c -> Maybe InfoTablePtr closureInfoPtr (Stack {}) = Nothing -closureInfoPtr (CCS {}) = Nothing closureInfoPtr (Closure _ c) = Just (tableId (info (noSize c))) infoSourceLocation :: Debuggee -> InfoTablePtr -> IO (Maybe SourceInformation) @@ -375,18 +366,23 @@ closureReferences e (Closure _ closure) = run e $ do refCCS <- do GD.dereferenceCCS ccsPtr >>= \ccs -> bitraverse pure GD.dereferenceCC ccs - return $ ListFullClosure $ CCS ccsPtr refCCS + return $ ListCCS ccsPtr refCCS closureReferencesAndLabels wrapClosure wrapStack wrapCCS (unDCS closure') -closureReferences e (CCS _ ccs) = do - case ccsPrevStack ccs of - Nothing -> pure [] - Just ccsPtr -> run e $ do - child' <- GD.dereferenceCCS ccsPtr - child <- bitraverse pure GD.dereferenceCC child' - pure [("child",ListFullClosure $ CCS ccsPtr child)] + +ccsReferences :: Debuggee -> GenCCSPayload CCSPtr CCPayload -> IO [ListItem ccs srt a b c d] +ccsReferences e initialCcs = run e $ (ListCC (ccsCc initialCcs) :) <$> go initialCcs + where + go ccs = do + case ccsPrevStack ccs of + Nothing -> pure [ListCC (ccsCc ccs)] + Just ccsPtr -> do + child <- GD.dereferenceCCS ccsPtr + child' <- bitraverse pure GD.dereferenceCC child + children <- go child' + return (ListCC (ccsCc child') : children) reverseClosureReferences :: HG.HeapGraph Size -> HG.ReverseGraph @@ -401,7 +397,6 @@ reverseClosureReferences :: HG.HeapGraph Size reverseClosureReferences hg rm _ c = case c of Stack {} -> error "Nope - Stack" - CCS {} -> error "Nope - CCS" Closure cp _ -> case (HG.reverseEdges cp rm) of Nothing -> return [] Just es -> @@ -424,7 +419,6 @@ fillConstrDesc e closure = do -- | Pretty print a closure closurePretty :: Debuggee -> DebugClosure CCSPtr InfoTablePtr PayloadCont ConstrDesc s ClosurePtr -> IO String -closurePretty _ (CCS _ ccs) = return $ (show $ ccsCc ccs) closurePretty _ (Stack _ frames) = return $ (show (length frames) ++ " frames") closurePretty dbg (Closure _ closure) = run dbg $ do closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure diff --git a/ghc-debug-brick/src/Main.hs b/ghc-debug-brick/src/Main.hs index 35c21b3762a360b37cd90e44779a65d9362059bb..de4f4fd19bcebee95cffa1b30f3c1124cd2b6a1b 100644 --- a/ghc-debug-brick/src/Main.hs +++ b/ghc-debug-brick/src/Main.hs @@ -43,7 +43,6 @@ import qualified Data.Text as T import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import qualified Data.Set as S -import Data.Maybe import qualified Data.Foldable as F import Text.Read (readMaybe) @@ -232,6 +231,21 @@ renderClosureDetails (cd@(ClosureDetails {})) = ] renderClosureDetails ((LabelNode n)) = txt n renderClosureDetails ((InfoDetails info')) = vLimit 8 $ vBox $ renderInfoInfo info' +renderClosureDetails (CCSDetails _ _ptr (Debug.CCSPayload{..})) = vLimit 8 $ vBox $ + [ labelled "ID" $ vLimit 1 (str $ show ccsID) + ] ++ renderCCPayload ccsCc +renderClosureDetails (CCDetails _ c) = vLimit 8 $ vBox $ renderCCPayload c + +renderCCPayload :: CCPayload -> [Widget Name] +renderCCPayload Debug.CCPayload{..} = + [ labelled "Label" $ vLimit 1 (str ccLabel) + , labelled "Module" $ vLimit 1 (str ccMod) + , labelled "Location" $ vLimit 1 (str ccLoc) + , labelled "Allocation" $ vLimit 1 (str $ show ccMemAlloc) + , labelled "Time Ticks" $ vLimit 1 (str $ show ccTimeTicks) + , labelled "Is CAF" $ vLimit 1 (str $ show ccIsCaf) + ] + footer :: Int -> Maybe Int -> FooterMode -> Widget Name footer n m mode = vLimit 1 $ @@ -396,18 +410,26 @@ myAppHandleEvent brickEvent = do getChildren :: Debuggee -> ClosureDetails -> IO [ClosureDetails] +getChildren _ LabelNode{} = return [] +getChildren _ CCDetails {} = return [] +getChildren _ InfoDetails {} = return [] getChildren d (ClosureDetails c _ _) = do children <- closureReferences d c children' <- traverse (traverse (fillListItem d)) children mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children' -getChildren _ _ = return [] +getChildren d (CCSDetails _ _ cp) = do + references <- zip [0 :: Int ..] <$> ccsReferences d cp + mapM (\(lbl, cc) -> getClosureDetails d (pack (show lbl)) cc) references + fillListItem :: Debuggee -> ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr -> IO (ListItem CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr) fillListItem _ (ListOnlyInfo x) = return $ ListOnlyInfo x -fillListItem d(ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd +fillListItem d (ListFullClosure cd) = ListFullClosure <$> fillConstrDesc d cd fillListItem _ ListData = return ListData +fillListItem _ (ListCCS c1 c2) = return $ ListCCS c1 c2 +fillListItem _ (ListCC c1) = return $ ListCC c1 mkIOTree :: Debuggee -> [a] @@ -513,7 +535,11 @@ renderInlineClosureDesc :: ClosureDetails -> [Widget n] renderInlineClosureDesc (LabelNode t) = [txtLabel t] renderInlineClosureDesc (InfoDetails info') = [txtLabel (_labelInParent info'), txt " ", txt (_pretty info')] -renderInlineClosureDesc closureDesc = +renderInlineClosureDesc (CCSDetails label _cptr ccspayload) = + [ txtLabel label, txt " ", txt (prettyCCS ccspayload)] +renderInlineClosureDesc (CCDetails label cc) = + [ txtLabel label, txt " ", txt (prettyCC cc)] +renderInlineClosureDesc closureDesc@(ClosureDetails{}) = [ txtLabel (_labelInParent (_info closureDesc)) , txt " " , colorEra $ txt $ pack (closureShowAddress (_closure closureDesc)) @@ -526,6 +552,13 @@ renderInlineClosureDesc closureDesc = Just (Debug.EraWord i) -> modifyDefAttr (flip Vty.withBackColor (era_colors !! (1 + (fromIntegral $ abs i) `mod` (length era_colors - 1)))) _ -> id +prettyCCS :: GenCCSPayload CCSPtr CCPayload -> Text +prettyCCS Debug.CCSPayload{ccsCc = cc} = prettyCC cc + +prettyCC :: CCPayload -> Text +prettyCC Debug.CCPayload{..} = + T.pack ccLabel <> " " <> T.pack ccMod <> " " <> T.pack ccLoc + completeClosureDetails :: Debuggee -> (Text, DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr) -> IO ClosureDetails @@ -541,6 +574,8 @@ getClosureDetails :: Debuggee getClosureDetails debuggee' t (ListOnlyInfo info_ptr) = do info' <- getInfoInfo debuggee' t info_ptr return $ InfoDetails info' +getClosureDetails _ plabel (ListCCS ccs payload) = return $ CCSDetails plabel ccs payload +getClosureDetails _ plabel (ListCC cc) = return $ CCDetails plabel cc getClosureDetails _ t ListData = return $ LabelNode t getClosureDetails debuggee' label' (ListFullClosure c) = do let excSize' = closureExclusiveSize c @@ -867,7 +902,8 @@ mkRetainerTree dbg stacks = do cs <- getChildren dbg' dc' results' <- liftIO $ mapM (\(l, c) -> getClosureDetails dbg' l (ListFullClosure c)) results return (cs ++ results') - lookup_c _ _ = return [] + -- And if it's not a closure, just do the normal thing + lookup_c dbg' dc' = getChildren dbg' dc' mkIOTree dbg roots lookup_c renderInlineClosureDesc id diff --git a/ghc-debug-brick/src/Model.hs b/ghc-debug-brick/src/Model.hs index 5feed90af9a4bb5e2c8019b560952d1576f8d49c..86aa1a7fb65d9594aa48c3d7a3af6c895cdbfcfc 100644 --- a/ghc-debug-brick/src/Model.hs +++ b/ghc-debug-brick/src/Model.hs @@ -110,7 +110,7 @@ data InfoInfo = InfoInfo , _closureType :: Maybe Text , _constructor :: Maybe Text , _profHeaderInfo :: !(Maybe ProfHeaderWord) - } + } deriving Show data ClosureDetails = ClosureDetails { _closure :: DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr @@ -118,7 +118,9 @@ data ClosureDetails = ClosureDetails , _info :: InfoInfo } | InfoDetails { _info :: InfoInfo } - | LabelNode { _label :: Text } + | CCSDetails Text CCSPtr (GenCCSPayload CCSPtr CCPayload) + | CCDetails Text CCPayload + | LabelNode { _label :: Text } deriving Show data TreeMode = SavedAndGCRoots (ClosureDetails -> Widget Name) | Retainer (ClosureDetails -> Widget Name) (IOTree (ClosureDetails) Name)