ghc-debug-common (empty) → 0.1.0.0
raw patch · 13 files changed
+2230/−0 lines, 13 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, bytestring, containers, cpu, deepseq, directory, dom-lt, filepath, ghc-debug-convention, ghc-heap, hashable, transformers, unordered-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- cbits/GhcDebug.cmm +69/−0
- cbits/Heap.c +26/−0
- ghc-debug-common.cabal +47/−0
- src/GHC/Debug/Decode.hs +286/−0
- src/GHC/Debug/Decode/Convert.hs +49/−0
- src/GHC/Debug/Decode/Stack.hs +62/−0
- src/GHC/Debug/Types.hs +471/−0
- src/GHC/Debug/Types/Closures.hs +486/−0
- src/GHC/Debug/Types/Graph.hs +376/−0
- src/GHC/Debug/Types/Ptr.hs +321/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for ghc-debug-common++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Ben Gamari++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ben Gamari nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/GhcDebug.cmm view
@@ -0,0 +1,69 @@+#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);+}
+ cbits/Heap.c view
@@ -0,0 +1,26 @@+#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, size, 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;+}
+ ghc-debug-common.cabal view
@@ -0,0 +1,47 @@+cabal-version: 3.0+name: ghc-debug-common+version: 0.1.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+ the heap of the debuggee program.+homepage: https://gitlab.haskell.org/ghc/ghc-debug+license: BSD-3-Clause+license-file: LICENSE+author: Ben Gamari, Matthew Pickering+maintainer: matthewtpickering@gmail.com+copyright: (c) 2021 Ben Gamari, Matthew Pickering+category: Development+build-type: Simple+extra-source-files: CHANGELOG.md++library+ exposed-modules: GHC.Debug.Decode,+ GHC.Debug.Decode.Convert,+ GHC.Debug.Decode.Stack,+ GHC.Debug.Types,+ GHC.Debug.Types.Closures,+ GHC.Debug.Types.Graph,+ GHC.Debug.Types.Ptr+ build-depends: base >=4.12 && <4.14,+ bytestring ^>=0.11,+ binary ^>=0.8,+ array ^>= 0.5,+ directory ^>= 1.3 ,+ filepath ^>= 1.4,+ hashable ^>= 1.3,+ ghc-heap >= 9.1,+ cpu ^>= 0.1,+ containers ^>= 0.6,+ transformers ^>= 0.5,+ dom-lt ^>= 0.2,+ unordered-containers ^>= 0.2,+ ghc-debug-convention ^>= 0.1,+ 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
+ src/GHC/Debug/Decode.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE BangPatterns #-}+-- | Low-level functions for decoding a closure representation from the raw+-- bytes+module GHC.Debug.Decode ( decodeClosure+ , decodeInfoTable+ ) where++import GHC.Ptr (plusPtr, castPtr)+import GHC.Exts hiding (closureSize#) -- (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.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 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)++-- | Allow access directly to the chunk of memory used by a bytestring+allocate :: BSI.ByteString -> (Ptr a -> IO a) -> IO a+allocate = allocateByCopy+++-- | 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)++skipClosureHeader :: Get ()+skipClosureHeader+ | profiling = () <$ skip (8 * 3)+ | otherwise = () <$ skip (8 * 1)++decodePAPClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodePAPClosure (infot, _) (_, rc) = decodeFromBS rc $ do+ _itbl <- skipClosureHeader+ 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)++decodeAPClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeAPClosure (infot, _) (_, rc) = decodeFromBS rc $ do+ _itbl <- skipClosureHeader+ _itbl <- skipClosureHeader+ 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)+++decodeTVarClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeTVarClosure (infot, _) (_, rc) = decodeFromBS rc $ do+ _itbl <- skipClosureHeader+ ptr <- getClosurePtr+ watch_queue <- getClosurePtr+ updates <- getInt64le+ return $ (TVarClosure infot ptr watch_queue (fromIntegral updates))++getClosurePtr :: Get ClosurePtr+getClosurePtr = get++getWord :: Get Word64+getWord = getWord64le++decodeMutPrim :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeMutPrim (infot, _) (_, rc) = decodeFromBS rc $ do+ _itbl <- skipClosureHeader+ 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)++decodeTrecChunk :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeTrecChunk (infot, _) (_, rc) = decodeFromBS rc $ do+ _itbl <- skipClosureHeader+ prev <- getClosurePtr+ clos_next_idx <- getWord64le+ chunks <- replicateM (fromIntegral clos_next_idx) getChunk+ return $ (TRecChunkClosure infot prev (fromIntegral clos_next_idx) chunks)+ where+ getChunk = do+ TRecEntry <$> getClosurePtr+ <*> getClosurePtr+ <*> getClosurePtr+ <*> (fromIntegral <$> getInt64le) -- TODO: num_updates field is wrong+ -- Not sure how it should+ -- be decoded++decodeBlockingQueue :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeBlockingQueue (infot, _) (_, rc) = decodeFromBS rc $ do+ _itbl <- skipClosureHeader+ q <- getClosurePtr+ bh <- getClosurePtr+ tso <- getClosurePtr+ bh_q <- getClosurePtr+ return $ (GHC.Debug.Types.Closures.BlockingQueueClosure infot 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+ st_size <- getWord32le+ st_dirty <- getWord8+ st_marking <- getWord8+ -- Up to now, 14 bytes are read, skip 2 to get to 16/start of+ -- sp field+ skip 2+ st_sp <- StackPtr <$> getWord+ stackHeaderSize <- bytesRead+ let stack_offset = fromIntegral (subtractStackPtr st_sp cp)+ -- -stackHeaderSize for the bytes already read+ - fromIntegral stackHeaderSize+ len = calculateStackLen st_size (fromIntegral stackHeaderSize) cp st_sp+ -- Skip to start of stack frames+ skip stack_offset+ -- Read the raw frames, we can't decode them yet because we+ -- need to query the debuggee for the bitmaps+ raw_stack <- RawStack <$> getByteString (fromIntegral len)+ return (GHC.Debug.Types.Closures.StackClosure+ infot+ st_size+ st_dirty+ st_marking+ (StackCont st_sp raw_stack))++decodeFromBS :: RawClosure -> Get (DebugClosure pap string s b)+ -> DebugClosureWithExtra Size pap string s b+decodeFromBS (RawClosure rc) parser =+ case runGetOrFail parser (BSL.fromStrict rc) of+ Left err -> error ("DEC:" ++ show err ++ printBS rc)+ Right (_rem, o, v) ->+ 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+ st_size <- getWord+ fun_closure <- getClosurePtr+ k <- bytesRead+ let sp = addStackPtr (StackPtr cp) (fromIntegral k)+ clos_payload <- RawStack <$> getByteString (fromIntegral st_size)+ return $ GHC.Debug.Types.Closures.APStackClosure+ infot+ (fromIntegral st_size)+ fun_closure+ (StackCont sp clos_payload)++decodeStandardLayout :: Get ()+ -> ([ClosurePtr] -> [Word] -> Closure)+ -> (StgInfoTableWithPtr, RawInfoTable)+ -> (ClosurePtr, RawClosure)+ -> SizedClosure+decodeStandardLayout extra k (infot, _) (_, rc) = decodeFromBS rc $ do+ _itbl <- skipClosureHeader+ -- 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)++decodeClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure+decodeClosure 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.+ | (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 = 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) i c+ | (StgInfoTable { tipe = ty }) <- decodedTable itb+ , THUNK <= ty && ty <= THUNK_0_2 =+ decodeStandardLayout (() <$ getWord) (ThunkClosure itb) i c+decodeClosure (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 . quadmap absurd+ id+ absurd+ mkClosurePtr . convertClosure itb+ $ fmap (\(W# w) -> (W64# w)) r+++fixTNTC :: Ptr a -> Ptr StgInfoTable+fixTNTC ptr+ | tablesNextToCode = castPtr $ ptr `plusPtr` realItblSize+ | otherwise = castPtr $ ptr++realItblSize :: Int+realItblSize+ | profiling = ItblProf.itblSize+ | otherwise = Itbl.itblSize++decodeInfoTable :: RawInfoTable -> StgInfoTable+decodeInfoTable (RawInfoTable itbl) = unsafePerformIO $ do+ allocate itbl $ \itblPtr -> do+ peekItbl itblPtr
+ src/GHC/Debug/Decode/Convert.hs view
@@ -0,0 +1,49 @@+{- 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',+convertClosure :: (Num a, Eq a, Show a) => StgInfoTableWithPtr -> GHC.GenClosure a -> DebugClosure 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+ 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.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.WeakClosure _ a2 a3 a4 a5 a6 ->+ -- nullPtr check+ let w_link = if a6 == 0+ then Nothing+ else Just a6+ in WeakClosure itb a2 a3 a4 a5 w_link+ GHC.UnsupportedClosure _ -> UnsupportedClosure itb+ c -> error ("Unexpected closure type: " ++ show c)
+ src/GHC/Debug/Decode/Stack.hs view
@@ -0,0 +1,62 @@+module GHC.Debug.Decode.Stack+ ( decodeStack+ ) where++import Data.Word+import qualified Data.ByteString as BS++import Data.Binary.Get as B++import GHC.Debug.Types+import Control.Monad++import Data.Coerce++decodeStack :: Monad m+ => (RawClosure -> m StgInfoTableWithPtr) -- ^ How to decode the info table for the stack frame+ -> (Word32 -> m PtrBitmap) -- ^ How to decode the bitmap for the stack frame at a given offset+ -> RawStack+ -> m StackFrames+decodeStack decodeInfoTable getBitmap rs = do+ GenStackFrames <$> get_frames 0 rs+ where+ get_frames sp raw@(RawStack c) = do+ st_it <- decodeInfoTable (coerce raw)+ bm <- getBitmap sp+ let res = B.runGetIncremental (getFrame bm st_it) `pushChunk` c+ case res of+ Fail _rem _offset err -> error err+ Partial _inp -> error "Not enough input"+ Done more offset v+ | BS.null more -> return []+ | otherwise -> (v:) <$> get_frames (sp + (fromIntegral offset)) (RawStack more)++getFrame :: PtrBitmap+ -> StgInfoTableWithPtr+ -> Get (DebugStackFrame ClosurePtr)+getFrame st_bitmap itbl =+ case tipe (decodedTable itbl) of+ RET_BCO ->+ -- TODO: In the case of a RET_BCO frame we must decode the frame as a BCO+ -- MP: If you trigger this case, then the decoding logic might+ -- already work but I have never encountered a stack frame with+ -- this type to test it. You might also need to modify `stub.cpp`+ -- but that should be straightforward.+ error "getStack: RET_BCO"+ ty -> do+ -- In all other cases we request the pointer bitmap from the debuggee+ -- and decode as appropriate.+ --traceShowM (headerSize ty, ty, st_bitmap, itbl)+ _itblPtr <- replicateM (headerSize ty) getWord64le+ fields <- traversePtrBitmap decodeField st_bitmap+ return (DebugStackFrame itbl fields)+ where+ decodeField True = SPtr . mkClosurePtr <$> getWord+ decodeField False = SNonPtr <$> getWord++ headerSize RET_FUN = 3+ headerSize RET_BCO = 2+ headerSize _ = 1++getWord :: Get Word64+getWord = getWord64le -- TODO word size
+ src/GHC/Debug/Types.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}++module GHC.Debug.Types(module T+ , Request(..)+ , ForkOrPause(..)+ , requestCommandId+ , doRequest+ , isWriteRequest+ , withWriteRequest+ , isImmutableRequest+ , AnyReq(..)+ , AnyResp(..)+ , CommandId(..)+ , SourceInformation(..)+ , ClosureType(..)++ -- * Serialisation functions+ , getIPE+ , putIPE+ , getInfoTable+ , putInfoTable+ , putRequest+ , getRequest ) where++import Control.Applicative+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import Data.Word+import System.IO++import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Data.Hashable++import GHC.Debug.Types.Closures as T+import GHC.Debug.Types.Ptr as T+import GHC.Exts.Heap.ClosureTypes+import GHC.Debug.Decode+import Control.Concurrent+import Debug.Trace++-- | The decision about whether to fork the running process or+-- pause it running whilst we are debugging it.+data ForkOrPause = Pause | Fork deriving (Eq, Ord, Show, Enum)++instance Hashable ForkOrPause where+ hashWithSalt s v = s `hashWithSalt` (fromEnum v)++instance Binary ForkOrPause where+ put = putWord8 . fromIntegral . fromEnum+ get = getWord8 >>= toBool+ where+ toBool 0 = return (toEnum 0)+ toBool 1 = return (toEnum 1)+ toBool c = fail ("Could not map value " ++ show c ++ " to ForkOrPause")+++-- | A request sent from the debugger to the debuggee parametrized on the result type.+data Request a where+ -- | Request protocol version+ RequestVersion :: Request Word32+ -- | Pause the debuggee.+ RequestPause :: ForkOrPause -> Request ()+ -- | Resume the debuggee.+ RequestResume :: Request ()+ -- | Request the debuggee's root pointers.+ RequestRoots :: Request [ClosurePtr]+ -- | Request a closure+ RequestClosure :: ClosurePtr -> Request RawClosure+ -- | Request an info table+ RequestInfoTable :: InfoTablePtr -> Request (StgInfoTableWithPtr, RawInfoTable)+ -- | Wait for the debuggee to pause itself and then+ -- execute an action. It currently impossible to resume after+ -- a pause caused by a poll.+ RequestPoll :: Request ()+ -- | A client can save objects by calling a special RTS method+ -- This function returns the closures it saved.+ RequestSavedObjects :: Request [ClosurePtr]+ -- | Request the pointer bitmap for a stack frame at a given offset+ -- from a StackPtr.+ RequestStackBitmap :: StackPtr -> Word32 -> Request PtrBitmap+ -- | Decode the bitmap contained in a StgFunInfoTable+ -- Used by PAP and AP closure types.+ RequestFunBitmap :: Word16 -> ClosurePtr -> Request PtrBitmap+ -- | Request the constructor description for an info table.+ -- The info table must be from a 'ConstrClosure'+ RequestConstrDesc :: InfoTablePtr -> Request ConstrDesc+ -- | Lookup source information of an info table+ RequestSourceInfo :: InfoTablePtr -> Request (Maybe SourceInformation)+ -- | Copy all blocks from the process at once+ RequestAllBlocks :: Request [RawBlock]+ -- | Request the block which contains a specific pointer+ RequestBlock :: ClosurePtr -> Request RawBlock++data SourceInformation = SourceInformation { infoName :: !String+ , infoClosureType :: !ClosureType+ , infoType :: !String+ , infoLabel :: !String+ , infoModule :: !String+ , infoPosition :: !String }+ deriving (Show, Eq, Ord)++eq1request :: Request a -> Request b -> Bool+eq1request r1 r2 =+ case r1 of+ RequestVersion -> case r2 of {RequestVersion -> True; _ -> False}+ RequestPause f1 -> case r2 of {RequestPause f2 -> f1 == f2; _ -> False }+ RequestResume -> case r2 of {RequestResume -> True; _ -> False }+ 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 }+ 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 }+ RequestFunBitmap n cp -> case r2 of {(RequestFunBitmap n' cp') -> n == n' && cp == cp'; _ -> False }+ RequestConstrDesc cp -> case r2 of { (RequestConstrDesc cp') -> cp == cp'; _ -> False }+ 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 }++-- | Whether a request mutates the debuggee state, don't cache these ones+isWriteRequest :: Request a -> Bool+isWriteRequest r = getConst $ withWriteRequest r (Const False) (const (Const True))++withWriteRequest :: Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a+withWriteRequest r def k =+ case r of+ RequestPause f -> k (RequestPause f)+ RequestResume -> k RequestResume+ RequestPoll -> k RequestPoll+ _ -> def++-- | Requests which will always answer the same.+-- For example, info tables are immutable and so requesting an info table+-- will always result in the same value and is safe to cache across pause+-- lines.+isImmutableRequest :: Request a -> Bool+isImmutableRequest r =+ case r of+ RequestVersion {} -> True+ RequestInfoTable {} -> True+ RequestSourceInfo {} -> True+ RequestConstrDesc {} -> True+ _ -> False+++deriving instance Show (Request a)+deriving instance Eq (Request a)++instance Hashable (Request a) where+ hashWithSalt s r = case r of+ RequestVersion -> s `hashWithSalt` cmdRequestVersion+ RequestPause f -> s `hashWithSalt` f `hashWithSalt` cmdRequestPause+ RequestResume -> s `hashWithSalt` cmdRequestResume+ RequestRoots -> s `hashWithSalt` cmdRequestRoots+ RequestClosure cs -> s `hashWithSalt` cmdRequestClosures `hashWithSalt` cs+ RequestInfoTable itp -> s `hashWithSalt` cmdRequestInfoTables `hashWithSalt` itp+ RequestPoll -> s `hashWithSalt` cmdRequestPoll+ RequestSavedObjects -> s `hashWithSalt` cmdRequestSavedObjects+ RequestStackBitmap p o -> s `hashWithSalt` cmdRequestStackBitmap `hashWithSalt` p `hashWithSalt` o+ RequestFunBitmap n cp -> s `hashWithSalt` cmdRequestFunBitmap `hashWithSalt` cp `hashWithSalt` n+ RequestConstrDesc cp -> s `hashWithSalt` cmdRequestConstrDesc `hashWithSalt` cp+ RequestSourceInfo itp -> s `hashWithSalt` cmdRequestSourceInfo `hashWithSalt` itp+ RequestAllBlocks -> s `hashWithSalt` cmdRequestAllBlocks+ RequestBlock cp -> s `hashWithSalt` cmdRequestBlock `hashWithSalt` cp+++newtype CommandId = CommandId Word32+ deriving (Eq, Ord, Show)+ deriving newtype (Binary, Hashable)++requestCommandId :: Request a -> CommandId+requestCommandId r = case r of+ RequestVersion {} -> cmdRequestVersion+ RequestPause {} -> cmdRequestPause+ RequestResume {} -> cmdRequestResume+ RequestRoots {} -> cmdRequestRoots+ RequestClosure {} -> cmdRequestClosures+ RequestInfoTable {} -> cmdRequestInfoTables+ RequestPoll {} -> cmdRequestPoll+ RequestSavedObjects {} -> cmdRequestSavedObjects+ RequestStackBitmap {} -> cmdRequestStackBitmap+ RequestFunBitmap {} -> cmdRequestFunBitmap+ RequestConstrDesc {} -> cmdRequestConstrDesc+ RequestSourceInfo {} -> cmdRequestSourceInfo+ RequestAllBlocks {} -> cmdRequestAllBlocks+ RequestBlock {} -> cmdRequestBlock++cmdRequestVersion :: CommandId+cmdRequestVersion = CommandId 1++cmdRequestPause :: CommandId+cmdRequestPause = CommandId 2++cmdRequestResume :: CommandId+cmdRequestResume = CommandId 3++cmdRequestRoots :: CommandId+cmdRequestRoots = CommandId 4++cmdRequestClosures :: CommandId+cmdRequestClosures = CommandId 5++cmdRequestInfoTables :: CommandId+cmdRequestInfoTables = CommandId 6++cmdRequestStackBitmap :: CommandId+cmdRequestStackBitmap = CommandId 7++cmdRequestPoll :: CommandId+cmdRequestPoll = CommandId 8++cmdRequestSavedObjects :: CommandId+cmdRequestSavedObjects = CommandId 9++cmdRequestConstrDesc :: CommandId+cmdRequestConstrDesc = CommandId 11++cmdRequestSourceInfo :: CommandId+cmdRequestSourceInfo = CommandId 12++cmdRequestAllBlocks :: CommandId+cmdRequestAllBlocks = CommandId 14++cmdRequestBlock :: CommandId+cmdRequestBlock = CommandId 15++cmdRequestFunBitmap :: CommandId+cmdRequestFunBitmap = CommandId 16++data AnyReq = forall req . AnyReq !(Request req)++instance Hashable AnyReq where+ hashWithSalt s (AnyReq r) = hashWithSalt s r++instance Eq AnyReq where+ (AnyReq r1) == (AnyReq r2) = eq1request r1 r2++data AnyResp = forall a . AnyResp !a !(a -> Put)++putCommand :: CommandId -> Put -> Put+putCommand c body = do+ putWord32be $ fromIntegral (4 + BSL.length body')+ put c+ putLazyByteString body'+ where+ body' = runPut body++putRequest :: Request a -> Put+putRequest RequestVersion = putCommand cmdRequestVersion mempty+putRequest (RequestPause p) = putCommand cmdRequestPause (put p)+putRequest RequestResume = putCommand cmdRequestResume mempty+putRequest RequestRoots = putCommand cmdRequestRoots mempty+putRequest (RequestClosure cs) =+ putCommand cmdRequestClosures $ do+ putWord16be 1+ put cs+putRequest (RequestInfoTable ts) =+ putCommand cmdRequestInfoTables $ do+ putWord16be 1+ put ts+putRequest (RequestStackBitmap sp o) =+ putCommand cmdRequestStackBitmap $ put sp >> putWord32be o+putRequest (RequestFunBitmap n cp) =+ putCommand cmdRequestFunBitmap $ put cp >> putWord16be n+putRequest (RequestConstrDesc itb) =+ putCommand cmdRequestConstrDesc $ put itb+putRequest RequestPoll = putCommand cmdRequestPoll mempty+putRequest RequestSavedObjects = putCommand cmdRequestSavedObjects mempty+--putRequest (RequestFindPtr c) =+-- putCommand cmdRequestFindPtr $ put c+putRequest (RequestSourceInfo it) = putCommand cmdRequestSourceInfo $ put it+putRequest (RequestAllBlocks) = putCommand cmdRequestAllBlocks $ return ()+putRequest (RequestBlock cp) = putCommand cmdRequestBlock $ put cp++-- This is used to serialise the RequestCache+getRequest :: Get AnyReq+getRequest = do+ len <- getWord32be+ isolate (fromIntegral len) $ do+ cmd <- get+ if+ | cmd == cmdRequestVersion -> return (AnyReq RequestVersion)+ | cmd == cmdRequestPause -> do+ b <- get+ return (AnyReq (RequestPause b))+ | cmd == cmdRequestResume -> return (AnyReq RequestResume)+ | cmd == cmdRequestRoots -> return (AnyReq RequestRoots)+ | cmd == cmdRequestClosures -> do+ _n <- getWord16be+-- cs <- replicateM (fromIntegral n) get+ cp <- get+ return (AnyReq (RequestClosure cp))+ | cmd == cmdRequestInfoTables -> do+ _n <- getWord16be+ --itbs <- replicateM (fromIntegral n) get+ itb <- get+ return (AnyReq (RequestInfoTable itb))+ | cmd == cmdRequestStackBitmap -> do+ sp <- get+ o <- getWord32be+ return (AnyReq (RequestStackBitmap sp o))+ | cmd == cmdRequestFunBitmap -> do+ cp <- get+ n <- getWord16be+ return (AnyReq (RequestFunBitmap n cp))+ | cmd == cmdRequestConstrDesc -> do+ itb <- get+ return (AnyReq (RequestConstrDesc itb))+ | cmd == cmdRequestPoll -> return (AnyReq RequestPoll)+ | cmd == cmdRequestSavedObjects -> return (AnyReq RequestSavedObjects)+ | cmd == cmdRequestSourceInfo -> do+ it <- get+ return (AnyReq (RequestSourceInfo it))+ | cmd == cmdRequestAllBlocks -> return (AnyReq RequestAllBlocks)+ | cmd == cmdRequestBlock -> do+ cp <- get+ return (AnyReq (RequestBlock cp))+ | otherwise -> error (show cmd)+++getResponse :: Request a -> Get a+getResponse RequestVersion = getWord32be+getResponse RequestPause {} = get+getResponse RequestResume = get+getResponse RequestRoots = many get+getResponse (RequestClosure {}) = get+getResponse (RequestInfoTable itbp) = (\(it, r) -> (StgInfoTableWithPtr itbp it, r)) <$> getInfoTable+-- zipWith (\p (it, r) -> (StgInfoTableWithPtr p it, r)) itps+-- <$> replicateM (length itps) getInfoTable+getResponse (RequestStackBitmap {}) = get+getResponse (RequestFunBitmap {}) = get+getResponse (RequestConstrDesc _) = getConstrDesc+getResponse RequestPoll = get+getResponse RequestSavedObjects = many get+getResponse (RequestSourceInfo _c) = getIPE+getResponse RequestAllBlocks = many get+getResponse RequestBlock {} = get+++getConstrDesc :: Get ConstrDesc+getConstrDesc = do+ len <- getInt32be+ parseConstrDesc . C8.unpack <$> getByteString (fromIntegral len)++getIPE :: Get (Maybe SourceInformation)+getIPE = do+ num <- getInt32be+ res <- replicateM (fromIntegral num) getOne+ case res of+ (id_name:cty:ty:lab:modu:loc:[]) ->+ return . Just $! SourceInformation id_name (readCTy cty) ty lab modu loc+ [] -> return Nothing+ fs -> fail (show ("Expecting 6 or 0 fields in IPE" :: String, fs,num))+ where+ getOne = do+ !len <- getInt32be+ !res <- C8.unpack <$> getByteString (fromIntegral len)+ return res+ -- All constructor nodes get 0, this is a wibble in the implementation+ -- of IPEs+ readCTy "0" = CONSTR+ readCTy n = toEnum (read @Int n)++putIPE :: Maybe SourceInformation -> Put+putIPE Nothing = putInt32be 0+putIPE (Just (SourceInformation a ty b c d e)) = do+ putInt32be 6+ putOne a+ putOne (show (fromEnum ty))+ putOne b+ putOne c+ putOne d+ putOne e+ where+ putOne s = do+ putInt32be (fromIntegral $ length s)+ putByteString (C8.pack s)+++++getInfoTable :: Get (StgInfoTable, RawInfoTable)+getInfoTable = do+ !len <- getInt32be+ !r <- RawInfoTable <$> getByteString (fromIntegral len)+ let !it = decodeInfoTable r+ return (it, r)++putInfoTable :: RawInfoTable -> Put+putInfoTable (RawInfoTable rc) = do+ let n = BS.length rc+ putWord32be (fromIntegral n)+ putByteString rc++++data Error = BadCommand+ | BadStack+ | AlreadyPaused+ | NotPaused+ | NoResume+ deriving stock (Eq, Ord, Show)++instance Exception Error++data ResponseCode = Okay+ | OkayContinues+ | Error Error+ deriving stock (Eq, Ord, Show)++getResponseCode :: Get ResponseCode+getResponseCode = getWord16be >>= f+ where+ f 0x0 = pure Okay+ f 0x1 = pure OkayContinues+ f 0x100 = pure $ Error BadCommand+ f 0x104 = pure $ Error BadStack+ f 0x101 = pure $ Error AlreadyPaused+ f 0x102 = pure $ Error NotPaused+ f 0x103 = pure $ Error NoResume+ f _ = fail "Unknown response code"++data Stream a r = Next !a (Stream a r)+ | End r++readFrames :: Handle -> IO (Stream BS.ByteString (Maybe Error))+readFrames hdl = do+ (respLen, status) <- runGet frameHeader <$> BSL.hGet hdl 6+ respBody <- BS.hGet hdl (fromIntegral respLen)+ case status of+ OkayContinues -> do rest <- readFrames hdl+ return $ Next respBody rest+ Okay -> return $ Next respBody (End Nothing)+ Error err-> return $ End (Just err)+ where+ frameHeader :: Get (Word32, ResponseCode)+ frameHeader =+ (,) <$> getWord32be+ <*> getResponseCode++throwStream :: Exception e => Stream a (Maybe e) -> [a]+throwStream = f+ where+ f (Next x rest) = x : f rest+ f (End Nothing) = []+ f (End (Just e)) = throw e++concatStream :: Stream BS.ByteString (Maybe Error) -> BSL.ByteString+concatStream = BSL.fromChunks . throwStream++-- | Perform a request+doRequest :: MVar Handle -> Request a -> IO a+doRequest mhdl req = withMVar mhdl $ \hdl -> do+ BSL.hPutStr hdl $ runPut $ putRequest req+ bframes <- readFrames hdl+ let x = runGet (getResponse req) (concatStream bframes)+ return x
+ src/GHC/Debug/Types/Closures.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{- | The Haskell representation of a heap closure, the 'DebugClosure' type+- is quite similar to the one found in the @ghc-heap@ package but with some+- more type parameters and other changes..+-}+module GHC.Debug.Types.Closures (+ -- * Closure Representation+ Closure+ , SizedClosure+ , SizedClosureC+ , DebugClosure(..)+ , TRecEntry(..)+ -- * Wrappers+ , DebugClosureWithSize+ , DebugClosureWithExtra(..)+ , Size(..)+ , InclusiveSize(..)+ , RetainerSize(..)+ , noSize+ , dcSize+ , allClosures+ -- * Info Table Representation+ , StgInfoTable(..)+ , GHC.ClosureType(..)+ , StgInfoTableWithPtr(..)+ -- * Stack Frame Representation+ , DebugStackFrame(..)+ , FieldValue(..)+ , GenStackFrames(..)+ , StackFrames+ , StackCont(..)+ -- * PAP payload representation+ , GenPapPayload(..)+ , PapPayload+ , PayloadCont(..)+ -- * Constructor Description Representation+ , ConstrDesc(..)+ , ConstrDescCont+ , parseConstrDesc++ -- * Traversing functions+ , Quadtraversable(..)+ , quadmap+ ) 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+import GHC.Exts+import GHC.Generics+import GHC.Debug.Types.Ptr+import Data.List (sortBy, intercalate)+import Data.Char+import Data.Kind++import Control.Applicative+import Data.Monoid+++------------------------------------------------------------------------+-- Closures+++type Closure = DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr+type SizedClosure = DebugClosureWithSize PayloadCont ConstrDescCont StackCont ClosurePtr+type SizedClosureC = DebugClosureWithSize PayloadCont ConstrDesc StackCont ClosurePtr++-- | Information needed to decode a 'ConstrDesc'+type ConstrDescCont = InfoTablePtr++-- | Information needed to decode a PAP payload+data PayloadCont = PayloadCont ClosurePtr [Word64] deriving Show++type DebugClosureWithSize = DebugClosureWithExtra Size++data DebugClosureWithExtra x pap string s b = DCS { extraDCS :: x+ , unDCS :: DebugClosure 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)++newtype InclusiveSize = InclusiveSize { getInclusiveSize :: Int }+ deriving stock (Show, Generic)+ deriving (Semigroup, Monoid) via (Sum Int)++newtype RetainerSize = RetainerSize { getRetainerSize :: Int }+ deriving stock (Show, Generic, Ord, Eq)+ deriving (Semigroup, Monoid) via (Sum Int)+++noSize :: DebugClosureWithSize pap string s b -> DebugClosure pap string s b+noSize = unDCS++dcSize :: DebugClosureWithSize 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++data StgInfoTableWithPtr = StgInfoTableWithPtr {+ tableId :: InfoTablePtr+ , decodedTable :: StgInfoTable+ } deriving (Show)++instance Ord StgInfoTableWithPtr where+ compare t1 t2 = compare (tableId t1) (tableId t2)++instance Eq StgInfoTableWithPtr where+ t1 == t2 = tableId t1 == tableId t2+++-- | 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>+--+-- The data type is parametrized by 4 type parameters which correspond to+-- different pointer types.+--+-- All Heap objects have the same basic layout. A header containing a pointer+-- to the info table and a payload with various fields. The @info@ field below+-- always refers to the info table pointed to by the header. The remaining+-- fields are the payload.+--+-- See+-- <https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects>+-- for more information.+data DebugClosure pap string s b+ = -- | A data constructor+ ConstrClosure+ { info :: !StgInfoTableWithPtr+ , ptrArgs :: ![b] -- ^ Pointer arguments+ , dataArgs :: ![Word] -- ^ Non-pointer arguments+ , constrDesc :: !string+ }++ -- | A function+ | FunClosure+ { info :: !StgInfoTableWithPtr+ , ptrArgs :: ![b] -- ^ Pointer arguments+ , dataArgs :: ![Word] -- ^ Non-pointer arguments+ }++ -- | A thunk, an expression not obviously in head normal form+ | ThunkClosure+ { info :: !StgInfoTableWithPtr+ , ptrArgs :: ![b] -- ^ Pointer arguments+ , dataArgs :: ![Word] -- ^ Non-pointer arguments+ }++ -- | A thunk which performs a simple selection operation+ | SelectorClosure+ { info :: !StgInfoTableWithPtr+ , selectee :: !b -- ^ Pointer to the object being+ -- selected from+ }++ -- | An unsaturated function application+ | PAPClosure+ { info :: !StgInfoTableWithPtr+ , arity :: !HalfWord -- ^ Arity of the partial application+ , n_args :: !HalfWord -- ^ Size of the payload in words+ , fun :: !b -- ^ Pointer to a 'FunClosure'+ , pap_payload :: !pap -- ^ Sequence of already applied+ -- arguments+ }++ -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported+ -- functions fun actually find the name here.+ -- At least the other direction works via "lookupSymbol+ -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)+ -- | A function application+ | APClosure+ { info :: !StgInfoTableWithPtr+ , arity :: !HalfWord -- ^ Always 0+ , n_args :: !HalfWord -- ^ Size of payload in words+ , fun :: !b -- ^ Pointer to a 'FunClosure'+ , ap_payload :: !pap -- ^ Sequence of already applied+ -- arguments+ }++ -- | A suspended thunk evaluation+ | APStackClosure+ { info :: !StgInfoTableWithPtr+ , ap_st_size :: !Word+ , fun :: !b -- ^ Function closure+ , payload :: !s -- ^ Stack right before suspension+ }++ -- | A pointer to another closure, introduced when a thunk is updated+ -- to point at its value+ | IndClosure+ { info :: !StgInfoTableWithPtr+ , indirectee :: !b -- ^ Target closure+ }++ -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code+ -- interpreter (e.g. as used by GHCi)+ | BCOClosure+ { info :: !StgInfoTableWithPtr+ , instrs :: !b -- ^ A pointer to an ArrWords+ -- of instructions+ , literals :: !b -- ^ A pointer to an ArrWords+ -- of literals+ , bcoptrs :: !b -- ^ A pointer to an ArrWords+ -- of byte code objects+ , arity :: !HalfWord -- ^ The arity of this BCO+ , size :: !HalfWord -- ^ The size of this BCO in words+ , bitmap :: ![Word] -- ^ An StgLargeBitmap describing the+ -- pointerhood of its args/free vars+ }++ -- | A thunk under evaluation by another thread+ | BlackholeClosure+ { info :: !StgInfoTableWithPtr+ , indirectee :: !b -- ^ The target closure+ }++ -- | A @ByteArray#@+ | ArrWordsClosure+ { info :: !StgInfoTableWithPtr+ , bytes :: !Word -- ^ Size of array in bytes+ , arrWords :: ![Word] -- ^ Array payload+ }++ -- | A @MutableByteArray#@+ | MutArrClosure+ { info :: !StgInfoTableWithPtr+ , mccPtrs :: !Word -- ^ Number of pointers+ , mccSize :: !Word -- ^ ?? Closures.h vs ClosureMacros.h+ , mccPayload :: ![b] -- ^ Array payload+ -- Card table ignored+ }++ -- | A @SmallMutableArray#@+ --+ -- @since 8.10.1+ | SmallMutArrClosure+ { info :: !StgInfoTableWithPtr+ , mccPtrs :: !Word -- ^ Number of pointers+ , mccPayload :: ![b] -- ^ Array payload+ }++ -- | An @MVar#@, with a queue of thread state objects blocking on them+ | MVarClosure+ { info :: !StgInfoTableWithPtr+ , queueHead :: !b -- ^ Pointer to head of queue+ , queueTail :: !b -- ^ Pointer to tail of queue+ , value :: !b -- ^ Pointer to closure+ }++ -- | A @MutVar#@+ | MutVarClosure+ { info :: !StgInfoTableWithPtr+ , var :: !b -- ^ Pointer to contents+ }++ -- | An STM blocking queue.+ | BlockingQueueClosure+ { info :: !StgInfoTableWithPtr+ , link :: !b -- ^ ?? Here so it looks like an IND+ , blackHole :: !b -- ^ The blackhole closure+ , owner :: !b -- ^ The owning thread state object+ , queue :: !b -- ^ ??+ }++ | TSOClosure+ { info :: !StgInfoTableWithPtr+ -- pointers+ , _link :: !b+ , global_link :: !b+ , tsoStack :: !b -- ^ stackobj from StgTSO+ , trec :: !b+ , blocked_exceptions :: !b+ , bq :: !b+ -- values+ , what_next :: GHC.WhatNext+ , why_blocked :: GHC.WhyBlocked+ , flags :: [GHC.TsoFlags]+ , threadId :: Word64+ , saved_errno :: Word32+ , dirty:: Word32+ , alloc_limit :: Int64+ , tot_stack_size :: Word32+ , prof :: Maybe ProfTypes.StgTSOProfInfo+ }++ | StackClosure+ { info :: !StgInfoTableWithPtr+ , stack_size :: !Word32 -- ^ stack size in *words*+ , stack_dirty :: !Word8 -- ^ non-zero => dirty+ , stack_marking :: !Word8+ , frames :: s+ }+++ | WeakClosure+ { info :: !StgInfoTableWithPtr+ , cfinalizers :: !b+ , key :: !b+ , value :: !b+ , finalizer :: !b+ , mlink :: !(Maybe b) -- ^ next weak pointer for the capability, can be NULL.+ }++ | TVarClosure+ { info :: !StgInfoTableWithPtr+ , current_value :: !b+ , tvar_watch_queue :: !b+ , num_updates :: !Int }++ | TRecChunkClosure+ { info :: !StgInfoTableWithPtr+ , prev_chunk :: !b+ , next_idx :: !Word+ , entries :: ![TRecEntry b]+ }++ | MutPrimClosure+ { info :: !StgInfoTableWithPtr+ , ptrArgs :: ![b]+ , dataArgs :: ![Word]+ }++ -----------------------------------------------------------+ -- Anything else++ -- | Another kind of closure+ | OtherClosure+ { info :: !StgInfoTableWithPtr+ , hvalues :: ![b]+ , rawWords :: ![Word]+ }++ | UnsupportedClosure+ { info :: !StgInfoTableWithPtr+ }+ deriving (Show, Generic, Functor, Foldable, Traversable, Ord, Eq)++data TRecEntry b = TRecEntry { tvar :: !b+ , expected_value :: !b+ , new_value :: !b+ , trec_num_updates :: Int -- Only in THREADED, TODO: This is not an Int,+ -- is it a pointer+ -- to a haskell int+ } deriving (Show, Generic, Functor, Foldable, Traversable, Ord, Eq)++newtype GenPapPayload b = GenPapPayload { getValues :: [FieldValue b] }+ deriving (Functor, Foldable, Traversable, Show, Ord, Eq)++type PapPayload = GenPapPayload ClosurePtr++-- | Information needed to decode a set of stack frames+data StackCont = StackCont StackPtr -- Address of start of frames+ RawStack -- The raw frames+ deriving Show++type StackFrames = GenStackFrames ClosurePtr+newtype GenStackFrames b = GenStackFrames { getFrames :: [DebugStackFrame b] }+ deriving (Functor, Foldable, Traversable, Show, Ord, Eq)++data DebugStackFrame b+ = DebugStackFrame+ { frame_info :: !StgInfoTableWithPtr+ , values :: [FieldValue b]+ } deriving (Traversable, Functor, Foldable, Show, Ord, Eq)++++data ConstrDesc = ConstrDesc {+ pkg :: !String -- ^ Package name+ , modl :: !String -- ^ Module name+ , name :: !String -- ^ Constructor name+ } deriving (Show, Eq, Ord)+++-- Copied from ghc-heap+parseConstrDesc :: String -> ConstrDesc+parseConstrDesc input =+ if not . all (>0) . fmap length $ [p,m,occ]+ then ConstrDesc "" "" input+ else ConstrDesc p m occ+ where+ (p, rest1) = break (== ':') input+ (m, occ)+ = (intercalate "." $ reverse modWords, occWord)+ where+ (modWords, occWord) =+ if null rest1 -- XXXXXXXXx YUKX+ --then error "getConDescAddress:parse:length rest1 < 1"+ then parseModOcc [] []+ else parseModOcc [] (tail rest1)+ -- We only look for dots if str could start with a module name,+ -- i.e. if it starts with an upper case character.+ -- Otherwise we might think that "X.:->" is the module name in+ -- "X.:->.+", whereas actually "X" is the module name and+ -- ":->.+" is a constructor name.+ parseModOcc :: [String] -> String -> ([String], String)+ parseModOcc acc str@(c : _)+ | isUpper c =+ case break (== '.') str of+ (top, []) -> (acc, top)+ (top, _:bot) -> parseModOcc (top : acc) bot+ parseModOcc acc str = (acc, str)++class Quadtraversable m where+ quadtraverse ::+ 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)++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)+ -> (c -> Identity d)+ -> (e -> Identity f)+ -> (g -> Identity h)+ -> t a c e g -> Identity (t b d f h))++allClosures :: DebugClosure (GenPapPayload c) a (GenStackFrames c) c -> [c]+allClosures c = getConst $ quadtraverse (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 =+ 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+ 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 a2 a3 a4 a5 a6 a7 a8 a9 a10 ->+ (\c1 c2 c3 c4 c5 c6 -> TSOClosure a1 c1 c2 c3 c4 c5 c6 a2 a3 a4 a5 a6 a7 a8 a9 a10) <$> g b1 <*> g b2 <*> g b3 <*> g b4 <*> g b5 <*> g b6+ 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)
+ src/GHC/Debug/Types/Graph.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE NamedFieldPuns #-}+module GHC.Debug.Types.Graph( -- * Types+ HeapGraph(..)+ , HeapGraphEntry(..)+ , HeapGraphIndex+ , PapHI+ , StackHI+ -- * Building a heap graph+ , DerefFunction+ , buildHeapGraph+ , multiBuildHeapGraph+ , generalBuildHeapGraph++ -- * Printing a heap graph+ , ppHeapGraph+ , ppClosure++ -- * Utility+ , lookupHeapGraph+ , traverseHeapGraph+ , updateHeapGraph+ , heapGraphSize+ , annotateHeapGraph++ -- * Reverse Graph+ , ReverseGraph+ , mkReverseGraph+ , reverseEdges+ )+ where++import Data.Char+import Data.List (intercalate, foldl', sort, group, sortBy, groupBy)+import Data.Maybe ( catMaybes )+import Data.Function+import qualified Data.HashMap.Strict as M+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans.State+import Control.Monad.Trans.Class+import GHC.Debug.Types.Ptr+import GHC.Debug.Types.Closures+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))++-- | For heap graphs, i.e. data structures that also represent sharing and+-- cyclic structures, these are the entries. If the referenced value is+-- @Nothing@, then we do not have that value in the map, most likely due to+-- exceeding the recursion bound passed to 'buildHeapGraph'.+--+-- Besides a pointer to the stored value and the closure representation we+-- have a slot for arbitrary data, for the user's convenience.+data HeapGraphEntry a = HeapGraphEntry {+ hgeClosurePtr :: ClosurePtr,+ hgeClosure :: DebugClosure PapHI ConstrDesc StackHI (Maybe HeapGraphIndex),+ hgeData :: a}+ deriving (Show, Functor, Foldable, Traversable)+type HeapGraphIndex = ClosurePtr++type StackHI = GenStackFrames (Maybe HeapGraphIndex)+type PapHI = GenPapPayload (Maybe HeapGraphIndex)++-- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',+-- as the internal representation may change. Nevertheless, we export it here:+-- Sometimes the user knows better what he needs than we do.+data HeapGraph a = HeapGraph+ { roots :: !(NE.NonEmpty ClosurePtr)+ , graph :: !(IM.IntMap (HeapGraphEntry a)) }+ deriving (Show, Foldable, Traversable, Functor)++traverseHeapGraph :: Applicative m =>+ (HeapGraphEntry a -> m (HeapGraphEntry b))+ -> HeapGraph a+ -> m (HeapGraph b)+traverseHeapGraph f (HeapGraph r im) = HeapGraph r <$> traverse f im+++lookupHeapGraph :: HeapGraphIndex -> HeapGraph a -> Maybe (HeapGraphEntry a)+lookupHeapGraph (ClosurePtr i) (HeapGraph _r m) = IM.lookup (fromIntegral i) m++insertHeapGraph :: HeapGraphIndex -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a+insertHeapGraph (ClosurePtr i) a (HeapGraph r m) = HeapGraph r (IM.insert (fromIntegral i) a m)++updateHeapGraph :: (HeapGraphEntry a -> Maybe (HeapGraphEntry a))+ -> HeapGraphIndex+ -> HeapGraph a+ -> HeapGraph a+updateHeapGraph f (ClosurePtr i) (HeapGraph r m) = HeapGraph r (IM.update f (fromIntegral i) m)++heapGraphSize :: HeapGraph a -> Int+heapGraphSize (HeapGraph _ g) = IM.size g++-- | Creates a 'HeapGraph' for the value in the box, but not recursing further+-- than the given limit.+buildHeapGraph+ :: (MonadFix m)+ => DerefFunction m a+ -> Maybe Int+ -> ClosurePtr -- ^ The value to start with+ -> m (HeapGraph a)+buildHeapGraph deref limit initialBox =+ multiBuildHeapGraph deref limit (NE.singleton initialBox)++-- TODO: It is a bit undesirable that the ConstrDesc field is already+-- 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)++-- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing+-- further than the given limit.+multiBuildHeapGraph+ :: (MonadFix m)+ => DerefFunction m a+ -> Maybe Int+ -> NonEmpty ClosurePtr -- ^ Starting values with associated data entry+ -> m (HeapGraph a)+multiBuildHeapGraph deref limit rs =+ generalBuildHeapGraph deref limit (HeapGraph rs IM.empty) rs+{-# INLINE multiBuildHeapGraph #-}++-- | Adds the given annotation to the entry at the given index, using the+-- 'mappend' operation of its 'Monoid' instance.+annotateHeapGraph :: (a -> a) -> HeapGraphIndex -> HeapGraph a -> HeapGraph a+annotateHeapGraph f i hg = updateHeapGraph go i hg+ where+ go hge = Just $ hge { hgeData = f (hgeData hge) }++{-# INLINE generalBuildHeapGraph #-}+generalBuildHeapGraph+ :: forall m a . (MonadFix m)+ => DerefFunction m a+ -> Maybe Int+ -> HeapGraph a+ -> NonEmpty ClosurePtr+ -> m (HeapGraph a)+generalBuildHeapGraph deref limit hg addBoxes = do+ -- First collect all boxes from the existing heap graph+ (_is, hg') <- runStateT (mapM (add limit) addBoxes) hg+ return hg'+ where+ add :: Maybe Int -> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)+ add (Just 0) _ = return Nothing+ add n cp = do+ -- If the box is in the map, return the index+ hm <- get+ case lookupHeapGraph cp hm of+ Just {} -> return (Just cp)+ -- FIXME GHC BUG: change `mdo` to `do` below:+ -- "GHC internal error: ‘c’ is not in scope during type checking, but it passed the renamer"+ Nothing -> mdo+ -- Look up the closure+ c <- lift $ deref cp+ let new_add = add (subtract 1 <$> n)+ -- NOTE: We tie-the-knot here with RecursiveDo so that we don't+ -- 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+ return (Just cp)++-- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example+-- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:+--+-- >let x1 = "Ki"+-- > x6 = C# 'H' : C# 'o' : x6+-- >in (x1,x1,x6)+ppHeapGraph :: (a -> String) -> HeapGraph a -> String+ppHeapGraph printData (HeapGraph (heapGraphRoot :| rs) m) = letWrapper ++ "(" ++ printData (hgeData (iToE heapGraphRoot)) ++ ") " ++ roots+ where+ -- All variables occuring more than once+ bindings = boundMultipleTimes (HeapGraph (heapGraphRoot :| rs) m) [heapGraphRoot]++ roots = unlines [+ "r" ++ show n ++ ":(" ++ printData (hgeData (iToE r)) ++ ") " ++ ppRef 0 (Just r) ++ "\n"+ | (n, r) <- zip [0 :: Int ..] (heapGraphRoot : rs) ]++ letWrapper =+ if null bindings+ then ""+ else "let " ++ intercalate "\n " (map ppBinding bindings) ++ "\nin "++ bindingLetter i = case hgeClosure (iToE i) of+ ThunkClosure {} -> 't'+ SelectorClosure {} -> 't'+ APClosure {} -> 't'+ PAPClosure {} -> 'f'+ BCOClosure {} -> 't'+ FunClosure {} -> 'f'+ _ -> 'x'++ ppBindingMap = M.fromList $+ concatMap (zipWith (\j (i,c) -> (i, c : show j)) [(1::Int)..]) $+ groupBy ((==) `on` snd) $+ sortBy (compare `on` snd)+ [ (i, bindingLetter i) | i <- bindings ]++ ppVar i = ppBindingMap M.! i+ ppBinding i = ppVar i ++ "(" ++ printData (hgeData (iToE i)) ++ ") = " ++ ppEntry 0 (iToE i)++ 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)+ where+ _app [a] = a ++ "()"+ _app xs = addBraces (10 <= prec) (unwords xs)++ ppRef _ Nothing = "..."+ ppRef prec (Just i) | i `elem` bindings = ppVar i+ | otherwise = ppEntry prec (iToE i)+ iToE (ClosurePtr i) = m IM.! (fromIntegral i)++ iToUnboundE cp@(ClosurePtr i)+ | cp `elem` bindings = Nothing+ | otherwise = IM.lookup (fromIntegral i) m++ isList :: DebugClosure p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex]+ isList c+ | isNil c =+ return []+ | otherwise = do+ (h,t) <- isCons c+ ti <- t+ e <- iToUnboundE ti+ t' <- isList (hgeClosure e)+ return $ (:) h t'++ isString :: DebugClosure 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+ -- are really strings.+ if null list+ then Nothing+ else mapM (isChar . hgeClosure <=< iToUnboundE <=< id) list+++-- | In the given HeapMap, list all indices that are used more than once. The+-- second parameter adds external references, commonly @[heapGraphRoot]@.+boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]+boundMultipleTimes (HeapGraph _rs m) roots = map head $ filter (not.null) $ group $ sort $+ roots ++ concatMap (catMaybes . allClosures . hgeClosure) (IM.elems m)++-- Utilities++addBraces :: Bool -> String -> String+addBraces True t = "(" ++ t ++ ")"+addBraces False t = t++braceize :: [String] -> String+braceize [] = ""+braceize xs = "{" ++ intercalate "," xs ++ "}"++isChar :: DebugClosure 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 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 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 ConstrClosure{ dataArgs = [], ..} =+ if length (name constrDesc) >= 3 &&+ head (name constrDesc) == '(' && last (name constrDesc) == ')' &&+ all (==',') (tail (init (name constrDesc)))+ then Just ptrArgs else Nothing+isTup _ = Nothing++++-- | A pretty-printer that tries to generate valid Haskell for evalutated data.+-- It assumes that for the included boxes, you already replaced them by Strings+-- 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+ _ | Just ch <- isChar c -> app+ ["C#", show ch]+ _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $+ showBox 5 h ++ " : " ++ showBox 4 t+ _ | Just vs <- isTup c ->+ "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"+ ConstrClosure {..} -> app $+ name constrDesc : map (showBox 10) ptrArgs ++ map show dataArgs+ ThunkClosure {..} -> app $+ "_thunk(" : herald : ")" : map (showBox 10) ptrArgs ++ map show dataArgs+ SelectorClosure {..} -> app+ ["_sel", showBox 10 selectee]+ IndClosure {..} -> app+ ["_ind", showBox 10 indirectee]+ BlackholeClosure {..} -> app+ ["_bh", showBox 10 indirectee]+ APClosure {..} -> app $ map (showBox 10) $+ [fun]+ -- TODO: Payload+ PAPClosure {..} -> app $ map (showBox 10) $+ [fun] -- TODO payload+ APStackClosure {..} -> app $ map (showBox 10) $+ [fun] -- TODO: stack+ TRecChunkClosure {} -> "_trecChunk" --TODO+ BCOClosure {..} -> app+ ["_bco", showBox 10 bcoptrs]+ ArrWordsClosure {..} -> app+ ["ARR_WORDS", "("++show bytes ++ " bytes)", ((show $ arrWordsBS arrWords)) ]+ MutArrClosure {..} -> app+ --["toMutArray", "("++show (length mccPayload) ++ " ptrs)", intercalate "," (shorten (map (showBox 10) mccPayload))]+ ["[", intercalate ", " (shorten (map (showBox 10) mccPayload)),"]"]+ SmallMutArrClosure {..} -> app+ ["[", intercalate ", " (shorten (map (showBox 10) mccPayload)),"]"]+ MutVarClosure {..} -> app+ ["_mutVar", showBox 10 var]+ MVarClosure {..} -> app+ ["MVar", showBox 10 value]+ FunClosure {..} ->+ "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)+ BlockingQueueClosure {} ->+ "_blockingQueue"+ OtherClosure {} ->+ "_other"+ TSOClosure {} -> "TSO"+ StackClosure {..} -> app ["Stack(", show stack_size, ")"] -- TODO+ WeakClosure {} -> "_wk" -- TODO+ TVarClosure {} -> "_tvar" -- TODO+ MutPrimClosure {} -> "_mutPrim" -- TODO+ UnsupportedClosure {info} -> (show info)+++ where+ app [a] = a ++ "()"+ app xs = addBraces (10 <= prec) (unwords xs)++ shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs+++-- Reverse Edges+--+closurePtrToInt :: ClosurePtr -> Int+closurePtrToInt (ClosurePtr p) = fromIntegral p++intToClosurePtr :: Int -> ClosurePtr+intToClosurePtr i = mkClosurePtr (fromIntegral i)++newtype ReverseGraph = ReverseGraph (IM.IntMap IS.IntSet)++reverseEdges :: ClosurePtr -> ReverseGraph -> Maybe [ClosurePtr]+reverseEdges cp (ReverseGraph rg) =+ map intToClosurePtr . IS.toList <$> IM.lookup (closurePtrToInt cp) rg++mkReverseGraph :: HeapGraph a -> ReverseGraph+mkReverseGraph (HeapGraph _ hg) = ReverseGraph graph+ where+ graph = IM.foldlWithKey' collectNodes IM.empty hg+ collectNodes newMap k h =+ let bs = allClosures (hgeClosure h)+ in foldl' (\m ma ->+ case ma of+ Nothing -> m+ Just a -> IM.insertWith IS.union (closurePtrToInt a) (IS.singleton k) m) newMap bs+
+ src/GHC/Debug/Types/Ptr.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Data types for representing different pointers and raw information+-- All pointers are stored in little-endian to make arithmetic easier.+--+-- We have to send and recieve the pointers in big endian though. This+-- conversion is dealt with in the Binary instance for ClosurePtr and+-- then the other pointers are derived from this instance using DerivingVia+module GHC.Debug.Types.Ptr( -- * InfoTables+ InfoTablePtr(..)+ , RawInfoTable(..)+ -- UntaggedClosurePtr constructor not exported so+ -- we can maintain the invariant that all+ -- ClosurePtr are untagged+ -- * Closures+ , ClosurePtr(..,ClosurePtr)+ , mkClosurePtr+ , RawClosure(..)+ , rawClosureSize+ , getInfoTblPtr+ -- * Operations on 'ClosurePtr'+ , applyBlockMask+ , applyMBlockMask+ , subtractBlockPtr+ , heapAlloced++ , getBlockOffset+ -- * Blocks+ , BlockPtr(..)+ , RawBlock(..)+ , isLargeBlock+ , isPinnedBlock+ , rawBlockAddr+ , extractFromBlock+ , blockMBlock+ , rawBlockSize+ -- * Stacks+ , StackPtr(..)+ , RawStack(..)++ , subtractStackPtr+ , calculateStackLen+ , addStackPtr+ , rawStackSize+ , printStack+ -- * Bitmaps+ , PtrBitmap(..)+ , traversePtrBitmap+ -- * Constants+ , blockMask+ , mblockMask+ , mblockMaxSize+ , blockMaxSize+ , profiling+ , tablesNextToCode++ -- * Other utility+ , arrWordsBS+ , prettyPrint+ , printBS+ ) where++import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString as BS+import Data.Hashable+import Data.Word++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import System.Endian++import Numeric (showHex)+import Data.Coerce+import Data.Bits+import GHC.Stack+import Control.Applicative+import qualified Data.Array.Unboxed as A+import Control.Monad+import qualified Data.Foldable as F++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)+ deriving (Show, Binary) via ClosurePtr++-- 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+newtype ClosurePtr = UntaggedClosurePtr Word64+ deriving (Eq)+ deriving newtype (Hashable)++pattern ClosurePtr :: Word64 -> ClosurePtr+pattern ClosurePtr p <- UntaggedClosurePtr p++{-# COMPLETE ClosurePtr #-}++mkClosurePtr :: Word64 -> ClosurePtr+mkClosurePtr = untagClosurePtr . UntaggedClosurePtr++instance Binary ClosurePtr where+ put (ClosurePtr p) = putWord64be (toBE64 p)+ get = mkClosurePtr . fromBE64 <$> getWord64be++instance Ord ClosurePtr where+ (ClosurePtr x) `compare` (ClosurePtr y) = x `compare` y++instance Show ClosurePtr where+ show (ClosurePtr 0) = "null"+ show (ClosurePtr p) = "0x" ++ showHex p ""+++newtype StackPtr = StackPtr Word64+ deriving (Eq, Ord)+ deriving newtype (Hashable)+ deriving (Show, Binary) via ClosurePtr++newtype StringPtr = StringPtr Word64+ deriving Show via StackPtr+++subtractBlockPtr :: ClosurePtr -> BlockPtr -> Word64+subtractBlockPtr cp bp = subtractStackPtr (coerce cp) (coerce bp)++subtractStackPtr :: StackPtr -> ClosurePtr -> Word64+subtractStackPtr (StackPtr c) (ClosurePtr c2) =+ c - c2++addStackPtr :: StackPtr -> Word64 -> StackPtr+addStackPtr (StackPtr c) o = StackPtr (c + o)++rawClosureSize :: RawClosure -> Int+rawClosureSize (RawClosure s) = BS.length s++calculateStackLen :: Word32 -> Word64 -> ClosurePtr -> StackPtr -> Word64+calculateStackLen siz offset (ClosurePtr p) (StackPtr sp) =+ (p -- Pointer to start of StgStack closure+ + offset -- Offset to end of closure+ + (fromIntegral siz * 8) -- Stack_Size (in words)+ )+ - sp -- Minus current Sp++printBS :: BS.ByteString -> String+-- Not technically all ClosurePtr but good for the show instance+printBS bs = show (runGet (many (get @ClosurePtr)) (BSL.fromStrict bs))++printStack :: RawStack -> String+printStack (RawStack s) = printBS s++arrWordsBS :: [Word] -> BSL.ByteString+arrWordsBS = runPut . mapM_ putWordhost++-- | Check if the ClosurePtr is block allocated or not+-- TODO: MP: These numbers are hard-coded from what+-- mblock_address_space.begin and mblock_address_space.end were when+-- I inspected them in gdb. I don't know if they are always the same of+-- should be queried from the debuggee+heapAlloced :: ClosurePtr -> Bool+heapAlloced (ClosurePtr w) = (w >= 0x4200000000 && w <= 0x14200000000)++newtype RawInfoTable = RawInfoTable BS.ByteString+ deriving (Eq, Ord, Show)+ deriving newtype (Binary)++newtype RawClosure = RawClosure BS.ByteString+ deriving (Eq, Ord, Show)++getRawClosure :: Get RawClosure+getRawClosure = do+ len <- getWord32be+ RawClosure <$!> getByteString (fromIntegral len)++putRawClosure :: RawClosure -> Put+putRawClosure (RawClosure rc) = do+ let n = BS.length rc+ putWord32be (fromIntegral n)+ putByteString rc++instance Binary RawClosure where+ get = getRawClosure+ put = putRawClosure++newtype RawStack = RawStack BS.ByteString+ deriving (Eq, Ord, Show)++newtype RawPayload = RawPayload BS.ByteString+ deriving (Eq, Ord, Show)++rawStackSize :: RawStack -> Int+rawStackSize (RawStack bs) = BS.length bs+++newtype BlockPtr = BlockPtr Word64+ deriving (Eq, Ord)+ deriving newtype (Hashable)+ deriving (Binary, Show) via StackPtr++blockMBlock :: BlockPtr -> Word64+blockMBlock (BlockPtr p) = p .&. (complement mblockMask)++applyMBlockMask :: ClosurePtr -> BlockPtr+applyMBlockMask (ClosurePtr p) = BlockPtr (p .&. complement mblockMask)++applyBlockMask :: ClosurePtr -> BlockPtr+applyBlockMask (ClosurePtr p) = BlockPtr (p .&. complement blockMask)++getBlockOffset :: ClosurePtr -> Word64+getBlockOffset (ClosurePtr p) = p .&. blockMask++mblockMaxSize, blockMaxSize :: Word64+mblockMaxSize = mblockMask + 1+blockMaxSize = blockMask + 1++mblockMask :: Word64+mblockMask = 0b11111111111111111111 -- 20 bits++blockMask :: Word64+blockMask = 0b111111111111 -- 12 bits++isPinnedBlock :: RawBlock -> Bool+isPinnedBlock (RawBlock _ flags _) = (flags .&. 0b100) /= 0++isLargeBlock :: RawBlock -> Bool+isLargeBlock (RawBlock _ flags _) = (flags .&. 0b10) /= 0++data RawBlock = RawBlock BlockPtr Word16 BS.ByteString+ deriving (Show)++-- flags, Ptr, size then raw block+getBlock :: Get RawBlock+getBlock = do+ bflags <- getWord16le+ bptr <- get+ len <- getInt32be+ rb <- getByteString (fromIntegral len)+ return (RawBlock bptr bflags rb)++putBlock :: RawBlock -> Put+putBlock (RawBlock bptr bflags rb) = do+ putWord16le bflags+ put bptr+ putInt32be (fromIntegral $ BS.length rb)+ putByteString rb++instance Binary RawBlock where+ get = getBlock+ put = putBlock++rawBlockSize :: RawBlock -> Int+rawBlockSize (RawBlock _ _ bs) = BS.length bs++rawBlockAddr :: RawBlock -> BlockPtr+rawBlockAddr (RawBlock addr _ _) = addr++-- | Invariant: ClosurePtr is within the range of the block+-- The 'RawClosure' this returns is actually the tail of the whole block,+-- this is fine because the memory for each block is only allocated once+-- due to how BS.drop is implemented via pointer arithmetic.+extractFromBlock :: ClosurePtr+ -> RawBlock+ -> RawClosure+extractFromBlock cp (RawBlock bp _ b) =+-- Calling closureSize doesn't work as the info table addresses are bogus+-- clos_size_w <- withForeignPtr fp' (\p -> return $ closureSize (ptrToBox p))+-- let clos_size = clos_size_w * 8+ --traceShow (fp, offset, cp, bp,o, l)+ --traceShow ("FP", fp `plusForeignPtr` offset)+ RawClosure (BS.drop offset b)+ where+ offset = fromIntegral (subtractBlockPtr cp bp)++tAG_MASK :: Word64+tAG_MASK = 0b111++untagClosurePtr :: ClosurePtr -> ClosurePtr+untagClosurePtr (ClosurePtr w) = UntaggedClosurePtr (w .&. complement tAG_MASK)++getInfoTblPtr :: HasCallStack => RawClosure -> InfoTablePtr+getInfoTblPtr (RawClosure bs) = runGet (isolate 8 get) (BSL.fromStrict bs)++-- | A bitmap that records whether each field of a stack frame is a pointer.+newtype PtrBitmap = PtrBitmap (A.Array Int Bool) deriving (Show)++traversePtrBitmap :: Monad m => (Bool -> m a) -> PtrBitmap -> m [a]+traversePtrBitmap f (PtrBitmap arr) = mapM f (A.elems arr)++getPtrBitmap :: Get PtrBitmap+getPtrBitmap = do+ len <- getWord32be+ bits <- replicateM (fromIntegral len) getWord8+ let arr = A.listArray (0, fromIntegral len-1) (map (==1) bits)+ return $ PtrBitmap arr++putPtrBitmap :: PtrBitmap -> Put+putPtrBitmap (PtrBitmap pbm) = do+ let n = F.length pbm+ putWord32be (fromIntegral n)+ F.traverse_ (\b -> if b then putWord8 1 else putWord8 0) pbm++instance Binary PtrBitmap where+ get = getPtrBitmap+ put = putPtrBitmap