diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for ghc-debug-common +## 0.3.0.0 -- 2022-10-06 + +* Support changes to TSO decoding on GHC HEAD +* Improvements to ARR_WORDS decoding +* Improvements to WeakPtr decoding. + ## 0.2.1.0 -- 2022-05-06 * Internal refactoring to give better error message on decoding failure diff --git a/ghc-debug-common.cabal b/ghc-debug-common.cabal --- a/ghc-debug-common.cabal +++ b/ghc-debug-common.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-debug-common -version: 0.2.1.0 +version: 0.3.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 @@ -23,7 +23,8 @@ GHC.Debug.Types.Closures, GHC.Debug.Types.Graph, GHC.Debug.Utils, - GHC.Debug.Types.Ptr + GHC.Debug.Types.Ptr, + GHC.Debug.Types.Version build-depends: base >=4.16 && < 5, bytestring ^>=0.11, binary ^>=0.8, @@ -37,7 +38,7 @@ transformers ^>= 0.5, dom-lt ^>= 0.2, unordered-containers ^>= 0.2, - ghc-debug-convention == 0.2.0.0, + ghc-debug-convention == 0.3.0.0, deepseq ^>= 1.4 hs-source-dirs: src diff --git a/src/GHC/Debug/Decode.hs b/src/GHC/Debug/Decode.hs --- a/src/GHC/Debug/Decode.hs +++ b/src/GHC/Debug/Decode.hs @@ -5,6 +5,8 @@ {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Low-level functions for decoding a closure representation from the raw -- bytes module GHC.Debug.Decode ( decodeClosure @@ -27,6 +29,7 @@ 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) @@ -36,6 +39,7 @@ import Control.Monad import Data.Void import Control.DeepSeq +import GHC.Exts.Heap.FFIClosures import qualified Data.ByteString as B @@ -216,18 +220,73 @@ cwords <- replicateM (fromIntegral (nptrs (decodedTable infot))) getWord return $ k pts (map fromIntegral cwords) -decodeClosure :: (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure -decodeClosure i@(itb, _) c +decodeArrWords :: (StgInfoTableWithPtr, b) + -> (a, RawClosure) -> DebugClosureWithExtra Size pap string s b1 +decodeArrWords (infot, _) (_, rc) = decodeFromBS rc $ do + _itbl <- skipClosureHeader + bytes <- getWord64le + payload <- replicateM (ceiling (fromIntegral bytes / 8)) getWord + return $ GHC.Debug.Types.Closures.ArrWordsClosure infot (fromIntegral bytes) (map fromIntegral payload) + +tsoVersionChanged :: Version +tsoVersionChanged = Version 905 20220925 + +decodeTSO :: Version + -> (StgInfoTableWithPtr, RawInfoTable) + -> (a, RawClosure) + -> SizedClosure +decodeTSO ver it@(infot, _) c@(_, rc) = decodeFromBS rc $ do + _itbl <- skipClosureHeader + link <- getClosurePtr + global_link <- getClosurePtr + tsoStack <- getClosurePtr + what_next <- parseWhatNext <$> getWord16le + why_blocked <- parseWhyBlocked <$> getWord16le + flags <- parseTsoFlags <$> getWord32le + _block_info <- getClosurePtr + threadId <- getWord64le + saved_errno <- getWord32le + dirty <- getWord32le + + _bound <- getClosurePtr + _cap <- getClosurePtr + trec <- getClosurePtr + threadLabel <- + if ver >= tsoVersionChanged + then do + thread_label <- getClosurePtr + return $ if thread_label == mkClosurePtr 0 then Nothing else Just thread_label + else return Nothing + blocked_exceptions <- getClosurePtr + bq <- getClosurePtr + alloc_limit <- getInt64le + tot_stack_size <- getWord32le + let res :: Closure = (GHC.Debug.Types.Closures.TSOClosure + { info = infot + , _link = link + , prof = Nothing + , .. }) + return res + + + + + +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 @@ -242,7 +301,14 @@ | (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 +decodeClosure _ rit rc = + decodeWithLibrary rit rc + + +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) diff --git a/src/GHC/Debug/Decode/Convert.hs b/src/GHC/Debug/Decode/Convert.hs --- a/src/GHC/Debug/Decode/Convert.hs +++ b/src/GHC/Debug/Decode/Convert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- Convert a GenClosure to a DebugClosure -} module GHC.Debug.Decode.Convert where @@ -27,7 +28,8 @@ GHC.MVarClosure _ a2 a3 a4 -> MVarClosure itb a2 a3 a4 GHC.MutVarClosure _ a2 -> MutVarClosure itb a2 GHC.BlockingQueueClosure _ a2 a3 a4 a5 -> BlockingQueueClosure itb a2 a3 a4 a5 - GHC.TSOClosure _ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 -> TSOClosure itb a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 + -- GHC.TSOClosure _ a2 a3 a4 a5 a6 a7 _ a8 a9 a10 a11 a12 a13 a14 a15 a16 -> TSOClosure itb a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 + GHC.TSOClosure _ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 -> TSOClosure itb a2 a3 a4 a5 a6 a7 Nothing a8 a9 a10 a11 a12 a13 a14 a15 a16 -- GHC.StackClosure _ a2 a3 a4 a5 -> StackClosure itb a2 a3 a4 (a2, (StackPtr a5)) {- GHC.IntClosure a1 a2 -> IntClosure a1 a2 @@ -40,10 +42,14 @@ -} GHC.OtherClosure _ a2 a3 -> OtherClosure itb a2 a3 GHC.WeakClosure _ a2 a3 a4 a5 a6 -> +#if __GLASGOW_HASKELL__ >= 905 + 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) diff --git a/src/GHC/Debug/Types.hs b/src/GHC/Debug/Types.hs --- a/src/GHC/Debug/Types.hs +++ b/src/GHC/Debug/Types.hs @@ -22,6 +22,7 @@ , CommandId(..) , SourceInformation(..) , ClosureType(..) + , Version(..) -- * Serialisation functions , getIPE @@ -47,6 +48,7 @@ import GHC.Debug.Types.Closures as T import GHC.Debug.Types.Ptr as T +import GHC.Debug.Types.Version import GHC.Debug.Utils import GHC.Exts.Heap.ClosureTypes import GHC.Debug.Decode @@ -71,7 +73,7 @@ -- | A request sent from the debugger to the debuggee parametrized on the result type. data Request a where -- | Request protocol version - RequestVersion :: Request Word32 + RequestVersion :: Request Version -- | Pause the debuggee. RequestPause :: ForkOrPause -> Request () -- | Resume the debuggee. @@ -333,7 +335,7 @@ getResponse :: Request a -> Get a -getResponse RequestVersion = getWord32be +getResponse RequestVersion = Version <$> get <*> get getResponse RequestPause {} = get getResponse RequestResume = get getResponse RequestRoots = many get diff --git a/src/GHC/Debug/Types/Closures.hs b/src/GHC/Debug/Types/Closures.hs --- a/src/GHC/Debug/Types/Closures.hs +++ b/src/GHC/Debug/Types/Closures.hs @@ -91,7 +91,7 @@ type ConstrDescCont = InfoTablePtr -- | Information needed to decode a PAP payload -data PayloadCont = PayloadCont ClosurePtr [Word64] deriving Show +data PayloadCont = PayloadCont ClosurePtr [Word64] deriving (Show, Eq) type DebugClosureWithSize = DebugClosureWithExtra Size @@ -297,6 +297,7 @@ , trec :: !b , blocked_exceptions :: !b , bq :: !b + , threadLabel :: !(Maybe b) -- values , what_next :: GHC.WhatNext , why_blocked :: GHC.WhyBlocked @@ -377,7 +378,7 @@ -- | Information needed to decode a set of stack frames data StackCont = StackCont StackPtr -- Address of start of frames RawStack -- The raw frames - deriving Show + deriving (Show, Eq, Ord) type StackFrames = GenStackFrames ClosurePtr newtype GenStackFrames b = GenStackFrames { getFrames :: [DebugStackFrame b] } @@ -473,8 +474,8 @@ 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 + 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 diff --git a/src/GHC/Debug/Types/Ptr.hs b/src/GHC/Debug/Types/Ptr.hs --- a/src/GHC/Debug/Types/Ptr.hs +++ b/src/GHC/Debug/Types/Ptr.hs @@ -22,6 +22,7 @@ -- * Closures , ClosurePtr(..,ClosurePtr) , mkClosurePtr + , readClosurePtr , RawClosure(..) , rawClosureSize , getInfoTblPtr @@ -79,7 +80,7 @@ import Data.Binary.Put import System.Endian -import Numeric (showHex) +import Numeric (showHex, readHex) import Data.Coerce import Data.Bits import GHC.Stack @@ -118,6 +119,12 @@ mkClosurePtr :: Word64 -> ClosurePtr mkClosurePtr = untagClosurePtr . UntaggedClosurePtr + +readClosurePtr :: String -> Maybe ClosurePtr +readClosurePtr ('0':'x':s) = case readHex s of + [(res, "")] -> Just (mkClosurePtr res) + _ -> Nothing +readClosurePtr _ = Nothing instance Binary ClosurePtr where put (ClosurePtr p) = putWord64be (toBE64 p) diff --git a/src/GHC/Debug/Types/Version.hs b/src/GHC/Debug/Types/Version.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Types/Version.hs @@ -0,0 +1,7 @@ +module GHC.Debug.Types.Version where + +import Data.Word + +data Version = Version { v_major :: Word32 + , v_patch :: Word32 + } deriving (Show, Ord, Eq)