diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for ghc-debug-common +## 0.4.0.0 -- 2022-12-14 + +* Add RequestSRT to allow support for tracing SRTs + ## 0.3.0.0 -- 2022-10-06 * Support changes to TSO decoding on GHC HEAD diff --git a/ghc-debug-common.cabal b/ghc-debug-common.cabal --- a/ghc-debug-common.cabal +++ b/ghc-debug-common.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-debug-common -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Connect to a socket created by ghc-debug-stub and analyse the heap of the debuggee program. description: Connect to a socket created by ghc-debug-stub and analyse @@ -38,7 +38,7 @@ transformers ^>= 0.5, dom-lt ^>= 0.2, unordered-containers ^>= 0.2, - ghc-debug-convention == 0.3.0.0, + ghc-debug-convention == 0.4.0.0, deepseq ^>= 1.4 hs-source-dirs: src diff --git a/src/GHC/Debug/Decode.hs b/src/GHC/Debug/Decode.hs --- a/src/GHC/Debug/Decode.hs +++ b/src/GHC/Debug/Decode.hs @@ -183,8 +183,8 @@ st_marking (StackCont st_sp raw_stack)) -decodeFromBS :: RawClosure -> Get (DebugClosure pap string s b) - -> DebugClosureWithExtra Size pap string s b +decodeFromBS :: RawClosure -> Get (DebugClosure srt pap string s b) + -> DebugClosureWithExtra Size srt pap string s b decodeFromBS (RawClosure rc) parser = case runGetOrFail parser (BSL.fromStrict rc) of Left err -> error ("DEC:" ++ show err ++ printBS rc) @@ -221,13 +221,17 @@ return $ k pts (map fromIntegral cwords) decodeArrWords :: (StgInfoTableWithPtr, b) - -> (a, RawClosure) -> DebugClosureWithExtra Size pap string s b1 + -> (a, RawClosure) -> DebugClosureWithExtra Size src pap string s b1 decodeArrWords (infot, _) (_, rc) = decodeFromBS rc $ do _itbl <- skipClosureHeader bytes <- getWord64le - payload <- replicateM (ceiling (fromIntegral bytes / 8)) getWord + payload <- replicateM (fromIntegral $ bytes `ceilIntDiv` 8) getWord return $ GHC.Debug.Types.Closures.ArrWordsClosure infot (fromIntegral bytes) (map fromIntegral payload) +-- | Compute @ceiling (a/b)@. +ceilIntDiv :: Integral a => a -> a -> a +ceilIntDiv a b = (a + b - 1) `div` b + tsoVersionChanged :: Version tsoVersionChanged = Version 905 20220925 @@ -235,7 +239,7 @@ -> (StgInfoTableWithPtr, RawInfoTable) -> (a, RawClosure) -> SizedClosure -decodeTSO ver it@(infot, _) c@(_, rc) = decodeFromBS rc $ do +decodeTSO ver (infot, _) (_, rc) = decodeFromBS rc $ do _itbl <- skipClosureHeader link <- getClosurePtr global_link <- getClosurePtr @@ -297,10 +301,10 @@ decodeStandardLayout (return ()) (\pts ws -> ConstrClosure itb pts ws (tableId itb)) i c | (StgInfoTable { tipe = ty }) <- decodedTable itb , FUN <= ty && ty <= FUN_STATIC = - decodeStandardLayout (return ()) (FunClosure itb) i c + decodeStandardLayout (return ()) (FunClosure itb (tableId itb)) i c | (StgInfoTable { tipe = ty }) <- decodedTable itb , THUNK <= ty && ty <= THUNK_0_2 = - decodeStandardLayout (() <$ getWord) (ThunkClosure itb) i c + decodeStandardLayout (() <$ getWord) (ThunkClosure itb (tableId itb)) i c decodeClosure _ rit rc = decodeWithLibrary rit rc @@ -330,7 +334,7 @@ -- the itbl pointer will point somewhere into our address space -- rather than the debuggee address space -- - return $ DCS s . quadmap absurd + return $ DCS s . quinmap id absurd id absurd mkClosurePtr . convertClosure itb diff --git a/src/GHC/Debug/Decode/Convert.hs b/src/GHC/Debug/Decode/Convert.hs --- a/src/GHC/Debug/Decode/Convert.hs +++ b/src/GHC/Debug/Decode/Convert.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} + {- Convert a GenClosure to a DebugClosure -} module GHC.Debug.Decode.Convert where @@ -8,41 +10,27 @@ import GHC.Debug.Types.Ptr import Data.Void --- | Convert a GenClosure from ghc-heap to a 'DebugClosure', -convertClosure :: (Num a, Eq a, Show a) => StgInfoTableWithPtr -> GHC.GenClosure a -> DebugClosure Void InfoTablePtr Void a +-- | Convert a GenClosure from ghc-heap to a 'DebugClosure'. +-- +-- N.B. This only handles cases not already handled by +-- 'GHC.Debug.Decode.decodeClosure'. Eventually this codepath should be +-- retired. +convertClosure :: (Num a, Eq a, Show a) => StgInfoTableWithPtr -> GHC.GenClosure a -> DebugClosure InfoTablePtr Void InfoTablePtr Void a convertClosure itb g = case g of - GHC.ConstrClosure _ a2 a3 _ _ _ -> ConstrClosure itb a2 a3 (tableId itb) - GHC.FunClosure _ a2 a3 -> FunClosure itb a2 a3 - GHC.ThunkClosure _ a2 a3 -> ThunkClosure itb a2 a3 + -- N.B. decodeClosure doesn't handle THUNK_STATIC + GHC.ThunkClosure _ a2 a3 -> ThunkClosure itb (tableId itb) a2 a3 GHC.SelectorClosure _ a2 -> SelectorClosure itb a2 --- GHC.PAPClosure _ a2 a3 a4 a5 -> PAPClosure itb a2 a3 a4 a5 --- GHC.APClosure _ a2 a3 a4 a5 -> APClosure itb a2 a3 a4 a5 --- GHC.APStackClosure _ a2 a3 -> APStackClosure itb a2 - GHC.IndClosure _ a2 -> IndClosure itb a2 GHC.BCOClosure _ a2 a3 a4 a5 a6 a7 -> BCOClosure itb a2 a3 a4 a5 a6 a7 GHC.BlackholeClosure _ a2 -> BlackholeClosure itb a2 - GHC.ArrWordsClosure _ a2 a3 -> ArrWordsClosure itb a2 a3 GHC.MutArrClosure _ a2 a3 a4 -> MutArrClosure itb a2 a3 a4 GHC.SmallMutArrClosure _ a2 a3 -> SmallMutArrClosure itb a2 a3 GHC.MVarClosure _ a2 a3 a4 -> MVarClosure itb a2 a3 a4 - GHC.MutVarClosure _ a2 -> MutVarClosure itb a2 - GHC.BlockingQueueClosure _ a2 a3 a4 a5 -> BlockingQueueClosure itb a2 a3 a4 a5 - -- GHC.TSOClosure _ a2 a3 a4 a5 a6 a7 _ a8 a9 a10 a11 a12 a13 a14 a15 a16 -> TSOClosure itb a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 - GHC.TSOClosure _ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 -> TSOClosure itb a2 a3 a4 a5 a6 a7 Nothing a8 a9 a10 a11 a12 a13 a14 a15 a16 --- GHC.StackClosure _ a2 a3 a4 a5 -> StackClosure itb a2 a3 a4 (a2, (StackPtr a5)) -{- - GHC.IntClosure a1 a2 -> IntClosure a1 a2 - GHC.WordClosure a1 a2 -> WordClosure a1 a2 - GHC.Int64Closure a1 a2 -> Int64Closure a1 a2 - GHC.Word64Closure a1 a2 -> Word64Closure a1 a2 - GHC.AddrClosure a1 a2 -> AddrClosure a1 a2 - GHC.FloatClosure a1 a2 -> FloatClosure a1 a2 - GHC.DoubleClosure a1 a2 -> DoubleClosure a1 a2 - -} GHC.OtherClosure _ a2 a3 -> OtherClosure itb a2 a3 + GHC.IndClosure _ a2 -> IndClosure itb a2 + GHC.MutVarClosure _ a2 -> MutVarClosure itb a2 GHC.WeakClosure _ a2 a3 a4 a5 a6 -> -#if __GLASGOW_HASKELL__ >= 905 +#if MIN_VERSION_GLASGOW_HASKELL(9,4,2,0) let w_link = a6 #else -- nullPtr check diff --git a/src/GHC/Debug/Decode/Stack.hs b/src/GHC/Debug/Decode/Stack.hs --- a/src/GHC/Debug/Decode/Stack.hs +++ b/src/GHC/Debug/Decode/Stack.hs @@ -33,7 +33,7 @@ getFrame :: PtrBitmap -> StgInfoTableWithPtr - -> Get (DebugStackFrame ClosurePtr) + -> Get (DebugStackFrame SrtCont ClosurePtr) getFrame st_bitmap itbl = case tipe (decodedTable itbl) of RET_BCO -> @@ -49,7 +49,7 @@ --traceShowM (headerSize ty, ty, st_bitmap, itbl) _itblPtr <- replicateM (headerSize ty) getWord64le fields <- traversePtrBitmap decodeField st_bitmap - return (DebugStackFrame itbl fields) + return (DebugStackFrame itbl (tableId itbl) fields) where decodeField True = SPtr . mkClosurePtr <$> getWord decodeField False = SNonPtr <$> getWord diff --git a/src/GHC/Debug/Types.hs b/src/GHC/Debug/Types.hs --- a/src/GHC/Debug/Types.hs +++ b/src/GHC/Debug/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeOperators #-} module GHC.Debug.Types(module T , Request(..) @@ -40,6 +41,7 @@ import qualified Data.ByteString.Char8 as C8 import Data.Word import System.IO +import Data.Functor import Data.Binary import Data.Binary.Put @@ -50,7 +52,6 @@ import GHC.Debug.Types.Ptr as T import GHC.Debug.Types.Version import GHC.Debug.Utils -import GHC.Exts.Heap.ClosureTypes import GHC.Debug.Decode import Control.Concurrent @@ -84,6 +85,12 @@ RequestClosure :: ClosurePtr -> Request RawClosure -- | Request an info table RequestInfoTable :: InfoTablePtr -> Request (StgInfoTableWithPtr, RawInfoTable) + + -- | Request the SRT of an info table. Some closures, like constructors, can never have SRTs. + -- Thunks, functions and stack frames may have SRTs. + -- Returns Nothing when the closure does not have an SRT. + RequestSRT :: InfoTablePtr -> Request (Maybe ClosurePtr) + -- | Wait for the debuggee to pause itself and then -- execute an action. It currently impossible to resume after -- a pause caused by a poll. @@ -124,6 +131,7 @@ RequestRoots -> case r2 of {RequestRoots -> True; _ -> False } RequestClosure cs -> case r2 of {(RequestClosure cs') -> cs == cs'; _ -> False } RequestInfoTable itp -> case r2 of { (RequestInfoTable itp') -> itp == itp'; _ -> False } + RequestSRT itp -> case r2 of { (RequestSRT itp') -> itp == itp'; _ -> False } RequestPoll -> case r2 of { RequestPoll -> True; _ -> False } RequestSavedObjects -> case r2 of {RequestSavedObjects -> True; _ -> False } RequestStackBitmap p o -> case r2 of {(RequestStackBitmap p' o') -> p == p' && o == o'; _ -> False } @@ -154,6 +162,7 @@ case r of RequestVersion {} -> True RequestInfoTable {} -> True + RequestSRT {} -> True RequestSourceInfo {} -> True RequestConstrDesc {} -> True _ -> False @@ -170,6 +179,7 @@ RequestRoots -> s `hashWithSalt` cmdRequestRoots RequestClosure cs -> s `hashWithSalt` cmdRequestClosures `hashWithSalt` cs RequestInfoTable itp -> s `hashWithSalt` cmdRequestInfoTables `hashWithSalt` itp + RequestSRT itp -> s `hashWithSalt` cmdRequestSRT `hashWithSalt` itp RequestPoll -> s `hashWithSalt` cmdRequestPoll RequestSavedObjects -> s `hashWithSalt` cmdRequestSavedObjects RequestStackBitmap p o -> s `hashWithSalt` cmdRequestStackBitmap `hashWithSalt` p `hashWithSalt` o @@ -192,6 +202,7 @@ RequestRoots {} -> cmdRequestRoots RequestClosure {} -> cmdRequestClosures RequestInfoTable {} -> cmdRequestInfoTables + RequestSRT {} -> cmdRequestSRT RequestPoll {} -> cmdRequestPoll RequestSavedObjects {} -> cmdRequestSavedObjects RequestStackBitmap {} -> cmdRequestStackBitmap @@ -243,6 +254,9 @@ cmdRequestFunBitmap :: CommandId cmdRequestFunBitmap = CommandId 16 +cmdRequestSRT :: CommandId +cmdRequestSRT = CommandId 17 + data AnyReq = forall req . AnyReq !(Request req) instance Hashable AnyReq where @@ -274,6 +288,10 @@ putCommand cmdRequestInfoTables $ do putWord16be 1 put ts +putRequest (RequestSRT ts) = + putCommand cmdRequestSRT $ do + putWord16be 1 + put ts putRequest (RequestStackBitmap sp o) = putCommand cmdRequestStackBitmap $ put sp >> putWord32be o putRequest (RequestFunBitmap n cp) = @@ -311,6 +329,10 @@ --itbs <- replicateM (fromIntegral n) get itb <- get return (AnyReq (RequestInfoTable itb)) + | cmd == cmdRequestSRT -> do + _n <- getWord16be + itb <- get + return (AnyReq (RequestSRT itb)) | cmd == cmdRequestStackBitmap -> do sp <- get o <- getWord32be @@ -341,6 +363,10 @@ getResponse RequestRoots = many get getResponse (RequestClosure {}) = get getResponse (RequestInfoTable itbp) = (\(it, r) -> (StgInfoTableWithPtr itbp it, r)) <$> getInfoTable +getResponse (RequestSRT {}) = do + cptr <- get + pure $ guard (cptr /= UntaggedClosurePtr 0) $> cptr + -- zipWith (\p (it, r) -> (StgInfoTableWithPtr p it, r)) itps -- <$> replicateM (length itps) getInfoTable getResponse (RequestStackBitmap {}) = get diff --git a/src/GHC/Debug/Types/Closures.hs b/src/GHC/Debug/Types/Closures.hs --- a/src/GHC/Debug/Types/Closures.hs +++ b/src/GHC/Debug/Types/Closures.hs @@ -22,6 +22,7 @@ Closure , SizedClosure , SizedClosureC + , SizedClosureP , DebugClosure(..) , TRecEntry(..) -- * Wrappers @@ -51,10 +52,14 @@ , ConstrDesc(..) , ConstrDescCont , parseConstrDesc + -- * SRT field representation + , GenSrtPayload(..) + , SrtPayload + , SrtCont -- * Traversing functions - , Quadtraversable(..) - , quadmap + , Quintraversable(..) + , quinmap ) where import Prelude -- See note [Why do we import Prelude here?] @@ -71,21 +76,24 @@ import GHC.Exts import GHC.Generics import GHC.Debug.Types.Ptr -import Data.List (sortBy, intercalate) +import Data.List (intercalate) import Data.Char -import Data.Kind import Control.Applicative import Data.Monoid +import Data.Bitraversable +import Data.Bifunctor +import Data.Bifoldable ------------------------------------------------------------------------ -- Closures -type Closure = DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr -type SizedClosure = DebugClosureWithSize PayloadCont ConstrDescCont StackCont ClosurePtr -type SizedClosureC = DebugClosureWithSize PayloadCont ConstrDesc StackCont ClosurePtr +type Closure = DebugClosure SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr +type SizedClosure = DebugClosureWithSize SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr +type SizedClosureC = DebugClosureWithSize SrtCont PayloadCont ConstrDesc StackCont ClosurePtr +type SizedClosureP = DebugClosureWithSize SrtPayload PapPayload ConstrDesc StackCont ClosurePtr -- | Information needed to decode a 'ConstrDesc' type ConstrDescCont = InfoTablePtr @@ -95,8 +103,8 @@ type DebugClosureWithSize = DebugClosureWithExtra Size -data DebugClosureWithExtra x pap string s b = DCS { extraDCS :: x - , unDCS :: DebugClosure pap string s b } +data DebugClosureWithExtra x srt pap string s b = DCS { extraDCS :: x + , unDCS :: DebugClosure srt pap string s b } deriving (Show, Ord, Eq) -- | Exclusive size @@ -114,14 +122,14 @@ deriving (Semigroup, Monoid) via (Sum Int) -noSize :: DebugClosureWithSize pap string s b -> DebugClosure pap string s b +noSize :: DebugClosureWithSize srt pap string s b -> DebugClosure srt pap string s b noSize = unDCS -dcSize :: DebugClosureWithSize pap string s b -> Size +dcSize :: DebugClosureWithSize srt pap string s b -> Size dcSize = extraDCS -instance Quadtraversable (DebugClosureWithExtra x) where - quadtraverse f g h i (DCS x v) = DCS x <$> quadtraverse f g h i v +instance Quintraversable (DebugClosureWithExtra x) where + quintraverse f g h i j (DCS x v) = DCS x <$> quintraverse f g h i j v data StgInfoTableWithPtr = StgInfoTableWithPtr { tableId :: InfoTablePtr @@ -149,7 +157,7 @@ -- See -- -- for more information. -data DebugClosure pap string s b +data DebugClosure srt pap string s b = -- | A data constructor ConstrClosure { info :: !StgInfoTableWithPtr @@ -161,6 +169,7 @@ -- | A function | FunClosure { info :: !StgInfoTableWithPtr + , srt :: !(srt) , ptrArgs :: ![b] -- ^ Pointer arguments , dataArgs :: ![Word] -- ^ Non-pointer arguments } @@ -168,6 +177,7 @@ -- | A thunk, an expression not obviously in head normal form | ThunkClosure { info :: !StgInfoTableWithPtr + , srt :: !(srt) , ptrArgs :: ![b] -- ^ Pointer arguments , dataArgs :: ![Word] -- ^ Non-pointer arguments } @@ -304,7 +314,7 @@ , flags :: [GHC.TsoFlags] , threadId :: Word64 , saved_errno :: Word32 - , dirty:: Word32 + , dirty :: Word32 , alloc_limit :: Int64 , tot_stack_size :: Word32 , prof :: Maybe ProfTypes.StgTSOProfInfo @@ -375,23 +385,52 @@ type PapPayload = GenPapPayload ClosurePtr +newtype GenSrtPayload b = GenSrtPayload { getSrt :: Maybe b } + deriving (Functor, Foldable, Traversable, Show, Ord, Eq) + +type SrtPayload = GenSrtPayload ClosurePtr + +type SrtCont = InfoTablePtr + -- | Information needed to decode a set of stack frames data StackCont = StackCont StackPtr -- Address of start of frames RawStack -- The raw frames deriving (Show, Eq, Ord) -type StackFrames = GenStackFrames ClosurePtr -newtype GenStackFrames b = GenStackFrames { getFrames :: [DebugStackFrame b] } +type StackFrames = GenStackFrames SrtCont ClosurePtr +newtype GenStackFrames srt b = GenStackFrames { getFrames :: [DebugStackFrame srt b] } deriving (Functor, Foldable, Traversable, Show, Ord, Eq) -data DebugStackFrame b +instance Bifoldable GenStackFrames where + bifoldMap f g (GenStackFrames frames) = foldMap (bifoldMap f g) frames + +instance Bitraversable GenStackFrames where + bitraverse f g (GenStackFrames frames) = GenStackFrames <$> traverse (bitraverse f g) frames + +instance Bifunctor GenStackFrames where + bimap f g (GenStackFrames frames) = GenStackFrames (fmap (bimap f g) frames) + + + +data DebugStackFrame srt b = DebugStackFrame { frame_info :: !StgInfoTableWithPtr + , frame_srt :: srt , values :: [FieldValue b] } deriving (Traversable, Functor, Foldable, Show, Ord, Eq) +instance Bifunctor DebugStackFrame where + bimap f g (DebugStackFrame itbl srt v) = DebugStackFrame itbl (f srt) (fmap (fmap g) v) +instance Bifoldable DebugStackFrame where + bifoldMap f g (DebugStackFrame _ srt v) = f srt <> foldMap (foldMap g) v + +instance Bitraversable DebugStackFrame where + bitraverse f g (DebugStackFrame itbl srt v) = DebugStackFrame itbl <$> f srt <*> traverse (traverse g) v + + + data ConstrDesc = ConstrDesc { pkg :: !String -- ^ Package name , modl :: !String -- ^ Module name @@ -428,37 +467,39 @@ (top, _:bot) -> parseModOcc (top : acc) bot parseModOcc acc str = (acc, str) -class Quadtraversable m where - quadtraverse :: +class Quintraversable m where + quintraverse :: Applicative f => (a -> f b) -> (c -> f d) -> (e -> f g) -> (h -> f i) - -> m a c e h - -> f (m b d g i) + -> (j -> f k) + -> m a c e h j + -> f (m b d g i k) -quadmap :: forall a b c d e f g h t . Quadtraversable t => (a -> b) -> (c -> d) -> (e -> f) -> (g -> h) -> t a c e g -> t b d f h -quadmap = coerce - (quadtraverse :: (a -> Identity b) +quinmap :: forall a b c d e f g h i j t . Quintraversable t => (a -> b) -> (c -> d) -> (e -> f) -> (g -> h) -> (i -> j) -> t a c e g i -> t b d f h j +quinmap = coerce + (quintraverse :: (a -> Identity b) -> (c -> Identity d) -> (e -> Identity f) -> (g -> Identity h) - -> t a c e g -> Identity (t b d f h)) + -> (i -> Identity j) + -> t a c e g i -> Identity (t b d f h j)) -allClosures :: DebugClosure (GenPapPayload c) a (GenStackFrames c) c -> [c] -allClosures c = getConst $ quadtraverse (traverse (Const . (:[]))) (const (Const [])) (traverse (Const . (:[]))) (Const . (:[])) c +allClosures :: DebugClosure (GenSrtPayload c) (GenPapPayload c) a (GenStackFrames (GenSrtPayload c) c) c -> [c] +allClosures c = getConst $ quintraverse (traverse (Const . (:[]))) (traverse (Const . (:[]))) (const (Const [])) (traverse (Const . (:[]))) (Const . (:[])) c data FieldValue b = SPtr b | SNonPtr !Word64 deriving (Show, Traversable, Functor, Foldable, Ord, Eq) -instance Quadtraversable DebugClosure where - quadtraverse p h f g c = +instance Quintraversable DebugClosure where + quintraverse srt p h f g c = case c of ConstrClosure a1 bs ds str -> (\cs cstr -> ConstrClosure a1 cs ds cstr) <$> traverse g bs <*> h str - FunClosure a1 bs ws -> (\cs -> FunClosure a1 cs ws) <$> traverse g bs - ThunkClosure a1 bs ws -> (\cs -> ThunkClosure a1 cs ws) <$> traverse g bs + FunClosure a1 srt_p bs ws -> (\srt' cs -> FunClosure a1 srt' cs ws) <$> srt srt_p <*> traverse g bs + ThunkClosure a1 srt_p bs ws -> (\srt' cs -> ThunkClosure a1 srt' cs ws) <$> srt srt_p <*> traverse g bs SelectorClosure a1 b -> SelectorClosure a1 <$> g b PAPClosure a1 a2 a3 a4 a5 -> PAPClosure a1 a2 a3 <$> g a4 <*> p a5 APClosure a1 a2 a3 a4 a5 -> APClosure a1 a2 a3 <$> g a4 <*> p a5 diff --git a/src/GHC/Debug/Types/Graph.hs b/src/GHC/Debug/Types/Graph.hs --- a/src/GHC/Debug/Types/Graph.hs +++ b/src/GHC/Debug/Types/Graph.hs @@ -13,6 +13,7 @@ , HeapGraphIndex , PapHI , StackHI + , SrtHI -- * Building a heap graph , DerefFunction , buildHeapGraph @@ -52,6 +53,7 @@ import GHC.Debug.Types.Closures import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) +import Data.Bitraversable -- | For heap graphs, i.e. data structures that also represent sharing and -- cyclic structures, these are the entries. If the referenced value is @@ -62,13 +64,14 @@ -- have a slot for arbitrary data, for the user's convenience. data HeapGraphEntry a = HeapGraphEntry { hgeClosurePtr :: ClosurePtr, - hgeClosure :: DebugClosure PapHI ConstrDesc StackHI (Maybe HeapGraphIndex), + hgeClosure :: DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe HeapGraphIndex), hgeData :: a} deriving (Show, Functor, Foldable, Traversable) type HeapGraphIndex = ClosurePtr -type StackHI = GenStackFrames (Maybe HeapGraphIndex) +type StackHI = GenStackFrames (GenSrtPayload (Maybe HeapGraphIndex)) (Maybe HeapGraphIndex) type PapHI = GenPapPayload (Maybe HeapGraphIndex) +type SrtHI = GenSrtPayload (Maybe HeapGraphIndex) -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph', -- as the internal representation may change. Nevertheless, we export it here: @@ -115,7 +118,7 @@ -- dereferenced, but also, not such a big deal. It could lead to additional -- requests to the debuggee which are not necessary and causes a mismatch -- with the step-by-step decoding functions in `Client.hs` -type DerefFunction m a = ClosurePtr -> m (DebugClosureWithExtra a PapPayload ConstrDesc StackFrames ClosurePtr) +type DerefFunction m a = ClosurePtr -> m (DebugClosureWithExtra a SrtPayload PapPayload ConstrDesc (GenStackFrames SrtPayload ClosurePtr) ClosurePtr) -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing -- further than the given limit. @@ -166,7 +169,7 @@ -- get into an infinite loop with cycles in the heap. rec modify' (insertHeapGraph cp (HeapGraphEntry cp c' e)) -- Add the resulting closure below to the map (above): - DCS e c' <- quadtraverse (traverse new_add) pure (traverse new_add) new_add c + DCS e c' <- quintraverse (traverse new_add) (traverse new_add) pure (bitraverse (traverse new_add) new_add) new_add c return (Just cp) -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example @@ -211,7 +214,7 @@ ppEntry prec hge | Just s <- isString (hgeClosure hge) = show s | Just l <- isList (hgeClosure hge) = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]" - | otherwise = ppClosure (printData (hgeData hge)) ppRef prec (hgeClosure hge) + | otherwise = ppClosure ppRef prec (hgeClosure hge) where _app [a] = a ++ "()" _app xs = addBraces (10 <= prec) (unwords xs) @@ -225,7 +228,7 @@ | cp `elem` bindings = Nothing | otherwise = IM.lookup (fromIntegral i) m - isList :: DebugClosure p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex] + isList :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex] isList c | isNil c = return [] @@ -236,7 +239,7 @@ t' <- isList (hgeClosure e) return $ (:) h t' - isString :: DebugClosure p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe String + isString :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe String isString e = do list <- isList e -- We do not want to print empty lists as "" as we do not know that they @@ -262,19 +265,19 @@ braceize [] = "" braceize xs = "{" ++ intercalate "," xs ++ "}" -isChar :: DebugClosure p ConstrDesc s c -> Maybe Char +isChar :: DebugClosure srt p ConstrDesc s c -> Maybe Char isChar ConstrClosure{ constrDesc = ConstrDesc {pkg = "ghc-prim", modl = "GHC.Types", name = "C#"}, dataArgs = [ch], ptrArgs = []} = Just (chr (fromIntegral ch)) isChar _ = Nothing -isNil :: DebugClosure p ConstrDesc s c -> Bool +isNil :: DebugClosure srt p ConstrDesc s c -> Bool isNil ConstrClosure{ constrDesc = ConstrDesc {pkg = "ghc-prim", modl = "GHC.Types", name = "[]"}, dataArgs = _, ptrArgs = []} = True isNil _ = False -isCons :: DebugClosure p ConstrDesc s c -> Maybe (c, c) +isCons :: DebugClosure srt p ConstrDesc s c -> Maybe (c, c) isCons ConstrClosure{ constrDesc = ConstrDesc {pkg = "ghc-prim", modl = "GHC.Types", name = ":"}, dataArgs = [], ptrArgs = [h,t]} = Just (h,t) isCons _ = Nothing -isTup :: DebugClosure p ConstrDesc s c -> Maybe [c] +isTup :: DebugClosure srt p ConstrDesc s c -> Maybe [c] isTup ConstrClosure{ dataArgs = [], ..} = if length (name constrDesc) >= 3 && head (name constrDesc) == '(' && last (name constrDesc) == ')' && @@ -289,8 +292,8 @@ -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'. -- -- The parameter gives the precedendence, to avoid avoidable parenthesises. -ppClosure :: String -> (Int -> c -> String) -> Int -> DebugClosure p ConstrDesc s c -> String -ppClosure herald showBox prec c = case c of +ppClosure :: (Int -> c -> String) -> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String +ppClosure showBox prec c = case c of _ | Just ch <- isChar c -> app ["C#", show ch] _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $ @@ -300,7 +303,11 @@ ConstrClosure {..} -> app $ name constrDesc : map (showBox 10) ptrArgs ++ map show dataArgs ThunkClosure {..} -> app $ - "_thunk(" : herald : ")" : map (showBox 10) ptrArgs ++ map show dataArgs + let srt_string = case getSrt srt of + Nothing -> [] + Just s -> ["{", showBox 10 s, "}"] + in ["_thunk" ++ unwords srt_string] ++ map (showBox 10) ptrArgs ++ map show dataArgs + SelectorClosure {..} -> app ["_sel", showBox 10 selectee] IndClosure {..} -> app @@ -329,7 +336,10 @@ MVarClosure {..} -> app ["MVar", showBox 10 value] FunClosure {..} -> - "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs) + let srt_string = case getSrt srt of + Nothing -> [] + Just s -> ["{", showBox 10 s, "}"] + in "_fun" ++ (unwords srt_string) ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs) BlockingQueueClosure {} -> "_blockingQueue" OtherClosure {} ->