ghc-debug-common 0.5.0.0 → 0.6.0.0

raw patch · 11 files changed

+925/−422 lines, 11 filesdep −ghc-heapdep ~deepseqdep ~filepathdep ~ghc-debug-conventionPVP ok

version bump matches the API change (PVP)

Dependencies removed: ghc-heap

Dependency ranges changed: deepseq, filepath, ghc-debug-convention

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• cbits/GhcDebug.cmm +0/−69
• cbits/Heap.c +0/−26
• ghc-debug-common.cabal +4/−8
• src/GHC/Debug/Decode.hs +354/−178
• src/GHC/Debug/Decode/Convert.hs +0/−43
• src/GHC/Debug/Types.hs +202/−8
• src/GHC/Debug/Types/Closures.hs +291/−67
• src/GHC/Debug/Types/Graph.hs +13/−11
• src/GHC/Debug/Types/Ptr.hs +41/−12
• src/GHC/Debug/Types/Version.hs +14/−0

@@ -1,5 +1,11 @@ # Revision history for ghc-debug-common +## 0.6.0.0 -- 2024-04-10++* Support for decoding profiled RTS+* Remove dependency on ghc-heap, all closures are decoded natively without+  any dependency on the compiler used to build ghc-debug.+ ## 0.5.0.0 -- 2023-06-06  * Bump to keep in sync with other libraries

@@ -1,69 +0,0 @@-#include "Cmm.h"---closureSizezh ( P_ closure )-{-    W_ clos;-    clos = UNTAG(closure);--    W_ len;-    (len) = foreign "C" heap_view_closureSize(clos "ptr");-    return (len);-}--unpackClosureDatzh ( P_ closure )-{-    W_ p, ptrs_arr, dat_arr;--    W_ clos;-    clos = UNTAG(closure);--    W_ len;-    (len) = foreign "C" heap_view_closureSize(clos "ptr");-    foreign "C" printf("unpack %p %d\n", clos, len);--    W_ dat_arr_sz;-    dat_arr_sz = SIZEOF_StgArrBytes + WDS(len);--    ALLOC_PRIM_N (dat_arr_sz, unpackClosureDatzh, closure);-    foreign "C" printf("unpack(2) %p %d\n", clos, len);--    dat_arr = Hp - dat_arr_sz + WDS(1);--    SET_HDR(dat_arr, stg_ARR_WORDS_info, CCCS);-    StgArrBytes_bytes(dat_arr) = WDS(len);-    foreign "C" printf("unpack(3) %p %d\n", clos, len);-    p = 0;-for:-    if(p < len) {-         foreign "C" printf("unpack(3a) %p %d/%d %p\n", clos,p, len, clos + WDS(p));-         W_[BYTE_ARR_CTS(dat_arr) + WDS(p)] = W_[clos + WDS(p)];-         p = p + 1;--         goto for;-    }-    foreign "C" printf("unpack(4) %p %d\n", clos, len);---    return (dat_arr);-}--unpackClosureInfozh ( P_ closure )-{-    W_ info;-    info = %GET_STD_INFO(UNTAG(closure));--    return (info);-}--unpackClosurePtrzh ( P_ closure )-{-    W_ clos;-    clos = UNTAG(closure);--    W_ ptrArray;--    ("ptr" ptrArray) = foreign "C" heap_view_closurePtrsAsWords(MyCapability() "ptr", clos "ptr");--    return (ptrArray);-}

@@ -1,26 +0,0 @@-#include <Rts.h>-#include "rts/storage/Heap.h"--StgArrBytes *heap_view_closurePtrsAsWords(Capability *cap, StgClosure *closure) {-    ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));--    StgWord size = heap_view_closureSize(closure);--    // First collect all pointers here, with the comfortable memory bound-    // of the whole closure. Afterwards we know how many pointers are in-    // the closure and then we can allocate space on the heap and copy them-    // there-    StgClosure *ptrs[size];-    StgWord nptrs = collect_pointers(closure, ptrs);-    StgArrBytes *arr =-        (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + nptrs);-    TICK_ALLOC_PRIM(sizeofW(StgArrBytes), nptrs, 0);-    SET_HDR(arr, &stg_ARR_WORDS_info, ((CapabilityPublic *)cap)->r.rCCCS);-    arr->bytes = sizeof(StgWord) * nptrs;--    for (StgWord i = 0; i<nptrs; i++) {-        arr->payload[i] = (StgWord)ptrs[i];-    }--    return arr;-}

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                ghc-debug-common-version:             0.5.0.0+version:             0.6.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@@ -17,7 +17,6 @@  library   exposed-modules:     GHC.Debug.Decode,-                       GHC.Debug.Decode.Convert,                        GHC.Debug.Decode.Stack,                        GHC.Debug.Types,                        GHC.Debug.Types.Closures,@@ -30,20 +29,17 @@                        binary ^>=0.8,                        array ^>= 0.5,                        directory ^>= 1.3 ,-                       filepath ^>= 1.4,+                       filepath >= 1.4 && < 1.6,                        hashable >= 1.3 && <= 1.5,-                       ghc-heap >= 9.1,                        cpu ^>= 0.1,                        containers ^>= 0.6,                        transformers >= 0.5 && < 0.7 ,                        dom-lt ^>= 0.2,                        unordered-containers ^>= 0.2,-                       ghc-debug-convention == 0.5.0.0,-                       deepseq ^>= 1.4+                       ghc-debug-convention == 0.6.0.0,+                       deepseq >= 1.4    hs-source-dirs:      src-  cmm-sources:         cbits/GhcDebug.cmm-  c-sources:           cbits/Heap.c   ghc-options: -Wall   default-language:    Haskell2010   default-extensions: ApplicativeDo

