ghc-debug-common 0.7.0.0 → 0.8.0.0

raw patch · 10 files changed

+210/−58 lines, 10 filesdep ~bytestringdep ~containersdep ~ghc-debug-conventionnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring, containers, ghc-debug-convention

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• ghc-debug-common.cabal +10/−9
• src/GHC/Debug/Decode.hs +56/−21
• src/GHC/Debug/Decode/Stack.hs +17/−10
• src/GHC/Debug/Types.hs +1/−1
• src/GHC/Debug/Types/Closures.hs +55/−9
• src/GHC/Debug/Types/Graph.hs +7/−6
• src/GHC/Debug/Types/Ptr.hs +13/−2
• src/GHC/Debug/Types/StackAnnotation.hs +43/−0
• src/GHC/Debug/Utils.hs +4/−0

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

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

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

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

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

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

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

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

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

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