diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for ghc-debug-common +## 0.8.0.0 -- 2026-03-25 + +* No changes. + ## 0.7.0.0 -- 2025-05-20 * Fix decoding of BCO bitmap field (fixes a runtime crash in projects which use Template Haskell) 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.7.0.0 +version: 0.8.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 @@ -9,11 +9,11 @@ license: BSD-3-Clause license-file: LICENSE author: Ben Gamari, Matthew Pickering -maintainer: matthewtpickering@gmail.com +maintainer: hannes@well-typed.com copyright: (c) 2021 Ben Gamari, Matthew Pickering category: Development build-type: Simple -extra-source-files: CHANGELOG.md +extra-doc-files: CHANGELOG.md library exposed-modules: GHC.Debug.Decode, @@ -23,20 +23,21 @@ GHC.Debug.Types.Graph, GHC.Debug.Utils, GHC.Debug.Types.Ptr, - GHC.Debug.Types.Version + GHC.Debug.Types.Version, + GHC.Debug.Types.StackAnnotation, build-depends: base >=4.16 && < 5, - bytestring ^>=0.11, + bytestring >=0.11 && < 0.13, binary ^>=0.8, array ^>= 0.5, - directory ^>= 1.3 , + directory ^>= 1.3, filepath >= 1.4 && < 1.6, hashable >= 1.3 && < 1.6, cpu ^>= 0.1, - containers ^>= 0.6, - transformers >= 0.5 && < 0.7 , + containers >= 0.6 && <0.9, + transformers >= 0.5 && < 0.7, dom-lt ^>= 0.2, unordered-containers ^>= 0.2, - ghc-debug-convention == 0.7.0.0, + ghc-debug-convention == 0.8.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 @@ -27,7 +27,6 @@ import Data.Binary import Control.Monad import Data.Bits -import Data.Functor import GHC.Debug.Types (getCCS, getIndexTable) import qualified Data.Array as A import GHC.Stack @@ -98,11 +97,17 @@ getWord :: Get Word64 getWord = getWord64le +layoutCountsOrErr :: String -> StgInfoTable -> (Int, Int) +layoutCountsOrErr ctx info = + case layoutCounts info of + Just (p, np) -> (fromIntegral p, fromIntegral np) + Nothing -> + error (ctx ++ ": unexpected non-payload layout for closure type " ++ show (tipe info)) + 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)) + let (kptrs, kdat) = layoutCountsOrErr "decodeMutPrim" (decodedTable infot) pts <- replicateM kptrs getClosurePtr dat <- replicateM kdat (fromIntegral <$> getWord64le) return $ (MutPrimClosure infot prof pts dat) @@ -110,8 +115,7 @@ 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)) + let (kptrs, kdat) = layoutCountsOrErr "decodePrim" (decodedTable infot) pts <- replicateM kptrs getClosurePtr dat <- replicateM kdat (fromIntegral <$> getWord64le) return $ (PrimClosure infot prof pts dat) @@ -192,15 +196,19 @@ _smp_header <- getWord64le st_size <- getWord fun_closure <- getClosurePtr - k <- bytesRead - let sp = addStackPtr (StackPtr cp) (fromIntegral k) - clos_payload <- RawStack <$> getByteString (fromIntegral st_size) + -- The payload is a captured chunk of stack frames. The GC treats it the same + -- way as it would a stack (see scavenge_stack in the RTS), so we expose it + -- via StackCont with a synthetic stack pointer into the payload. + payloadOffset <- bytesRead + let payloadSp = addStackPtr (StackPtr cp) (fromIntegral payloadOffset) + payloadBytes = st_size * wordSizeBytes + rawPayload <- RawStack <$> getByteString (fromIntegral payloadBytes) return $ GHC.Debug.Types.Closures.APStackClosure infot prof (fromIntegral st_size) fun_closure - (StackCont sp clos_payload) + (StackCont payloadSp rawPayload) decodeStandardLayout :: Version -> Get () @@ -212,8 +220,9 @@ prof <- decodeClosureHeader ver -- For the THUNK header extra - pts <- replicateM (fromIntegral (ptrs (decodedTable infot))) getClosurePtr - cwords <- replicateM (fromIntegral (nptrs (decodedTable infot))) getWord + let (kptrs, kdat) = layoutCountsOrErr "decodeStandardLayout" (decodedTable infot) + pts <- replicateM kptrs getClosurePtr + cwords <- replicateM kdat getWord return $ k prof pts (map fromIntegral cwords) decodeArrWords :: Version -> (StgInfoTableWithPtr, b) @@ -228,6 +237,9 @@ ceilIntDiv :: Integral a => a -> a -> a ceilIntDiv a b = (a + b - 1) `div` b +wordSizeBytes :: Word64 +wordSizeBytes = 8 + tsoVersionChanged :: Version -> Bool tsoVersionChanged (Version majv minv _ _) = (majv > 905) || (majv == 905 && minv >= 20220925) @@ -347,6 +359,7 @@ MUT_VAR_CLEAN -> decodeMutVar ver i c MUT_VAR_DIRTY -> decodeMutVar ver i c WEAK -> decodeWeakClosure ver i c + COMPACT_NFDATA -> decodeCompactNFData 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 @@ -380,6 +393,20 @@ pure $ if w == 0 then Nothing else Just p pure $ WeakClosure infot profHeader cfinalizers key value finalizer mlink +decodeCompactNFData :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure +decodeCompactNFData ver (infot, _) (_, rc) = decodeFromBS rc $ do + profHeader <- decodeClosureHeader ver + totalWords <- getWord64le + _autoBlockWords <- getWord64le + _hpLim <- getWord64le + _hp <- getWord64le + _nursery <- getWord64le + _last <- getWord64le + _hash <- getWord64le + _result <- getClosurePtr + _link <- getWord64le + pure $ CompactNFDataClosure infot profHeader totalWords + decodeMVar :: Version -> (StgInfoTableWithPtr, RawInfoTable) -> (ClosurePtr, RawClosure) -> SizedClosure decodeMVar ver (infot, _) (_, rc) = decodeFromBS rc $ do profHeader <- decodeClosureHeader ver @@ -465,16 +492,24 @@ when (isProfiledRTS ver) $ do () <$ getWord64le () <$ getWord64le - ptrs <- getWord32le - nptrs <- getWord32le - tipe <- getWord32le - srtlen <- getWord32le + layoutLo <- getWord32le + layoutHi <- getWord32le + tipeWord <- getWord32le + srtWord <- getWord32le + let closureType = decodeInfoTableType tipeWord + layoutWord = (fromIntegral layoutHi `shiftL` 32) .|. fromIntegral layoutLo + layoutInfo + | usesSelectorLayout closureType = + StgLayoutSelector layoutLo + | isStackFrameType closureType = + StgLayoutBitmap layoutWord + | otherwise = + StgLayoutPayload (fromIntegral layoutLo) (fromIntegral layoutHi) return $ StgInfoTable - { ptrs = ptrs - , nptrs = nptrs - , tipe = decodeInfoTableType tipe - , srtlen = srtlen + { layout = layoutInfo + , tipe = closureType + , srtField = fromIntegral srtWord } decodeInfoTableType :: Word32 -> ClosureType @@ -544,6 +579,6 @@ 62 -> SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 63 -> COMPACT_NFDATA 64 -> CONTINUATION - 65 -> N_CLOSURE_TYPES + 65 -> ANN_FRAME + 66 -> N_CLOSURE_TYPES n -> error $ "Unexpected closure type: " ++ show n - diff --git a/src/GHC/Debug/Decode/Stack.hs b/src/GHC/Debug/Decode/Stack.hs --- a/src/GHC/Debug/Decode/Stack.hs +++ b/src/GHC/Debug/Decode/Stack.hs @@ -20,16 +20,23 @@ 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) + get_frames sp raw@(RawStack c) + -- It seems to be possible that the 'AP_STACK' closure is empty, + -- i.e., contains no stack frames. + -- It is currently unclear how this happens precisely, and normal 'STACK' closures + -- always contain at least one stack frame. + | BS.null c = pure [] + | otherwise = 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 [v] + | otherwise -> + (v:) <$> get_frames (sp + (fromIntegral offset)) (RawStack more) getFrame :: PtrBitmap -> StgInfoTableWithPtr 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 @@ -654,7 +654,7 @@ f 0x101 = pure $ Error AlreadyPaused f 0x102 = pure $ Error NotPaused f 0x103 = pure $ Error NoResume - f _ = fail "Unknown response code" + f c = error $ "Unknown response code: " ++ showAsHex c data Stream a r = Next !a (Stream a r) | End r 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 @@ -36,6 +36,12 @@ , allClosures -- * Info Table Representation , StgInfoTable(..) + , StgInfoTableLayout(..) + , layoutCounts + , isStackFrameType + , usesSelectorLayout + , StgInfoTableLayout(..) + , layoutCounts , ClosureType(..) , WhatNext(..) , WhyBlocked(..) @@ -74,6 +80,7 @@ import Prelude -- See note [Why do we import Prelude here?] +import Data.Bits import Data.Functor.Identity import Data.Int import Data.Word @@ -159,18 +166,51 @@ | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN | COMPACT_NFDATA | CONTINUATION + | ANN_FRAME | N_CLOSURE_TYPES deriving (Enum, Eq, Ord, Show, Generic, Read) +isStackFrameType :: ClosureType -> Bool +isStackFrameType ct = + case ct of + RET_BCO -> True + RET_SMALL -> True + RET_BIG -> True + RET_FUN -> True + UPDATE_FRAME -> True + CATCH_FRAME -> True + UNDERFLOW_FRAME -> True + STOP_FRAME -> True + ATOMICALLY_FRAME -> True + CATCH_RETRY_FRAME -> True + CATCH_STM_FRAME -> True + ANN_FRAME -> True + _ -> False + +usesSelectorLayout :: ClosureType -> Bool +usesSelectorLayout THUNK_SELECTOR = True +usesSelectorLayout _ = False + type HalfWord = Word32 -- TODO support 32 bit -data StgInfoTable = StgInfoTable { - ptrs :: HalfWord, - nptrs :: HalfWord, - tipe :: ClosureType, - srtlen :: HalfWord +data StgInfoTableLayout + = StgLayoutPayload { layoutPtrs :: !HalfWord + , layoutNPtrs :: !HalfWord + } + | StgLayoutBitmap !Word64 + | StgLayoutSelector !Word32 + deriving (Eq, Show, Generic) + +data StgInfoTable = StgInfoTable + { layout :: !StgInfoTableLayout + , tipe :: ClosureType + , srtField :: !HalfWord } deriving (Eq, Show, Generic) +layoutCounts :: StgInfoTable -> Maybe (HalfWord, HalfWord) +layoutCounts StgInfoTable{ layout = StgLayoutPayload p np } = Just (p, np) +layoutCounts _ = Nothing + data WhatNext = ThreadRunGHC | ThreadInterpret @@ -525,6 +565,11 @@ , dataArgs :: ![Word] } + | CompactNFDataClosure + { info :: !StgInfoTableWithPtr + , profHeader :: Maybe (ProfHeader ccs) + , totalWords :: !Word64 + } ----------------------------------------------------------- -- Anything else @@ -671,10 +716,9 @@ = (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) + case rest1 of + [] -> parseModOcc [] [] + (_:restTail) -> parseModOcc [] restTail -- 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 @@ -748,5 +792,7 @@ 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 + CompactNFDataClosure a1 ph b1 -> + CompactNFDataClosure a1 <$> (traverse . traverse) fccs ph <*> pure b1 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 diff --git a/src/GHC/Debug/Types/Graph.hs b/src/GHC/Debug/Types/Graph.hs --- a/src/GHC/Debug/Types/Graph.hs +++ b/src/GHC/Debug/Types/Graph.hs @@ -39,7 +39,10 @@ where import Data.Char -import Data.List (intercalate, foldl', sort, group, sortBy, groupBy) +import Data.List (intercalate, sort, sortBy, groupBy) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe ( catMaybes ) import Data.Function import qualified Data.HashMap.Strict as M @@ -52,9 +55,7 @@ import GHC.Debug.Types.Ptr import GHC.Debug.Types.Closures 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 @@ -253,7 +254,7 @@ -- | 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 $ +boundMultipleTimes (HeapGraph _rs m) roots = fmap NonEmpty.head $ NonEmpty.group $ sort $ roots ++ concatMap (catMaybes . allClosures . hgeClosure) (IM.elems m) -- Utilities @@ -351,6 +352,7 @@ TVarClosure {} -> "_tvar" -- TODO MutPrimClosure {} -> "_mutPrim" -- TODO PrimClosure {} -> "_prim" -- TODO + CompactNFDataClosure {} -> "_compactNFData" -- TODO UnsupportedClosure {info} -> (show info) @@ -381,8 +383,7 @@ graph = IM.foldlWithKey' collectNodes IM.empty hg collectNodes newMap k h = let bs = allClosures (hgeClosure h) - in foldl' (\m ma -> + in List.foldl' (\m ma -> case ma of Nothing -> m Just a -> IM.insertWith IS.union (closurePtrToInt a) (IS.singleton k) m) newMap bs - 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 @@ -11,7 +11,7 @@ -- | 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 +-- We have to send and receive 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 @@ -44,6 +44,7 @@ , extractFromBlock , blockMBlock , rawBlockSize + , rawBlockContains -- * Stacks , StackPtr(..) , RawStack(..) @@ -73,6 +74,7 @@ , arrWordsBS , prettyPrint , printBS + , prettyAddr ) where import qualified Data.ByteString.Lazy as BSL @@ -172,8 +174,10 @@ instance Show ClosurePtr where show (ClosurePtr 0) = "null" - show (ClosurePtr p) = "0x" ++ showHex p "" + show (ClosurePtr p) = prettyAddr p +prettyAddr :: Word64 -> String +prettyAddr addr = "0x" ++ showHex addr "" newtype StackPtr = StackPtr Word64 deriving (Eq, Ord) @@ -316,6 +320,13 @@ rawBlockAddr :: RawBlock -> BlockPtr rawBlockAddr (RawBlock addr _ _) = addr + + +-- | Test whether a @RawBlock@ contains the target address of a @ClosurePtr@. +rawBlockContains :: ClosurePtr -> RawBlock -> Bool +rawBlockContains (ClosurePtr cp) rb@(RawBlock (BlockPtr addr) _ _) = + cp >= addr + && cp < addr + fromIntegral (rawBlockSize rb) -- | Invariant: ClosurePtr is within the range of the block -- The 'RawClosure' this returns is actually the tail of the whole block, diff --git a/src/GHC/Debug/Types/StackAnnotation.hs b/src/GHC/Debug/Types/StackAnnotation.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Types/StackAnnotation.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module GHC.Debug.Types.StackAnnotation ( + StackAnnotation(..), + StackAnnotationWithPtrPayload, + isSomeStackAnnotationConstrDesc, + ) where + +import GHC.Debug.Types.Closures +import GHC.Debug.Types.Ptr +import qualified Data.List as List + +-- | 'StackAnnotation' is a closure pushed onto the Haskell callstack +-- via the primop 'annotateStack#'. +-- +-- In 'ghc-experimental:GHC.Stack.Annotation.Experimental', we define a type hierarchy +-- for types that can be pushed onto the stack via lifted versions of 'annotateStack#'. +-- The root of this hierarchy is 'SomeStackAnnotation' which this type is representation of. +data StackAnnotation constr dcd tcd cd = StackAnnotation + { stackAnno_constr :: constr + , stackAnno_typeableEv :: tcd + , stackAnno_displayStackAnnoEv :: dcd + , stackAnno_payload :: cd + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + +type StackAnnotationWithPtrPayload = StackAnnotation ConstrDesc ClosurePtr ClosurePtr ClosurePtr + +someStackAnnotationConstrDesc :: ConstrDesc +someStackAnnotationConstrDesc = + ConstrDesc + { pkg = "ghc-experimental" + , modl = "GHC.Stack.Annotation.Experimental" + , name = "SomeStackAnnotation" + } + +isSomeStackAnnotationConstrDesc :: ConstrDesc -> Bool +isSomeStackAnnotationConstrDesc desc = and + [ pkg someStackAnnotationConstrDesc `List.isPrefixOf` pkg desc + , modl desc == modl someStackAnnotationConstrDesc + , name desc == name someStackAnnotationConstrDesc + ] diff --git a/src/GHC/Debug/Utils.hs b/src/GHC/Debug/Utils.hs --- a/src/GHC/Debug/Utils.hs +++ b/src/GHC/Debug/Utils.hs @@ -3,8 +3,12 @@ import Data.Binary.Get import Data.ByteString.Lazy import GHC.Stack +import qualified Numeric runGet_ :: HasCallStack => Get a -> ByteString -> a runGet_ g b = case runGetOrFail g b of Left (_, _, err) -> error err Right (_, _, r) -> r + +showAsHex :: Integral a => a -> String +showAsHex n = "0x" ++ Numeric.showHex n ""