@@ -11,108 +11,84 @@ -- bytes module GHC.Debug.Decode ( decodeClosure                         , decodeInfoTable+                        , decodeCCS+                        , decodeIndexTable                         ) where -import GHC.Ptr (plusPtr, castPtr)-import GHC.Exts hiding (closureSize#) -- (Addr#, unsafeCoerce#, Any, Word#, ByteArray#)+ -- (Addr#, unsafeCoerce#, Any, Word#, ByteArray#) import GHC.Word-import GHC.IO.Unsafe-import Foreign.Storable -import qualified Data.ByteString.Internal as BSI-import Data.ByteString.Short.Internal (ShortByteString(..), toShort) import qualified Data.ByteString.Lazy as BSL -import GHC.Exts.Heap (GenClosure)-import GHC.Exts.Heap hiding (GenClosure(..), Closure)-import qualified GHC.Exts.Heap.InfoTable as Itbl-import qualified GHC.Exts.Heap.InfoTableProf as ItblProf- import GHC.Debug.Types.Ptr import GHC.Debug.Types.Version import GHC.Debug.Types.Closures-import GHC.Debug.Decode.Convert-import Foreign.Marshal.Alloc    (allocaBytes)-import Foreign.ForeignPtr       (withForeignPtr) import Data.Binary.Get as B import Data.Binary import Control.Monad-import Data.Void-import Control.DeepSeq-import GHC.Exts.Heap.FFIClosures--import qualified Data.ByteString as B--foreign import prim "unpackClosurePtrzh" unpackClosurePtr# ::-              Addr# -> (# ByteArray# #)--foreign import prim "closureSizezh" closureSize# ::-              Addr# -> (# Word# #)--getClosureRaw :: StgInfoTable -> Ptr a -> BSI.ByteString -> IO (GenClosure Word, Size)-getClosureRaw itb (Ptr closurePtr) datString = do-  let !(# pointers #) = unpackClosurePtr# closurePtr-      !(# raw_size_wh #) = closureSize# closurePtr-      raw_size = fromIntegral (W# raw_size_wh) * 8-  -- Not strictly necessary to take the size of the raw string but its-  -- a good sanity check. In particular it helps with stack decoding.-  let !(SBS datArr) = (toShort (B.take raw_size datString))-  let nelems_ptrs = (I# (sizeofByteArray# pointers)) `div` 8-      end_ptrs = fromIntegral nelems_ptrs - 1-      rawPtrs = force [W# (indexWordArray# pointers i) | I# i <- [0.. end_ptrs] ]-  gen_closure <- getClosureDataFromHeapRepPrim (return ("", "", ""))-                                               (\_ -> return Nothing) itb datArr  rawPtrs-  return (gen_closure, Size raw_size)+import Data.Bits+import Data.Functor+import GHC.Debug.Types (getCCS, getIndexTable) --- | Allow access directly to the chunk of memory used by a bytestring-allocate :: BSI.ByteString -> (Ptr a -> IO a) -> IO a-allocate = allocateByCopy+decodeClosureHeader :: Version -> Get (Maybe ProfHeaderWithPtr)+decodeClosureHeader ver = do+  () <$ skip (8 * 1)+  getProfHeader ver +getProfHeader :: Version -> Get (Maybe ProfHeaderWithPtr)+getProfHeader ver =+  case v_profiling ver of+    Nothing -> pure Nothing+    Just mode -> do+      ccs <- get+      header <- getWord64le+      pure $ Just $ ProfHeader ccs (decodeHeader mode header) --- | Allocate a bytestring directly into memory and return a pointer to the--- allocated buffer-allocateByCopy :: BSI.ByteString -> (Ptr a -> IO a) -> IO a-allocateByCopy (BSI.PS fp o l) action =- allocaBytes l $ \buf ->-   withForeignPtr fp $ \p -> do-     --print (fp, o, l)-     BSI.memcpy buf (p `plusPtr` o) (fromIntegral l)-     action (castPtr buf)+decodeHeader :: ProfilingMode -> Word64 -> ProfHeaderWord+decodeHeader mode hp = case mode of+  NoProfiling -> OtherHeader hp+  OtherProfiling -> OtherHeader hp+  -- TODO handle 32 bit+  RetainerProfiling -> RetainerHeader (testBit hp 0) (RetainerSetPtr $ clearBit hp 0)+  LDVProfiling -> LDVWord (testBit hp 60) (fromIntegral ((hp .&. _LDV_CREATE_MASK) `shiftR` _LDV_SHIFT)) (fromIntegral (hp .&. _LDV_LAST_MASK))+  EraProfiling -> EraWord hp -skipClosureHeader :: Get ()-skipClosureHeader-  | profiling = () <$ skip (8 * 3)-  | otherwise = () <$ skip (8 * 1)+_LDV_CREATE_MASK, _LDV_LAST_MASK :: Word64+_LDV_CREATE_MASK = 0x0FFFFFFFC0000000+_LDV_LAST_MASK = 0x000000003FFFFFFF+_LDV_SHIFT :: Int+_LDV_SHIFT = 30 -decodePAPClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodePAPClosure (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+decodePAPClosure :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodePAPClosure ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver   carity <- getWord32le   nargs <- getWord32le   funp <- getClosurePtr   cpayload <- replicateM (fromIntegral nargs) getWord64le   let cont = PayloadCont funp cpayload-  return $ (GHC.Debug.Types.Closures.PAPClosure infot carity nargs funp cont)+  return $ (GHC.Debug.Types.Closures.PAPClosure infot prof carity nargs funp cont) -decodeAPClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodeAPClosure (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader-  _itbl <- skipClosureHeader+decodeAPClosure :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeAPClosure ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver+  _smp_header <- getWord64le+  -- _itbl <- decodeClosureHeader   carity <- getWord32le   nargs <- getWord32le   funp <- getClosurePtr   cpayload <- replicateM (fromIntegral nargs) getWord64le   let cont = PayloadCont funp cpayload-  return $ (GHC.Debug.Types.Closures.APClosure infot carity nargs funp cont)+  return $ (GHC.Debug.Types.Closures.APClosure infot prof carity nargs funp cont)  -decodeTVarClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodeTVarClosure (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+decodeTVarClosure :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeTVarClosure ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver   ptr <- getClosurePtr   watch_queue <- getClosurePtr   updates <- getInt64le-  return $ (TVarClosure infot ptr watch_queue (fromIntegral updates))+  return $ (TVarClosure infot prof ptr watch_queue (fromIntegral updates))  getClosurePtr :: Get ClosurePtr getClosurePtr = get@@ -120,22 +96,31 @@ getWord :: Get Word64 getWord = getWord64le -decodeMutPrim :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodeMutPrim (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+decodeMutPrim :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeMutPrim ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver   let kptrs = fromIntegral (ptrs (decodedTable infot))       kdat = fromIntegral (nptrs (decodedTable infot))   pts <- replicateM kptrs getClosurePtr   dat <- replicateM kdat (fromIntegral <$> getWord64le)-  return $ (MutPrimClosure infot pts dat)+  return $ (MutPrimClosure infot prof pts dat) -decodeTrecChunk :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodeTrecChunk (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+decodePrim :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodePrim ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver+  let kptrs = fromIntegral (ptrs (decodedTable infot))+      kdat = fromIntegral (nptrs (decodedTable infot))+  pts <- replicateM kptrs getClosurePtr+  dat <- replicateM kdat (fromIntegral <$> getWord64le)+  return $ (PrimClosure infot prof pts dat)++decodeTrecChunk :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeTrecChunk ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver   prev <- getClosurePtr   clos_next_idx <- getWord64le   chunks <- replicateM (fromIntegral clos_next_idx) getChunk-  return $ (TRecChunkClosure infot prev (fromIntegral clos_next_idx) chunks)+  return $ (TRecChunkClosure infot prof prev (fromIntegral clos_next_idx) chunks)   where     getChunk = do       TRecEntry <$> getClosurePtr@@ -145,20 +130,20 @@                                                   -- Not sure how it should                                                   -- be decoded -decodeBlockingQueue :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodeBlockingQueue (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+decodeBlockingQueue :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeBlockingQueue ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver   q <- getClosurePtr   bh <- getClosurePtr   tso <- getClosurePtr   bh_q <- getClosurePtr-  return $ (GHC.Debug.Types.Closures.BlockingQueueClosure infot q bh tso bh_q)+  return $ (GHC.Debug.Types.Closures.BlockingQueueClosure infot prof q bh tso bh_q)  -- It is just far simpler to directly decode the stack here rather than use -- the existing logic in ghc-heap......-decodeStack :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodeStack (infot, _) (cp, rc) = decodeFromBS rc $ do-   _itbl <- skipClosureHeader+decodeStack :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeStack ver (infot, _) (cp, rc) = decodeFromBS rc $ do+   prof <- decodeClosureHeader ver    st_size <- getWord32le    st_dirty <- getWord8    st_marking <- getWord8@@ -178,13 +163,14 @@    raw_stack <- RawStack <$> getByteString (fromIntegral len)    return (GHC.Debug.Types.Closures.StackClosure             infot+            prof             st_size             st_dirty             st_marking             (StackCont st_sp raw_stack)) -decodeFromBS :: RawClosure -> Get (DebugClosure srt pap string s b)-                           -> DebugClosureWithExtra Size srt pap string s b+decodeFromBS :: RawClosure -> Get (DebugClosure ccs srt pap string s b)+                           -> DebugClosureWithExtra Size ccs srt pap string s b decodeFromBS (RawClosure rc) parser =   case runGetOrFail parser (BSL.fromStrict rc) of     Left err -> error ("DEC:" ++ show err ++ printBS rc)@@ -192,10 +178,16 @@       let !s = fromIntegral o       in DCS (Size s) v -decodeAPStack :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure-decodeAPStack (infot, _) (ClosurePtr cp, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader-  _itbl <- skipClosureHeader+decodeFromBS' :: RawClosure -> Get a -> a+decodeFromBS' (RawClosure rc) parser =+  case runGetOrFail parser (BSL.fromStrict rc) of+    Left err -> error ("DEC:" ++ show err ++ printBS rc)+    Right (_rem, _offset, v) -> v++decodeAPStack :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeAPStack ver (infot, _) (ClosurePtr cp, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver+  _smp_header <- getWord64le   st_size <- getWord   fun_closure <- getClosurePtr   k <- bytesRead@@ -203,50 +195,67 @@   clos_payload <- RawStack <$> getByteString (fromIntegral st_size)   return $ GHC.Debug.Types.Closures.APStackClosure               infot+              prof               (fromIntegral st_size)               fun_closure               (StackCont sp clos_payload) -decodeStandardLayout :: Get ()-                     -> ([ClosurePtr] -> [Word] -> Closure)+decodeStandardLayout :: Version+                     -> Get ()+                     -> (Maybe ProfHeaderWithPtr -> [ClosurePtr] -> [Word] -> Closure)                      -> (StgInfoTableWithPtr, RawInfoTable)                      -> (ClosurePtr, RawClosure)                      -> SizedClosure-decodeStandardLayout extra k (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+decodeStandardLayout ver extra k (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver   -- For the THUNK header   extra   pts <- replicateM (fromIntegral (ptrs (decodedTable infot))) getClosurePtr   cwords <- replicateM (fromIntegral (nptrs (decodedTable infot))) getWord-  return $ k pts (map fromIntegral cwords)+  return $ k prof pts (map fromIntegral cwords) -decodeArrWords :: (StgInfoTableWithPtr, b)-               -> (a, RawClosure) -> DebugClosureWithExtra Size src pap string s b1-decodeArrWords  (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+decodeArrWords :: Version -> (StgInfoTableWithPtr, b)+               -> (a, RawClosure) -> SizedClosure+decodeArrWords ver  (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver   bytes <- getWord64le   payload <- replicateM (fromIntegral $ bytes `ceilIntDiv` 8) getWord-  return $ GHC.Debug.Types.Closures.ArrWordsClosure infot (fromIntegral bytes) (map fromIntegral payload)+  return $ GHC.Debug.Types.Closures.ArrWordsClosure infot prof (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+tsoVersionChanged :: Version -> Bool+tsoVersionChanged (Version majv minv _ _) = (majv > 905) || (majv == 905 && minv >= 20220925) +whyBlockedWord32 :: Version -> Bool+whyBlockedWord32 (Version majv minv _ _) = majv > 909 || (majv == 909 && minv >= 20240201)+ decodeTSO :: Version           -> (StgInfoTableWithPtr, RawInfoTable)           -> (a, RawClosure)           -> SizedClosure decodeTSO ver (infot, _) (_, rc) = decodeFromBS rc $ do-  _itbl <- skipClosureHeader+  prof <- decodeClosureHeader ver   link <- getClosurePtr   global_link <- getClosurePtr   tsoStack <- getClosurePtr   what_next <- parseWhatNext <$> getWord16le-  why_blocked <- parseWhyBlocked <$> getWord16le-  flags <- parseTsoFlags <$> getWord32le+  (why_blocked, flags) <-+    if whyBlockedWord32 ver+      then do+        flags <- parseTsoFlags <$> getWord32le+        -- Padding+        skip 2+        why_blocked <- parseWhyBlocked <$> getWord32le+        -- Padding+        skip 4+        return (why_blocked, flags)+      else do+        why_blocked <- parseWhyBlocked . fromIntegral @Word16 @Word32 <$> getWord16le+        flags <- parseTsoFlags <$> getWord32le+        return (why_blocked, flags)   _block_info <- getClosurePtr   threadId <- getWord64le   saved_errno <- getWord32le@@ -256,7 +265,7 @@   _cap         <- getClosurePtr   trec           <- getClosurePtr   threadLabel <--    if ver >= tsoVersionChanged+    if tsoVersionChanged ver       then do         thread_label <- getClosurePtr         return $ if thread_label == mkClosurePtr 0 then Nothing else Just thread_label@@ -267,91 +276,258 @@   tot_stack_size <- getWord32le   let res :: Closure = (GHC.Debug.Types.Closures.TSOClosure             { info = infot+            , profHeader = prof             , _link = link             , prof = Nothing             , .. })   return res -+parseWhatNext :: Word16 -> WhatNext+parseWhatNext i = case i of+  1 -> ThreadRunGHC+  2 -> ThreadInterpret+  3 -> ThreadKilled+  4 -> ThreadComplete+  _ -> WhatNextUnknownValue i +parseWhyBlocked :: Word32 -> WhyBlocked+parseWhyBlocked i = case i of+  0  -> NotBlocked+  1  -> BlockedOnMVar+  14 -> BlockedOnMVarRead+  2  -> BlockedOnBlackHole+  3  -> BlockedOnRead+  4  -> BlockedOnWrite+  5  -> BlockedOnDelay+  6  -> BlockedOnSTM+  7  -> BlockedOnDoProc+  10 -> BlockedOnCCall+  11 -> BlockedOnCCall_Interruptible+  12 -> BlockedOnMsgThrowTo+  13 -> ThreadMigrating+  _  -> WhyBlockedUnknownValue i +parseTsoFlags :: Word32 -> [TsoFlags]+parseTsoFlags w =+  go [ (TsoLocked             , 1)+     , (TsoBlockx             , 2)+     , (TsoInterruptible      , 3)+     , (TsoStoppedOnBreakpoint, 4)+     , (TsoMarked             , 5)+     , (TsoSqueezed           , 6)+     , (TsoAllocLimit         , 7)+     ]+  where+    go xs = [flag | (flag, i) <- xs, testBit w i]  decodeClosure :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure decodeClosure ver i@(itb, _) c-  -- MP: It was far easier to implement the decoding of these closures in-  -- ghc-heap using binary rather than patching GHC and going through that-  -- dance. I think in the future it's better to do this for all the-  -- closures... it's simpler and probably much faster.---  | traceShow itb False = undefined-  | (StgInfoTable { tipe = ARR_WORDS }) <- decodedTable itb = decodeArrWords i c-  | (StgInfoTable { tipe = PAP }) <- decodedTable itb = decodePAPClosure i c-  | (StgInfoTable { tipe = AP }) <- decodedTable itb = decodeAPClosure i c-  | (StgInfoTable { tipe = TVAR }) <- decodedTable itb = decodeTVarClosure i c-  | (StgInfoTable { tipe = MUT_PRIM }) <- decodedTable itb = decodeMutPrim i c-  | (StgInfoTable { tipe = TREC_CHUNK }) <- decodedTable itb = decodeTrecChunk i c-  | (StgInfoTable { tipe = BLOCKING_QUEUE }) <- decodedTable itb = decodeBlockingQueue i c-  | (StgInfoTable { tipe = TSO }) <- decodedTable itb = decodeTSO ver i c-  | (StgInfoTable { tipe = STACK }) <- decodedTable itb = decodeStack i c-  | (StgInfoTable { tipe = AP_STACK }) <- decodedTable itb = decodeAPStack i c-  | (StgInfoTable { tipe = ty }) <- decodedTable itb-  , CONSTR <= ty && ty <= CONSTR_0_2 =-      decodeStandardLayout (return ()) (\pts ws -> ConstrClosure itb pts ws (tableId itb)) i c-  | (StgInfoTable { tipe = ty }) <- decodedTable itb-  , CONSTR <= ty && ty <= CONSTR_NOCAF =-      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 (tableId itb)) i c-  | (StgInfoTable { tipe = ty }) <- decodedTable itb-  , THUNK <= ty && ty <= THUNK_0_2 =-      decodeStandardLayout (() <$ getWord) (ThunkClosure itb (tableId itb)) i c-decodeClosure _ rit rc =-  decodeWithLibrary rit rc+  = case tipe (decodedTable itb) of+      ARR_WORDS -> decodeArrWords ver i c+      PAP -> decodePAPClosure ver i c+      AP -> decodeAPClosure ver i c+      TVAR -> decodeTVarClosure ver i c+      MUT_PRIM -> decodeMutPrim ver i c+      PRIM -> decodePrim ver i c+      TREC_CHUNK -> decodeTrecChunk ver i c+      BLOCKING_QUEUE -> decodeBlockingQueue ver i c+      TSO -> decodeTSO ver i c+      STACK -> decodeStack ver i c+      AP_STACK -> decodeAPStack ver i c+      THUNK_STATIC -> decodeStandardLayout ver (return ()) (\ph -> ThunkClosure itb ph (tableId itb)) i c+      THUNK_SELECTOR -> decodeThunkSelector ver i c+      BCO -> decodeBCO ver i c+      IND        -> decodeIndirectee ver IndClosure i c+      IND_STATIC -> decodeIndirectee ver IndClosure i c+      BLACKHOLE  -> decodeIndirectee ver BlackholeClosure i c+      MVAR_CLEAN -> decodeMVar ver i c+      MVAR_DIRTY -> decodeMVar ver i c+      MUT_VAR_CLEAN -> decodeMutVar ver i c+      MUT_VAR_DIRTY -> decodeMutVar ver i c+      WEAK -> decodeWeakClosure ver i c+      ty+        | CONSTR <= ty && ty <= CONSTR_0_2 ->+            decodeStandardLayout ver (return ()) (\ph pts ws -> ConstrClosure itb ph pts ws (tableId itb)) i c+        | CONSTR <= ty && ty <= CONSTR_NOCAF ->+            decodeStandardLayout ver (return ()) (\ph pts ws -> ConstrClosure itb ph pts ws (tableId itb)) i c+        | FUN <= ty && ty <= FUN_STATIC ->+            decodeStandardLayout ver (return ()) (\ph -> FunClosure itb ph (tableId itb)) i c+        | THUNK <= ty && ty <= THUNK_0_2 ->+            decodeStandardLayout ver (() <$ getWord) (\ph -> ThunkClosure itb ph (tableId itb)) i c+        | MUT_ARR_PTRS_CLEAN <= ty && ty <= MUT_ARR_PTRS_FROZEN_CLEAN ->+            decodeMutArr ver i c+        | SMALL_MUT_ARR_PTRS_CLEAN <= ty && ty <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN ->+            decodeSmallMutArr ver i c+        | otherwise -> error $ "unhandled closure type" ++ show ty +decodeCCS :: Version -> RawClosure -> CCSPayload+decodeCCS _ rc = decodeFromBS' rc getCCS -decodeWithLibrary :: (StgInfoTableWithPtr, RawInfoTable)-                      -> (a, RawClosure)-                      -> SizedClosure-decodeWithLibrary (itb, RawInfoTable rit) (_, (RawClosure clos)) = unsafePerformIO $ do-    allocate rit $ \itblPtr -> do-      allocate clos $ \closPtr -> do-        let ptr_to_itbl_ptr :: Ptr (Ptr StgInfoTable)-            ptr_to_itbl_ptr = castPtr closPtr-        -- The pointer is to the end of the info table (not the start)-        -- Info table is two words long which is why we subtract 16 from-        -- the pointer-        --print (itblPtr, closPtr)-        poke ptr_to_itbl_ptr (fixTNTC itblPtr)-        -- You should be able to print these addresses in gdb-        -- and observe the memory layout is identical to the debugee-        -- process-        -- Printing this return value can lead to segfaults because the-        -- pointer for constrDesc won't point to a string after being-        -- decoded.-        --print (tipe (decodedTable itb), ptr, closPtr, itblPtr)-        (!r, !s) <- getClosureRaw (decodedTable itb) closPtr clos-        -- Mutate back the ByteArray as if we attempt to use it again then-        -- the itbl pointer will point somewhere into our address space-        -- rather than the debuggee address space-        ---        return $ DCS s . quinmap id absurd-                        id-                        absurd-                        mkClosurePtr . convertClosure itb-          $ fmap (fromIntegral @Word @Word64) r+decodeIndexTable :: Version -> RawClosure -> IndexTable+decodeIndexTable _ rc = decodeFromBS' rc getIndexTable +decodeWeakClosure :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeWeakClosure ver (infot, _) (_, rc) = decodeFromBS rc $ do+  profHeader <- decodeClosureHeader ver+  cfinalizers <- getClosurePtr+  key <- getClosurePtr+  value <- getClosurePtr+  finalizer <- getClosurePtr+  mlink <- do+    p@(ClosurePtr w) <- getClosurePtr+    pure $ if w == 0 then Nothing else Just p+  pure $ WeakClosure infot profHeader cfinalizers key value finalizer mlink -fixTNTC :: Ptr a -> Ptr StgInfoTable-fixTNTC ptr-  | tablesNextToCode = castPtr $ ptr  `plusPtr` realItblSize-  | otherwise        = castPtr $ ptr+decodeMVar :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeMVar ver (infot, _) (_, rc) = decodeFromBS rc $ do+  profHeader <- decodeClosureHeader ver+  hd <- getClosurePtr+  tl <- getClosurePtr+  val <- getClosurePtr+  pure $ MVarClosure infot profHeader hd tl val -realItblSize :: Int-realItblSize-  | profiling  = ItblProf.itblSize-  | otherwise  = Itbl.itblSize+decodeMutVar :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeMutVar ver (infot, _) (_, rc) = decodeFromBS rc $ do+  profHeader <- decodeClosureHeader ver+  val <- getClosurePtr+  pure $ MutVarClosure infot profHeader val -decodeInfoTable :: RawInfoTable -> StgInfoTable-decodeInfoTable (RawInfoTable itbl) = unsafePerformIO $ do-  allocate itbl $ \itblPtr -> do-    peekItbl itblPtr+decodeMutArr :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeMutArr ver (infot, _) (_, rc) = decodeFromBS rc $ do+  profHeader <- decodeClosureHeader ver+  nptrs <- getWord64le+  size <- getWord64le+  payload <- replicateM (fromIntegral nptrs) getClosurePtr+  pure $ MutArrClosure infot profHeader (fromIntegral nptrs) (fromIntegral size) payload++decodeSmallMutArr :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeSmallMutArr ver (infot, _) (_, rc) = decodeFromBS rc $ do+  profHeader <- decodeClosureHeader ver+  nptrs <- getWord64le+  payload <- replicateM (fromIntegral nptrs) getClosurePtr+  pure $ SmallMutArrClosure infot profHeader (fromIntegral nptrs) payload++decodeIndirectee :: Version+                 -> (StgInfoTableWithPtr -> Maybe ProfHeaderWithPtr -> ClosurePtr -> Closure)+                 -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeIndirectee ver mk (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver+  ind <- getClosurePtr+  pure $ mk infot prof ind++decodeBCO :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeBCO ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver+  instrs <- getClosurePtr+  literals <- getClosurePtr+  bcoptrs <- getClosurePtr+  arity <- getWord32le+  size <- getWord32le+  bitmap <- replicateM (fromIntegral size) (fromIntegral <$> getWord64le) -- TODO getWord?+  pure (BCOClosure infot prof instrs literals bcoptrs arity size bitmap)+++decodeThunkSelector :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) ->  SizedClosure+decodeThunkSelector ver (infot, _) (_, rc) = decodeFromBS rc $ do+  prof <- decodeClosureHeader ver+  (() <$ getWord)+  selectee <- getClosurePtr+  pure (SelectorClosure infot prof selectee)++decodeInfoTable :: Version -> RawInfoTable -> StgInfoTable+decodeInfoTable ver@Version{..} (RawInfoTable itbl) =+  case runGetOrFail itParser (BSL.fromStrict itbl) of+    Left err -> error ("DEC:" ++ show err ++ printBS itbl)+    Right (_rem, !_, v) -> v+  where+    itParser = do+      _entry <- case v_tntc of+        True -> pure Nothing+        False -> do+          getWord64le -- todo return funptr+          pure Nothing+      when (isProfiledRTS ver) $ do+        () <$ getWord64le+        () <$ getWord64le+      ptrs <- getWord32le+      nptrs <- getWord32le+      tipe <- getWord32le+      srtlen <- getWord32le+      return $+        StgInfoTable+        { ptrs = ptrs+        , nptrs = nptrs+        , tipe = decodeInfoTableType tipe+        , srtlen = srtlen+        }++decodeInfoTableType :: Word32 -> ClosureType+decodeInfoTableType i = case i of+  0 -> INVALID_OBJECT+  1 -> CONSTR+  2 -> CONSTR_1_0+  3 -> CONSTR_0_1+  4 -> CONSTR_2_0+  5 -> CONSTR_1_1+  6 -> CONSTR_0_2+  7 -> CONSTR_NOCAF+  8 -> FUN+  9 -> FUN_1_0+  10 -> FUN_0_1+  11 -> FUN_2_0+  12 -> FUN_1_1+  13 -> FUN_0_2+  14 -> FUN_STATIC+  15 -> THUNK+  16 -> THUNK_1_0+  17 -> THUNK_0_1+  18 -> THUNK_2_0+  19 -> THUNK_1_1+  20 -> THUNK_0_2+  21 -> THUNK_STATIC+  22 -> THUNK_SELECTOR+  23 -> BCO+  24 -> AP+  25 -> PAP+  26 -> AP_STACK+  27 -> IND+  28 -> IND_STATIC+  29 -> RET_BCO+  30 -> RET_SMALL+  31 -> RET_BIG+  32 -> RET_FUN+  33 -> UPDATE_FRAME+  34 -> CATCH_FRAME+  35 -> UNDERFLOW_FRAME+  36 -> STOP_FRAME+  37 -> BLOCKING_QUEUE+  38 -> BLACKHOLE+  39 -> MVAR_CLEAN+  40 -> MVAR_DIRTY+  41 -> TVAR+  42 -> ARR_WORDS+  43 -> MUT_ARR_PTRS_CLEAN+  44 -> MUT_ARR_PTRS_DIRTY+  45 -> MUT_ARR_PTRS_FROZEN_DIRTY+  46 -> MUT_ARR_PTRS_FROZEN_CLEAN+  47 -> MUT_VAR_CLEAN+  48 -> MUT_VAR_DIRTY+  49 -> WEAK+  50 -> PRIM+  51 -> MUT_PRIM+  52 -> TSO+  53 -> STACK+  54 -> TREC_CHUNK+  55 -> ATOMICALLY_FRAME+  56 -> CATCH_RETRY_FRAME+  57 -> CATCH_STM_FRAME+  58 -> WHITEHOLE+  59 -> SMALL_MUT_ARR_PTRS_CLEAN+  60 -> SMALL_MUT_ARR_PTRS_DIRTY+  61 -> SMALL_MUT_ARR_PTRS_FROZEN_DIRTY+  62 -> SMALL_MUT_ARR_PTRS_FROZEN_CLEAN+  63 -> COMPACT_NFDATA+  64 -> CONTINUATION+  65 -> N_CLOSURE_TYPES+  n  -> error $ "Unexpected closure type: " ++ show n+

@@ -1,43 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NamedFieldPuns #-}--{- Convert a GenClosure to a DebugClosure -}-module GHC.Debug.Decode.Convert where--import qualified GHC.Exts.Heap as GHC--import GHC.Debug.Types.Closures-import GHC.Debug.Types.Ptr-import Data.Void---- | 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-    -- 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.BCOClosure _ a2 a3 a4 a5 a6 a7 -> BCOClosure itb a2 a3 a4 a5 a6 a7-    GHC.BlackholeClosure _ a2          -> BlackholeClosure itb a2-    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.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 MIN_VERSION_GLASGOW_HASKELL(9,4,2,0)-      let w_link = a6-#else-      -- nullPtr check-      let w_link = if a6 == 0-                  then Nothing-                  else Just a6-#endif-      in WeakClosure itb a2 a3 a4 a5 w_link-    GHC.UnsupportedClosure _           -> UnsupportedClosure itb-    c -> error ("Unexpected closure type: " ++ show c)

@@ -9,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RecordWildCards #-}  module GHC.Debug.Types(module T                       , Request(..)@@ -31,7 +32,18 @@                       , getInfoTable                       , putInfoTable                       , putRequest-                      , getRequest ) where+                      , getCCS+                      , getCC+                      , putCCS+                      , putCC+                      , putIndexTable+                      , getIndexTable+                      , putCCSMainPtr+                      , getCCSMainPtr+                      , getProfilingMode+                      , putProfilingMode+                      , getRequest+                      ) where  import Control.Applicative import Control.Exception@@ -52,7 +64,6 @@ import GHC.Debug.Types.Ptr as T import GHC.Debug.Types.Version import GHC.Debug.Utils-import GHC.Debug.Decode import Control.Concurrent  -- | The decision about whether to fork the running process or@@ -84,7 +95,7 @@     -- | Request a closure     RequestClosure :: ClosurePtr -> Request RawClosure     -- | Request an info table-    RequestInfoTable :: InfoTablePtr -> Request (StgInfoTableWithPtr, RawInfoTable)+    RequestInfoTable :: InfoTablePtr -> Request RawInfoTable      -- | Request the SRT of an info table. Some closures, like constructors, can never have SRTs.     -- Thunks, functions and stack frames may have SRTs.@@ -114,6 +125,16 @@     -- | Request the block which contains a specific pointer     RequestBlock :: ClosurePtr -> Request RawBlock +    -- | Request the cost center stack+    RequestCCS :: CCSPtr -> Request CCSPayload+    -- | Request the cost center entry+    RequestCC :: CCPtr -> Request CCPayload+    -- | Request the index table.+    RequestIndexTable :: IndexTablePtr -> Request IndexTable+    -- | Request the CCS_MAIN pointer+    RequestCCSMainPtr :: Request CCSPtr++ data SourceInformation = SourceInformation { infoName        :: !String                                          , infoClosureType :: !ClosureType                                          , infoType        :: !String@@ -140,6 +161,10 @@     RequestSourceInfo itp  -> case r2 of { (RequestSourceInfo itp') -> itp == itp'; _ -> False }     RequestAllBlocks       -> case r2 of { RequestAllBlocks -> True; _ -> False }     RequestBlock cp        -> case r2 of { RequestBlock cp' -> cp == cp'; _ -> False }+    RequestCCS cp       -> case r2 of { RequestCCS cp' -> cp == cp'; _ -> False }+    RequestCC cp       -> case r2 of { RequestCC cp' -> cp == cp'; _ -> False }+    RequestIndexTable cp -> case r2 of { RequestIndexTable cp' -> cp == cp'; _ -> False }+    RequestCCSMainPtr -> case r2 of { RequestCCSMainPtr -> True; _ -> False }  -- | Whether a request mutates the debuggee state, don't cache these ones isWriteRequest :: Request a -> Bool@@ -165,6 +190,8 @@     RequestSRT {} -> True     RequestSourceInfo {} -> True     RequestConstrDesc {} -> True+    RequestCCS {} -> True+    RequestCC {} -> True     _ -> False  @@ -188,6 +215,10 @@     RequestSourceInfo itp  -> s `hashWithSalt` cmdRequestSourceInfo `hashWithSalt` itp     RequestAllBlocks       -> s `hashWithSalt` cmdRequestAllBlocks     RequestBlock cp        -> s `hashWithSalt` cmdRequestBlock `hashWithSalt` cp+    RequestCCS cp          -> s `hashWithSalt` cmdRequestCCS `hashWithSalt` cp+    RequestCC cp           -> s `hashWithSalt` cmdRequestCC  `hashWithSalt` cp+    RequestIndexTable cp   -> s `hashWithSalt` cmdRequestIndexTable  `hashWithSalt` cp+    RequestCCSMainPtr      -> s `hashWithSalt` cmdRequestCCSMainPtr   newtype CommandId = CommandId Word32@@ -211,6 +242,10 @@     RequestSourceInfo {}   -> cmdRequestSourceInfo     RequestAllBlocks {} -> cmdRequestAllBlocks     RequestBlock {} -> cmdRequestBlock+    RequestCCS{} -> cmdRequestCCS+    RequestCC{} -> cmdRequestCC+    RequestIndexTable{} -> cmdRequestIndexTable+    RequestCCSMainPtr{} -> cmdRequestCCSMainPtr  cmdRequestVersion :: CommandId cmdRequestVersion = CommandId 1@@ -257,6 +292,18 @@ cmdRequestSRT :: CommandId cmdRequestSRT  = CommandId 17 +cmdRequestCCS :: CommandId+cmdRequestCCS  = CommandId 18++cmdRequestCC :: CommandId+cmdRequestCC  = CommandId 19++cmdRequestIndexTable :: CommandId+cmdRequestIndexTable  = CommandId 20++cmdRequestCCSMainPtr :: CommandId+cmdRequestCCSMainPtr  = CommandId 21+ data AnyReq = forall req . AnyReq !(Request req)  instance Hashable AnyReq where@@ -305,6 +352,10 @@ putRequest (RequestSourceInfo it) = putCommand cmdRequestSourceInfo $ put it putRequest (RequestAllBlocks) = putCommand cmdRequestAllBlocks $ return () putRequest (RequestBlock cp)  = putCommand cmdRequestBlock $ put cp+putRequest (RequestCCS cp)  = putCommand cmdRequestCCS $ put cp+putRequest (RequestCC cp)  = putCommand cmdRequestCC $ put cp+putRequest (RequestIndexTable cp)  = putCommand cmdRequestIndexTable $ put cp+putRequest RequestCCSMainPtr  = putCommand cmdRequestCCSMainPtr mempty  -- This is used to serialise the RequestCache getRequest :: Get AnyReq@@ -353,16 +404,26 @@       | cmd == cmdRequestBlock -> do             cp <- get             return (AnyReq (RequestBlock cp))+      | cmd == cmdRequestCCS -> do+            cp <- get+            return (AnyReq (RequestCCS cp))+      | cmd == cmdRequestCC -> do+            cp <- get+            return (AnyReq (RequestCC cp))+      | cmd == cmdRequestIndexTable -> do+            cp <- get+            return (AnyReq (RequestIndexTable cp))+      | cmd == cmdRequestCCSMainPtr -> return (AnyReq RequestCCSMainPtr)       | otherwise -> error (show cmd)   getResponse :: Request a -> Get a-getResponse RequestVersion       = Version <$> get <*> get+getResponse RequestVersion       = Version <$> get <*> get <*> getProfilingMode <*> get getResponse RequestPause {}      = get getResponse RequestResume        = get getResponse RequestRoots         = many get getResponse (RequestClosure {}) = get-getResponse (RequestInfoTable itbp) = (\(it, r) -> (StgInfoTableWithPtr itbp it, r)) <$> getInfoTable+getResponse (RequestInfoTable {}) = getInfoTable getResponse (RequestSRT {}) = do   cptr <- get   pure $ guard (cptr /= UntaggedClosurePtr 0) $> cptr@@ -377,8 +438,142 @@ getResponse (RequestSourceInfo _c) = getIPE getResponse RequestAllBlocks = many get getResponse RequestBlock {}  = get+getResponse (RequestCCS {}) = getCCS +getResponse (RequestCC {}) = getCC+getResponse (RequestIndexTable {}) = getIndexTable+getResponse (RequestCCSMainPtr {}) = getCCSMainPtr +getProfilingMode :: Get (Maybe ProfilingMode)+getProfilingMode = do+  w <- getWord8+  case w of+    0 -> pure $ Nothing+    1 -> pure $ Just NoProfiling+    2 -> pure $ Just RetainerProfiling+    3 -> pure $ Just LDVProfiling+    4 -> pure $ Just EraProfiling+    5 -> pure $ Just OtherProfiling+    _ -> error $ "Unknown profiling mode: " ++ (show w)++putProfilingMode :: Maybe ProfilingMode -> Put+putProfilingMode Nothing = putWord8 0+putProfilingMode (Just mode) =+  case mode of+    NoProfiling -> putWord8 1+    RetainerProfiling -> putWord8 2+    LDVProfiling -> putWord8 3+    EraProfiling -> putWord8 4+    OtherProfiling -> putWord8 5++getCCS :: Get CCSPayload+getCCS = do+  ccsID <- getInt64le+  ccsCc <- get+  ccsPrevStack <- do+    p <- get+    pure $ guard (p /= CCSPtr 0) $>  p+  ccsIndexTable <- do+    p <- get+    pure $ guard (p /= IndexTablePtr 0) $>  p+  ccsRoot <- do+    p <- get+    pure $ guard (p /= CCSPtr 0) $>  p+  ccsDepth <- fromIntegral <$> getWord64le+  ccsSccCount <- getWord64le+  ccsSelected <- fromIntegral <$> getWord64le+  ccsTimeTicks <- fromIntegral <$> getWord64le+  ccsMemAlloc <- getWord64le+  ccsInheritedAlloc <- getWord64le+  ccsInheritedTicks <- fromIntegral <$> getWord64le+  pure CCSPayload{..}+++putCCS :: CCSPayload -> Put+putCCS CCSPayload{..} = do+  putInt64le ccsID+  put ccsCc+  case ccsPrevStack of+    Nothing -> put (CCSPtr 0)+    Just x -> put x+  case ccsIndexTable of+    Nothing -> put (IndexTablePtr 0)+    Just x -> put x+  case ccsRoot of+    Nothing -> put (CCSPtr 0)+    Just x -> put x+  putWord64le $ fromIntegral ccsDepth+  putWord64le ccsSccCount+  putWord64le $ fromIntegral ccsSelected+  putWord64le $ fromIntegral ccsTimeTicks+  putWord64le ccsMemAlloc+  putWord64le ccsInheritedAlloc+  putWord64le $ fromIntegral ccsInheritedTicks++getCC :: Get CCPayload+getCC = do+  ccID <- getInt64le+  ccLabel <- getString+  ccMod <- getString+  ccLoc <- getString+  ccMemAlloc <- get+  ccTimeTicks <- get+  ccIsCaf <- (\i -> if i == 0 then False else True ) <$> getWord64be+  ccLink <- do+    p <- get+    pure $ guard (p /= CCPtr 0) $>  p+  pure CCPayload{..}+  where+    getString = do+      len <- getInt32be+      C8.unpack <$> getByteString (fromIntegral len)++putCC :: CCPayload -> Put+putCC CCPayload{..} = do+  putInt64le ccID+  putString ccLabel+  putString ccMod+  putString ccLoc+  put ccMemAlloc+  put ccTimeTicks+  if ccIsCaf+    then putWord64le 0+    else putWord64le 1+  case ccLink of+    Nothing -> put (CCPtr 0)+    Just x -> put x+  where+    putString xs = do+      putInt32be (fromIntegral $ length xs)+      putByteString (C8.pack xs)++getIndexTable :: Get IndexTable+getIndexTable = do+  itCostCentre <- get+  itCostCentreStack <- get+  itNext <- do+    p <- get+    pure $ guard (p /= IndexTablePtr 0) $> p+  itBackEdge <- (\i -> if i == 0 then False else True) <$> getWord8+  pure IndexTable{..}++putIndexTable :: IndexTable -> Put+putIndexTable IndexTable {..} = do+  put itCostCentre+  put itCostCentreStack+  case itNext of+    Nothing -> put (IndexTablePtr 0)+    Just x -> put x+  if itBackEdge+    then putWord8 0+    else putWord8 1++getCCSMainPtr :: Get CCSPtr+getCCSMainPtr = get++putCCSMainPtr :: CCSPtr -> Put+putCCSMainPtr = put+ getConstrDesc :: Get ConstrDesc getConstrDesc = do   len <- getInt32be@@ -421,12 +616,11 @@   -getInfoTable :: Get (StgInfoTable, RawInfoTable)+getInfoTable :: Get RawInfoTable getInfoTable = do   !len <- getInt32be   !r <- RawInfoTable <$> getByteString (fromIntegral len)-  let !it = decodeInfoTable r-  return (it, r)+  return r  putInfoTable :: RawInfoTable -> Put putInfoTable (RawInfoTable rc) = do

@@ -36,7 +36,10 @@     , allClosures     -- * Info Table Representation     , StgInfoTable(..)-    , GHC.ClosureType(..)+    , ClosureType(..)+    , WhatNext(..)+    , WhyBlocked(..)+    , TsoFlags(..)     , StgInfoTableWithPtr(..)     -- * Stack Frame Representation     , DebugStackFrame(..)@@ -56,20 +59,21 @@     , GenSrtPayload(..)     , SrtPayload     , SrtCont+    , ProfHeader(..)+    , ProfHeaderWord(..)+    , ProfHeaderWithPtr+    , CCSPayload+    , GenCCSPayload(..)+    , CCPayload(..)+    , IndexTable(..)      -- * Traversing functions-    , Quintraversable(..)-    , quinmap+    , Hextraversable(..)+    , hexmap     ) where  import Prelude -- See note [Why do we import Prelude here?]--- TODO: Support profiling---import qualified GHC.Exts.Heap.InfoTableProf as ItblProf-import GHC.Exts.Heap.InfoTable-import qualified GHC.Exts.Heap as GHC-import GHC.Exts.Heap.ProfInfo.Types as ProfTypes - import Data.Functor.Identity import Data.Int import Data.Word@@ -85,15 +89,136 @@ import Data.Bifunctor import Data.Bifoldable +------------------------------------------------------------------------+-- GHC Heap ++data ClosureType+    = INVALID_OBJECT+    | CONSTR+    | CONSTR_1_0+    | CONSTR_0_1+    | CONSTR_2_0+    | CONSTR_1_1+    | CONSTR_0_2+    | CONSTR_NOCAF+    | FUN+    | FUN_1_0+    | FUN_0_1+    | FUN_2_0+    | FUN_1_1+    | FUN_0_2+    | FUN_STATIC+    | THUNK+    | THUNK_1_0+    | THUNK_0_1+    | THUNK_2_0+    | THUNK_1_1+    | THUNK_0_2+    | THUNK_STATIC+    | THUNK_SELECTOR+    | BCO+    | AP+    | PAP+    | AP_STACK+    | IND+    | IND_STATIC+    | RET_BCO+    | RET_SMALL+    | RET_BIG+    | RET_FUN+    | UPDATE_FRAME+    | CATCH_FRAME+    | UNDERFLOW_FRAME+    | STOP_FRAME+    | BLOCKING_QUEUE+    | BLACKHOLE+    | MVAR_CLEAN+    | MVAR_DIRTY+    | TVAR+    | ARR_WORDS+    | MUT_ARR_PTRS_CLEAN+    | MUT_ARR_PTRS_DIRTY+    | MUT_ARR_PTRS_FROZEN_DIRTY+    | MUT_ARR_PTRS_FROZEN_CLEAN+    | MUT_VAR_CLEAN+    | MUT_VAR_DIRTY+    | WEAK+    | PRIM+    | MUT_PRIM+    | TSO+    | STACK+    | TREC_CHUNK+    | ATOMICALLY_FRAME+    | CATCH_RETRY_FRAME+    | CATCH_STM_FRAME+    | WHITEHOLE+    | SMALL_MUT_ARR_PTRS_CLEAN+    | SMALL_MUT_ARR_PTRS_DIRTY+    | SMALL_MUT_ARR_PTRS_FROZEN_DIRTY+    | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN+    | COMPACT_NFDATA+    | CONTINUATION+    | N_CLOSURE_TYPES+ deriving (Enum, Eq, Ord, Show, Generic, Read)++type HalfWord = Word32 -- TODO support 32 bit++data StgInfoTable = StgInfoTable {+   ptrs   :: HalfWord,+   nptrs  :: HalfWord,+   tipe   :: ClosureType,+   srtlen :: HalfWord+  } deriving (Eq, Show, Generic)++data WhatNext+  = ThreadRunGHC+  | ThreadInterpret+  | ThreadKilled+  | ThreadComplete+  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug+  deriving (Eq, Show, Generic, Ord)++data WhyBlocked+  = NotBlocked+  | BlockedOnMVar+  | BlockedOnMVarRead+  | BlockedOnBlackHole+  | BlockedOnRead+  | BlockedOnWrite+  | BlockedOnDelay+  | BlockedOnSTM+  | BlockedOnDoProc+  | BlockedOnCCall+  | BlockedOnCCall_Interruptible+  | BlockedOnMsgThrowTo+  | ThreadMigrating+  | WhyBlockedUnknownValue Word32 -- ^ Please report this as a bug+  deriving (Eq, Show, Generic, Ord)++data TsoFlags+  = TsoLocked+  | TsoBlockx+  | TsoInterruptible+  | TsoStoppedOnBreakpoint+  | TsoMarked+  | TsoSqueezed+  | TsoAllocLimit+  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug+  deriving (Eq, Show, Generic, Ord)++newtype StgTSOProfInfo = StgTSOProfInfo {+    cccs :: Maybe CCSPtr+} deriving (Show, Generic, Eq, Ord)+ ------------------------------------------------------------------------ -- Closures  -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+type Closure = DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr+type SizedClosure = DebugClosureWithSize CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr+type SizedClosureC = DebugClosureWithSize CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr+type SizedClosureP = DebugClosureWithSize CCSPtr SrtPayload PapPayload ConstrDesc StackCont ClosurePtr  -- | Information needed to decode a 'ConstrDesc' type ConstrDescCont = InfoTablePtr@@ -103,15 +228,16 @@  type DebugClosureWithSize = DebugClosureWithExtra Size -data DebugClosureWithExtra x srt pap string s b = DCS { extraDCS :: x-                                              , unDCS :: DebugClosure srt pap string s b }+data DebugClosureWithExtra x ccs srt pap string s b+  = DCS { extraDCS :: x+        , unDCS :: DebugClosure ccs srt pap string s b }     deriving (Show, Ord, Eq)  -- | Exclusive size newtype Size = Size { getSize :: Int }   deriving stock (Show, Generic)   deriving (Semigroup, Monoid) via (Sum Int)-  deriving newtype (Num, Ord, Eq)+  deriving newtype (Num, Ord, Eq, Read)  newtype InclusiveSize = InclusiveSize { getInclusiveSize :: Int }   deriving stock (Show, Generic)@@ -122,15 +248,17 @@   deriving (Semigroup, Monoid) via (Sum Int)  -noSize :: DebugClosureWithSize srt pap string s b -> DebugClosure srt pap string s b+noSize :: DebugClosureWithSize ccs srt pap string s b -> DebugClosure ccs srt pap string s b noSize = unDCS -dcSize :: DebugClosureWithSize srt pap string s b -> Size+dcSize :: DebugClosureWithSize ccs srt pap string s b -> Size dcSize = extraDCS -instance Quintraversable (DebugClosureWithExtra x) where-  quintraverse f g h i j (DCS x v) = DCS x <$> quintraverse f g h i j v+instance Hextraversable (DebugClosureWithExtra x) where+  hextraverse f g h i j k (DCS x v) = DCS x <$> hextraverse f g h i j k v ++ data StgInfoTableWithPtr = StgInfoTableWithPtr {                               tableId :: InfoTablePtr                             , decodedTable :: StgInfoTable@@ -142,7 +270,18 @@ instance Eq StgInfoTableWithPtr where   t1 == t2 = tableId t1 == tableId t2 +data ProfHeader a = ProfHeader { ccs :: a, hp :: ProfHeaderWord }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable) +data ProfHeaderWord+  = RetainerHeader { trav :: !Bool, retainerSet :: !RetainerSetPtr }+  | LDVWord { state :: !Bool, creationTime :: !Word32, lastUseTime :: !Word32 }+  | EraWord Word64+  | OtherHeader Word64+  deriving (Eq, Ord, Show)++type ProfHeaderWithPtr = ProfHeader CCSPtr+ -- | This is the representation of a Haskell value on the heap. It reflects -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h> --@@ -157,10 +296,11 @@ -- See -- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects> -- for more information.-data DebugClosure srt pap string s b+data DebugClosure ccs srt pap string s b   = -- | A data constructor     ConstrClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , ptrArgs    :: ![b]            -- ^ Pointer arguments         , dataArgs   :: ![Word]         -- ^ Non-pointer arguments         , constrDesc :: !string@@ -169,6 +309,7 @@     -- | A function   | FunClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , srt        :: !(srt)         , ptrArgs    :: ![b]            -- ^ Pointer arguments         , dataArgs   :: ![Word]         -- ^ Non-pointer arguments@@ -177,6 +318,7 @@     -- | A thunk, an expression not obviously in head normal form   | ThunkClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , srt        :: !(srt)         , ptrArgs    :: ![b]            -- ^ Pointer arguments         , dataArgs   :: ![Word]         -- ^ Non-pointer arguments@@ -185,6 +327,7 @@     -- | A thunk which performs a simple selection operation   | SelectorClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , selectee   :: !b              -- ^ Pointer to the object being                                         --   selected from         }@@ -192,6 +335,7 @@     -- | An unsaturated function application   | PAPClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , arity      :: !HalfWord       -- ^ Arity of the partial application         , n_args     :: !HalfWord       -- ^ Size of the payload in words         , fun        :: !b              -- ^ Pointer to a 'FunClosure'@@ -206,6 +350,7 @@     -- | A function application   | APClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , arity      :: !HalfWord       -- ^ Always 0         , n_args     :: !HalfWord       -- ^ Size of payload in words         , fun        :: !b              -- ^ Pointer to a 'FunClosure'@@ -216,6 +361,7 @@     -- | A suspended thunk evaluation   | APStackClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , ap_st_size :: !Word         , fun        :: !b              -- ^ Function closure         , payload    :: !s            -- ^ Stack right before suspension@@ -225,6 +371,7 @@     -- to point at its value   | IndClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , indirectee :: !b              -- ^ Target closure         } @@ -232,6 +379,7 @@    -- interpreter (e.g. as used by GHCi)   | BCOClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , instrs     :: !b              -- ^ A pointer to an ArrWords                                         --   of instructions         , literals   :: !b              -- ^ A pointer to an ArrWords@@ -247,12 +395,14 @@     -- | A thunk under evaluation by another thread   | BlackholeClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , indirectee :: !b              -- ^ The target closure         }      -- | A @ByteArray#@   | ArrWordsClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , bytes      :: !Word           -- ^ Size of array in bytes         , arrWords   :: ![Word]         -- ^ Array payload         }@@ -260,6 +410,7 @@     -- | A @MutableByteArray#@   | MutArrClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , mccPtrs    :: !Word           -- ^ Number of pointers         , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h         , mccPayload :: ![b]            -- ^ Array payload@@ -271,6 +422,7 @@     -- @since 8.10.1   | SmallMutArrClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , mccPtrs    :: !Word           -- ^ Number of pointers         , mccPayload :: ![b]            -- ^ Array payload         }@@ -278,6 +430,7 @@     -- | An @MVar#@, with a queue of thread state objects blocking on them   | MVarClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , queueHead  :: !b              -- ^ Pointer to head of queue         , queueTail  :: !b              -- ^ Pointer to tail of queue         , value      :: !b              -- ^ Pointer to closure@@ -286,12 +439,14 @@     -- | A @MutVar#@   | MutVarClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , var        :: !b              -- ^ Pointer to contents         }      -- | An STM blocking queue.   | BlockingQueueClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , link       :: !b              -- ^ ?? Here so it looks like an IND         , blackHole  :: !b              -- ^ The blackhole closure         , owner      :: !b              -- ^ The owning thread state object@@ -300,6 +455,7 @@    | TSOClosure       { info :: !StgInfoTableWithPtr+      , profHeader :: Maybe (ProfHeader ccs)       -- pointers       , _link :: !b       , global_link :: !b@@ -309,19 +465,20 @@       , bq :: !b       , threadLabel :: !(Maybe b)       -- values-      , what_next :: GHC.WhatNext-      , why_blocked :: GHC.WhyBlocked-      , flags :: [GHC.TsoFlags]+      , what_next :: WhatNext+      , why_blocked :: WhyBlocked+      , flags :: [TsoFlags]       , threadId :: Word64       , saved_errno :: Word32       , dirty :: Word32       , alloc_limit :: Int64       , tot_stack_size :: Word32-      , prof :: Maybe ProfTypes.StgTSOProfInfo+      , prof :: Maybe StgTSOProfInfo       }   | StackClosure      { info :: !StgInfoTableWithPtr+     , profHeader :: Maybe (ProfHeader ccs)      , stack_size :: !Word32 -- ^ stack size in *words*      , stack_dirty :: !Word8 -- ^ non-zero => dirty      , stack_marking :: !Word8@@ -331,6 +488,7 @@    | WeakClosure      { info        :: !StgInfoTableWithPtr+     , profHeader :: Maybe (ProfHeader ccs)      , cfinalizers :: !b      , key         :: !b      , value       :: !b@@ -340,12 +498,14 @@    | TVarClosure     { info :: !StgInfoTableWithPtr+    , profHeader :: Maybe (ProfHeader ccs)     , current_value :: !b     , tvar_watch_queue :: !b     , num_updates :: !Int }    | TRecChunkClosure     { info :: !StgInfoTableWithPtr+    , profHeader :: Maybe (ProfHeader ccs)     , prev_chunk  :: !b     , next_idx :: !Word     , entries :: ![TRecEntry b]@@ -353,22 +513,32 @@    | MutPrimClosure     { info :: !StgInfoTableWithPtr+    , profHeader :: Maybe (ProfHeader ccs)     , ptrArgs :: ![b]     , dataArgs :: ![Word]     } +  | PrimClosure+    { info :: !StgInfoTableWithPtr+    , profHeader :: Maybe (ProfHeader ccs)+    , ptrArgs :: ![b]+    , dataArgs :: ![Word]+    }+     -----------------------------------------------------------     -- Anything else      -- | Another kind of closure   | OtherClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         , hvalues    :: ![b]         , rawWords   :: ![Word]         }    | UnsupportedClosure         { info       :: !StgInfoTableWithPtr+        , profHeader :: Maybe (ProfHeader ccs)         }   deriving (Show, Generic, Functor, Foldable, Traversable, Ord, Eq) @@ -392,6 +562,57 @@  type SrtCont = InfoTablePtr +data GenCCSPayload ccsPtr ccPtr+  = CCSPayload+  { ccsID :: !Int64+  , ccsCc :: ccPtr+  , ccsPrevStack :: Maybe ccsPtr+  , ccsIndexTable :: Maybe IndexTablePtr+  , ccsRoot :: Maybe CCSPtr -- todo ccsPtr?+  , ccsDepth :: Word+  , ccsSccCount :: Word64+  , ccsSelected :: Word+  , ccsTimeTicks :: Word+  , ccsMemAlloc :: Word64+  , ccsInheritedAlloc :: Word64+  , ccsInheritedTicks :: Word+  } deriving (Show, Ord, Eq, Functor)++instance Bifunctor GenCCSPayload where+  bimap f g CCSPayload{..} = (\a b -> CCSPayload{ccsPrevStack = a, ccsCc = b, ..})+                              (fmap f ccsPrevStack)+                              (g ccsCc)++instance Bifoldable GenCCSPayload where+  bifoldMap f g CCSPayload{..} = foldMap f ccsPrevStack <> g ccsCc++instance Bitraversable GenCCSPayload where+  bitraverse f g CCSPayload{..} = (\a b -> CCSPayload{ccsPrevStack = a, ccsCc = b, ..})+                              <$> traverse f ccsPrevStack+                              <*> g ccsCc++type CCSPayload = GenCCSPayload CCSPtr CCPtr++data CCPayload+  = CCPayload+  { ccID :: !Int64+  , ccLabel :: String+  , ccMod :: String+  , ccLoc :: String+  , ccMemAlloc :: Word64+  , ccTimeTicks :: Word+  , ccIsCaf :: Bool+  , ccLink :: Maybe CCPtr -- todo ccPtr?+  } deriving (Show, Ord, Eq)++-- data IndexTable ccsPtr ccPtr = IndexTable+data IndexTable = IndexTable+  { itCostCentre :: CCPtr+  , itCostCentreStack :: CCSPtr+  , itNext :: Maybe IndexTablePtr+  , itBackEdge :: Bool+  } deriving (Show, Ord, Eq)+ -- | Information needed to decode a set of stack frames data StackCont = StackCont StackPtr -- Address of start of frames                            RawStack -- The raw frames@@ -467,62 +688,65 @@                 (top, _:bot) -> parseModOcc (top : acc) bot     parseModOcc acc str = (acc, str) -class Quintraversable m where-  quintraverse ::+class Hextraversable m where+  hextraverse ::     Applicative f => (a -> f b)                   -> (c -> f d)                   -> (e -> f g)                   -> (h -> f i)                   -> (j -> f k)-                  -> m a c e h j-                  -> f (m b d g i k)+                  -> (l -> f n)+                  ->    m a c e h j l+                  -> f (m b d g i k n) -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)+hexmap :: forall a b c d e f g h i j k l t . Hextraversable t => (a -> b) -> (c -> d) -> (e -> f) -> (g -> h) -> (i -> j) -> (k -> l) -> t a c e g i k -> t b d f h j l+hexmap = coerce+  (hextraverse :: (a -> Identity b)               -> (c -> Identity d)               -> (e -> Identity f)               -> (g -> Identity h)               -> (i -> Identity j)-              -> t a c e g i -> Identity (t b d f h j))+              -> (k -> Identity l)+              -> t a c e g i k -> Identity (t b d f h j l)) -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+allClosures :: DebugClosure ccs (GenSrtPayload c) (GenPapPayload c) a (GenStackFrames (GenSrtPayload c) c) c -> [c]+allClosures c = getConst $ hextraverse (const (Const [])) (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 Quintraversable DebugClosure where-  quintraverse srt p h f g c =+instance Hextraversable DebugClosure where+  hextraverse fccs 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 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-      APStackClosure a1 s b bs   -> APStackClosure a1 s <$> g b <*> f bs-      IndClosure a1 b -> IndClosure a1 <$> g b-      BCOClosure a1 b1 b2 b3 a2 a3 a4 ->-        (\c1 c2 c3 -> BCOClosure a1 c1 c2 c3 a2 a3 a4) <$> g b1 <*> g b2 <*> g b3-      BlackholeClosure a1 b -> BlackholeClosure a1 <$> g b-      ArrWordsClosure a1 a2 a3 -> pure (ArrWordsClosure a1 a2 a3)-      MutArrClosure a1 a2 a3 bs -> MutArrClosure a1 a2 a3 <$> traverse g bs-      SmallMutArrClosure a1 a2 bs -> SmallMutArrClosure a1 a2 <$> traverse g bs-      MVarClosure a1 b1 b2 b3     -> MVarClosure a1 <$> g b1 <*> g b2 <*> g b3-      MutVarClosure a1 b -> MutVarClosure a1 <$> g b-      BlockingQueueClosure a1 b1 b2 b3 b4 ->-        BlockingQueueClosure a1 <$> g b1 <*> g b2 <*> g b3 <*> g b4-      TSOClosure a1 b1 b2 b3 b4 b5 b6 b7 a2 a3 a4 a5 a6 a7 a8 a9 a10 ->-        (\c1 c2 c3 c4 c5 c6 c7 -> TSOClosure a1 c1 c2 c3 c4 c5 c6 c7 a2 a3 a4 a5 a6 a7 a8 a9 a10) <$> g b1 <*> g b2 <*> g b3 <*> g b4 <*> g b5 <*> g b6 <*> traverse g b7-      StackClosure a1 a2 a3 a4 a5 -> StackClosure a1 a2 a3 a4 <$> f a5-      WeakClosure a1 a2 a3 a4 a5 a6 ->-        WeakClosure a1 <$> g a2 <*> g a3 <*> g a4 <*> g a5 <*> traverse g a6-      TVarClosure a1 a2 a3 a4 ->-        TVarClosure a1 <$> g a2 <*> g a3 <*> pure a4-      TRecChunkClosure a1 a2 a3 a4 -> TRecChunkClosure a1 <$> g a2 <*>  pure a3 <*> traverse (traverse g) a4-      MutPrimClosure a1 a2 a3 -> MutPrimClosure a1 <$> traverse g a2 <*> pure a3-      OtherClosure a1 bs ws -> OtherClosure a1 <$> traverse g bs <*> pure ws-      UnsupportedClosure i  -> pure (UnsupportedClosure i)+      ConstrClosure a1 ph bs ds str ->+        (\ph1 cs cstr -> ConstrClosure a1 ph1 cs ds cstr) <$> (traverse . traverse) fccs ph <*> traverse g bs <*> h str+      FunClosure a1 ph srt_p bs ws -> (\ph1 srt' cs -> FunClosure a1 ph1 srt' cs ws) <$> (traverse . traverse) fccs ph <*> srt srt_p <*> traverse g bs+      ThunkClosure a1 ph srt_p bs ws -> (\ph1 srt' cs -> ThunkClosure a1 ph1 srt' cs ws) <$> (traverse . traverse) fccs ph <*> srt srt_p <*> traverse g bs+      SelectorClosure a1 ph b  -> SelectorClosure a1 <$> (traverse . traverse) fccs ph <*> g b+      PAPClosure a1 a2 a3 a4 a5 a6 -> (\b2 -> PAPClosure a1 b2 a3 a4) <$> (traverse . traverse) fccs a2 <*> g a5 <*> p a6+      APClosure a1 a2 a3 a4 a5 a6 -> (\b2 -> APClosure a1 b2 a3 a4) <$> (traverse . traverse) fccs a2 <*> g a5 <*> p a6+      APStackClosure a1 ph s b bs   -> (\ph2 -> APStackClosure a1 ph2 s) <$> (traverse . traverse) fccs ph <*> g b <*> f bs+      IndClosure a1 ph b -> IndClosure a1 <$> (traverse . traverse) fccs ph <*> g b+      BCOClosure a1 ph b1 b2 b3 a2 a3 a4 ->+        (\ph2 c1 c2 c3 -> BCOClosure a1 ph2 c1 c2 c3 a2 a3 a4) <$> (traverse . traverse) fccs ph <*> g b1 <*> g b2 <*> g b3+      BlackholeClosure a1 ph b -> BlackholeClosure a1 <$> (traverse . traverse) fccs ph <*> g b+      ArrWordsClosure a1 ph a2 a3 -> (\ph2 -> ArrWordsClosure a1 ph2 a2 a3) <$> (traverse . traverse) fccs ph+      MutArrClosure a1 ph a2 a3 bs -> (\ph2 -> MutArrClosure a1 ph2 a2 a3) <$> (traverse . traverse) fccs ph <*> traverse g bs+      SmallMutArrClosure a1 ph a2 bs -> (\ph2 -> SmallMutArrClosure a1 ph2 a2) <$> (traverse . traverse) fccs ph <*> traverse g bs+      MVarClosure a1 ph b1 b2 b3     -> MVarClosure a1 <$> (traverse . traverse) fccs ph <*> g b1 <*> g b2 <*> g b3+      MutVarClosure a1 ph b -> MutVarClosure a1 <$> (traverse . traverse) fccs ph <*> g b+      BlockingQueueClosure a1 ph b1 b2 b3 b4 ->+        BlockingQueueClosure a1 <$> (traverse . traverse) fccs ph <*> g b1 <*> g b2 <*> g b3 <*> g b4+      TSOClosure a1 ph b1 b2 b3 b4 b5 b6 b7 a2 a3 a4 a5 a6 a7 a8 a9 a10 ->+        (\ph2 c1 c2 c3 c4 c5 c6 c7 -> TSOClosure a1 ph2 c1 c2 c3 c4 c5 c6 c7 a2 a3 a4 a5 a6 a7 a8 a9 a10) <$> (traverse . traverse) fccs ph <*> g b1 <*> g b2 <*> g b3 <*> g b4 <*> g b5 <*> g b6 <*> traverse g b7+      StackClosure a1 ph a2 a3 a4 a5 -> (\ph2 -> StackClosure a1 ph2 a2 a3 a4) <$> (traverse . traverse) fccs ph <*> f a5+      WeakClosure a1 ph a2 a3 a4 a5 a6 ->+        WeakClosure a1 <$> (traverse . traverse) fccs ph <*> g a2 <*> g a3 <*> g a4 <*> g a5 <*> traverse g a6+      TVarClosure a1 ph a2 a3 a4 ->+        TVarClosure a1 <$> (traverse . traverse) fccs ph <*> g a2 <*> g a3 <*> pure a4+      TRecChunkClosure a1 ph a2 a3 a4 -> TRecChunkClosure a1 <$> (traverse . traverse) fccs ph <*> g a2 <*>  pure a3 <*> traverse (traverse g) a4+      MutPrimClosure a1 ph a2 a3 -> MutPrimClosure a1 <$> (traverse . traverse) fccs ph <*> traverse g a2 <*> pure a3+      PrimClosure a1 ph a2 a3 -> PrimClosure a1 <$> (traverse . traverse) fccs ph <*> traverse g a2 <*> pure a3+      OtherClosure a1 ph bs ws -> OtherClosure a1 <$> (traverse . traverse) fccs ph <*> traverse g bs <*> pure ws+      UnsupportedClosure i ph -> UnsupportedClosure i <$> (traverse . traverse) fccs ph

