ghc-debug-common 0.3.0.0 → 0.4.0.0

raw patch · 8 files changed

+158/−85 lines, 8 filesdep ~ghc-debug-conventionPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-debug-convention

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• ghc-debug-common.cabal +2/−2
• src/GHC/Debug/Decode.hs +12/−8
• src/GHC/Debug/Decode/Convert.hs +13/−25
• src/GHC/Debug/Decode/Stack.hs +2/−2
• src/GHC/Debug/Types.hs +27/−1
• src/GHC/Debug/Types/Closures.hs +73/−32
• src/GHC/Debug/Types/Graph.hs +25/−15

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 -- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects> -- 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

@@ -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 {} ->