@@ -54,6 +54,7 @@ import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) import Data.Bitraversable+import qualified Data.ByteString.Lazy as BS  -- | For heap graphs, i.e. data structures that also represent sharing and -- cyclic structures, these are the entries. If the referenced value is@@ -64,7 +65,7 @@ -- have a slot for arbitrary data, for the user's convenience. data HeapGraphEntry a = HeapGraphEntry {         hgeClosurePtr :: ClosurePtr,-        hgeClosure :: DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe HeapGraphIndex),+        hgeClosure :: DebugClosure CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe HeapGraphIndex),         hgeData :: a}     deriving (Show, Functor, Foldable, Traversable) type HeapGraphIndex = ClosurePtr@@ -118,7 +119,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 SrtPayload PapPayload ConstrDesc (GenStackFrames SrtPayload ClosurePtr) ClosurePtr)+type DerefFunction m a = ClosurePtr -> m (DebugClosureWithExtra a CCSPtr SrtPayload PapPayload ConstrDesc (GenStackFrames SrtPayload ClosurePtr) ClosurePtr)  -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing --   further than the given limit.@@ -169,7 +170,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' <- quintraverse (traverse new_add) (traverse new_add) pure (bitraverse (traverse new_add) new_add) new_add c+                    DCS e c' <- hextraverse pure (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@@ -228,7 +229,7 @@         | cp `elem` bindings = Nothing         | otherwise         = IM.lookup (fromIntegral i) m -    isList :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex]+    isList :: DebugClosure ccs srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex]     isList c         | isNil c =             return []@@ -239,7 +240,7 @@             t' <- isList (hgeClosure e)             return $ (:) h t' -    isString :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe String+    isString :: DebugClosure ccs 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@@ -265,19 +266,19 @@ braceize [] = "" braceize xs = "{" ++ intercalate "," xs ++ "}" -isChar :: DebugClosure srt p ConstrDesc s c -> Maybe Char+isChar :: DebugClosure ccs 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 srt p ConstrDesc s c -> Bool+isNil :: DebugClosure ccs srt p ConstrDesc s c -> Bool isNil ConstrClosure{ constrDesc = ConstrDesc {pkg = "ghc-prim", modl = "GHC.Types", name = "[]"}, dataArgs = _, ptrArgs = []} = True isNil _ = False -isCons :: DebugClosure srt p ConstrDesc s c -> Maybe (c, c)+isCons :: DebugClosure ccs 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 srt p ConstrDesc s c -> Maybe [c]+isTup :: DebugClosure ccs srt p ConstrDesc s c -> Maybe [c] isTup ConstrClosure{ dataArgs = [], ..} =     if length (name constrDesc) >= 3 &&        head (name constrDesc) == '(' && last (name constrDesc) == ')' &&@@ -292,7 +293,7 @@ -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'. -- -- The parameter gives the precedendence, to avoid avoidable parenthesises.-ppClosure :: (Int -> c -> String) -> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String+ppClosure :: (Int -> c -> String) -> Int -> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c -> String ppClosure showBox prec c = case c of     _ | Just ch <- isChar c -> app         ["C#", show ch]@@ -325,7 +326,7 @@     BCOClosure {..} -> app         ["_bco", showBox 10 bcoptrs]     ArrWordsClosure {..} -> app-        ["ARR_WORDS", "("++show bytes ++ " bytes)", ((show $ arrWordsBS arrWords)) ]+        ["ARR_WORDS", "("++show bytes ++ " bytes)", ((show $ arrWordsBS $ take (min 100 $ fromIntegral bytes) arrWords)) ]     MutArrClosure {..} -> app         --["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]         ["[", intercalate ", " (shorten (map (showBox 10) mccPayload)),"]"]@@ -349,6 +350,7 @@     WeakClosure {} -> "_wk" -- TODO     TVarClosure {} -> "_tvar" -- TODO     MutPrimClosure {} -> "_mutPrim" -- TODO+    PrimClosure {} -> "_prim" -- TODO     UnsupportedClosure {info} -> (show info)  

@@ -6,6 +6,7 @@ {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE NumericUnderscores #-}  -- | Data types for representing different pointers and raw information -- All pointers are stored in little-endian to make arithmetic easier.@@ -60,8 +61,13 @@                           , mblockMask                           , mblockMaxSize                           , blockMaxSize-                          , profiling-                          , tablesNextToCode+                          , CCSPtr(..)+                          , CCPtr(..)+                          , readCCPtr+                          , mkCCPtr+                          , IndexTablePtr(..)+                          , mkIndexTablePtr+                          , RetainerSetPtr(..)                            -- * Other utility                           , arrWordsBS@@ -93,14 +99,6 @@ prettyPrint :: BS.ByteString -> String prettyPrint = concatMap (flip showHex "") . BS.unpack --- TODO: Fetch this from debuggee-tablesNextToCode :: Bool-tablesNextToCode = True---- TODO: Fetch this from debuggee-profiling :: Bool-profiling = False- newtype InfoTablePtr = InfoTablePtr Word64                      deriving (Eq, Ord)                      deriving newtype (Hashable)@@ -112,7 +110,38 @@     _ -> Nothing readInfoTablePtr _ = Nothing +newtype RetainerSetPtr = RetainerSetPtr Word64+                   deriving (Eq, Ord)+                   deriving newtype (Hashable)+                   deriving (Show, Binary) via ClosurePtr +newtype CCSPtr = CCSPtr Word64+                   deriving (Eq, Ord)+                   deriving newtype (Hashable)+                   deriving (Show, Binary) via ClosurePtr++newtype CCPtr = CCPtr Word64+                   deriving (Eq, Ord)+                   deriving newtype (Hashable)+                   deriving (Show, Binary) via ClosurePtr++readCCPtr :: String -> Maybe CCPtr+readCCPtr ('0':'x':s) = case readHex s of+                               [(res, "")] -> Just (mkCCPtr res)+                               _ -> Nothing+readCCPtr _ = Nothing++mkCCPtr :: Word64 -> CCPtr+mkCCPtr = CCPtr++newtype IndexTablePtr = IndexTablePtr Word64+                   deriving (Eq, Ord)+                   deriving newtype (Hashable)+                   deriving (Show, Binary) via ClosurePtr++mkIndexTablePtr :: Word64 -> IndexTablePtr+mkIndexTablePtr = IndexTablePtr+ -- Invariant, ClosurePtrs are *always* untagged, we take some care to -- untag them when making a ClosurePtr so we don't have to do it on every -- call to decodeClosure@@ -248,10 +277,10 @@ blockMaxSize = blockMask + 1  mblockMask :: Word64-mblockMask = 0b11111111111111111111 -- 20 bits+mblockMask = 0b1111_1111_1111_1111_1111 -- 20 bits  blockMask :: Word64-blockMask = 0b111111111111 -- 12 bits+blockMask = 0b1111_1111_1111 -- 12 bits  isPinnedBlock :: RawBlock -> Bool isPinnedBlock (RawBlock _ flags _) = (flags .&. 0b100) /= 0

@@ -1,7 +1,21 @@ module GHC.Debug.Types.Version where  import Data.Word+import Data.Maybe (isJust) +data ProfilingMode+  = NoProfiling -- ^ We are running profiled code but not doing any profiling right now+  | RetainerProfiling+  | LDVProfiling+  | EraProfiling+  | OtherProfiling+  deriving (Eq, Ord, Show, Enum)+ data Version = Version { v_major :: Word32                        , v_patch :: Word32+                       , v_profiling :: Maybe ProfilingMode+                       , v_tntc :: Bool                        } deriving (Show, Ord, Eq)++isProfiledRTS :: Version -> Bool+isProfiledRTS = isJust . v_profiling