ghc-debug-client 0.5.0.0 → 0.6.0.0

raw patch · 21 files changed

+714/−223 lines, 21 filesdep +vectordep ~basedep ~bitwisedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: vector

Dependency ranges changed: base, bitwise, bytestring, contra-tracer, filepath, ghc-debug-common, ghc-debug-convention, ghc-prim, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• ghc-debug-client.cabal +13/−10
• src/GHC/Debug/Client.hs +9/−2
• src/GHC/Debug/Client/Monad/Simple.hs +1/−3
• src/GHC/Debug/Client/Query.hs +64/−10
• src/GHC/Debug/Client/RequestCache.hs +28/−5
• src/GHC/Debug/Client/Search.hs +1/−1
• src/GHC/Debug/CostCentres.hs +129/−0
• src/GHC/Debug/Count.hs +11/−18
• src/GHC/Debug/Fragmentation.hs +5/−5
• src/GHC/Debug/GML.hs +1/−1
• src/GHC/Debug/ObjectEquiv.hs +4/−12
• src/GHC/Debug/ParTrace.hs +63/−20
• src/GHC/Debug/Profile.hs +142/−39
• src/GHC/Debug/Profile/Types.hs +22/−6
• src/GHC/Debug/Retainers.hs +130/−48
• src/GHC/Debug/Snapshot.hs +6/−3
• src/GHC/Debug/Strings.hs +25/−30
• src/GHC/Debug/Thunks.hs +29/−0
• src/GHC/Debug/Trace.hs +19/−5
• src/GHC/Debug/TypePointsFrom.hs +6/−5

@@ -1,5 +1,11 @@ # Revision history for ghc-debug-client +## 0.6.0.0 -- 2024-04-10++* Properly handle exceptions in parralel traversals+* Fix snapshotting when extra blocks are requested by RequestBlock+* Support for profiling RTS+ ## 0.5.0.0 -- 2023-06-06  * Remove eventlog2html dependency and hence `profile` function. These can be

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                ghc-debug-client-version:             0.5.0.0+version:             0.6.0.0 synopsis:            Useful functions for writing heap analysis tools which use                      ghc-debug. description:         Useful functions for writing heap analysis tools which use@@ -17,6 +17,7 @@  library   exposed-modules:     GHC.Debug.Client,+                       GHC.Debug.CostCentres,                        GHC.Debug.Retainers,                        GHC.Debug.GML,                        GHC.Debug.Fragmentation,@@ -31,6 +32,7 @@                        GHC.Debug.TypePointsFrom,                        GHC.Debug.Snapshot,                        GHC.Debug.Dominators,+                       GHC.Debug.Thunks,                        GHC.Debug.Client.Query,                        GHC.Debug.Client.Monad,                        GHC.Debug.Client.BlockCache,@@ -38,17 +40,17 @@                        GHC.Debug.Client.Monad.Class,                        GHC.Debug.Client.Monad.Simple -  build-depends:       base >=4.16 && < 4.19,+  build-depends:       base >=4.16 && < 4.20,                        network >= 2.6 ,                        containers ^>= 0.6,                        unordered-containers ^>= 0.2.13,-                       ghc-debug-common == 0.5.0.0,-                       ghc-debug-convention == 0.5.0.0,-                       text >= 1.2.4 && < 3,+                       ghc-debug-common == 0.6.0.0,+                       ghc-debug-convention == 0.6.0.0,+                       text >= 2.1 && < 3,                        process ^>= 1.6,-                       filepath ^>= 1.4,+                       filepath >= 1.4 && < 1.6,                        directory ^>= 1.3,-                       bitwise ^>= 1.0,+                       bitwise >= 1.0,                        hashable >= 1.3 && < 1.5,                        mtl >= 2.2 && <2.4,                        binary ^>= 0.8,@@ -57,10 +59,11 @@                        async ^>= 2.2,                        monoidal-containers >= 0.6,                        language-dot ^>= 0.1,-                       ghc-prim >= 0.8 && <0.11,+                       ghc-prim >= 0.8 && <0.12,                        stm ^>= 2.5,-                       bytestring,-                       contra-tracer+                       vector ^>= 0.13.1 ,+                       bytestring >= 0.11,+                       contra-tracer ^>= 0.2.0    hs-source-dirs:      src   default-language:    Haskell2010

@@ -51,14 +51,18 @@   , dereferenceClosure   , dereferenceToClosurePtr   , addConstrDesc+  , requestCCSMain   , dereferenceClosures   , dereferenceStack   , dereferencePapPayload   , dereferenceConDesc   , dereferenceInfoTable+  , dereferenceIndexTable   , dereferenceSRT+  , dereferenceCCS+  , dereferenceCC -  , Quintraversable(..)+  , Hextraversable(..)    -- * Building a Heap Graph   , buildHeapGraph@@ -85,6 +89,9 @@   , StackPtr   , ClosurePtr   , InfoTablePtr+  , CCPtr+  , CCSPtr+  , IndexTablePtr   , HG.StackHI   , HG.PapHI   , HG.HeapGraphIndex@@ -103,7 +110,7 @@ derefFuncM :: HG.DerefFunction DebugM Size derefFuncM c = do   c' <- dereferenceClosure c-  quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure c'+  hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure c'  -- | Build a heap graph starting from the given root. The first argument -- controls how many levels to recurse. You nearly always want to set this

@@ -123,9 +123,7 @@  initBlockCacheFromReqCache :: RequestCache -> BlockCache initBlockCacheFromReqCache new_req_cache  =-  case lookupReq RequestAllBlocks new_req_cache of-        Just bs -> addBlocks bs emptyBlockCache-        Nothing -> emptyBlockCache+  addBlocks (lookupBlocks new_req_cache) emptyBlockCache   

@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingVia #-} module GHC.Debug.Client.Query   ( -- * Pause/Resume@@ -18,6 +19,7 @@   , allBlocks   , getSourceInfo   , savedObjects+  , requestCCSMain   , version    -- * Dereferencing functions@@ -32,6 +34,11 @@   , dereferenceConDesc   , dereferenceInfoTable   , dereferenceSRT+  , dereferenceCCS+  , dereferenceCCSDirect+  , dereferenceCC+  , dereferenceIndexTable+  , dereferenceIndexTableDirect   ) where  import           Control.Exception@@ -71,8 +78,10 @@ lookupInfoTable :: RawClosure -> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure) lookupInfoTable rc = do     let ptr = getInfoTblPtr rc-    (itbl, rit) <- request (RequestInfoTable ptr)-    return (itbl,rit, rc)+    rit <- request (RequestInfoTable ptr)+    ver <- version+    let !it = D.decodeInfoTable ver rit+    return (StgInfoTableWithPtr ptr it,rit, rc)  pauseThen :: Debuggee -> DebugM b -> IO b pauseThen e d =@@ -84,12 +93,12 @@  addConstrDesc :: SizedClosure -> DebugM SizedClosureC addConstrDesc c =-  quintraverse pure pure dereferenceConDesc pure pure c+  hextraverse pure pure pure dereferenceConDesc pure pure c  -- Derefence other structures so we just have 'ClosurePtr' at leaves. dereferenceToClosurePtr :: SizedClosure -> DebugM SizedClosureP dereferenceToClosurePtr c = do-  quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc pure pure c+  hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc pure pure c   -- | Decode a closure corresponding to the given 'ClosurePtr'@@ -100,14 +109,15 @@     raw_c <- request (RequestClosure c)     let it = getInfoTblPtr raw_c     raw_it <- request (RequestInfoTable it)-    decodeClosure raw_it (c, raw_c)+    decodeClosure (it, raw_it) (c, raw_c) -decodeClosure :: (StgInfoTableWithPtr, RawInfoTable)+decodeClosure :: (InfoTablePtr, RawInfoTable)               -> (ClosurePtr, RawClosure)               -> DebugM SizedClosure-decodeClosure it c = do+decodeClosure (itp, raw_it) c = do   ver <- version-  return $ D.decodeClosure ver it c+  let !it = D.decodeInfoTable ver raw_it+  return $ D.decodeClosure ver (StgInfoTableWithPtr itp it, raw_it) c  dereferenceClosures  :: [ClosurePtr] -> DebugM [SizedClosure] dereferenceClosures cs = mapM dereferenceClosure cs@@ -175,7 +185,7 @@         else do           let it = getInfoTblPtr rc           st_it <- request (RequestInfoTable it)-          decodeClosure st_it (cp, rc)+          decodeClosure (it, st_it) (cp, rc)  -- | Fetch all the blocks from the debuggee and add them to the block cache precacheBlocks :: DebugM [RawBlock]@@ -198,12 +208,56 @@ savedObjects :: DebugM [ClosurePtr] savedObjects = request RequestSavedObjects +requestCCSMain :: DebugM CCSPtr+requestCCSMain = request RequestCCSMainPtr+ -- | Query the debuggee for the protocol version version :: DebugM Version version = request RequestVersion  dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable-dereferenceInfoTable it = decodedTable . fst <$> request (RequestInfoTable it)+dereferenceInfoTable it = do+  rit <- request (RequestInfoTable it)+  ver <- version+  let !decoded_it = D.decodeInfoTable ver rit+  pure decoded_it  dereferenceSRT :: InfoTablePtr -> DebugM SrtPayload dereferenceSRT it = GenSrtPayload <$> request (RequestSRT it)++dereferenceCCSDirect :: CCSPtr -> DebugM CCSPayload+dereferenceCCSDirect it = request (RequestCCS it)++dereferenceCCS :: CCSPtr -> DebugM CCSPayload+dereferenceCCS ccsPtr@(CCSPtr w)+  | not (heapAlloced $ mkClosurePtr w) = dereferenceCCSDirect ccsPtr+  | otherwise = do+      rc <- requestBlock (LookupClosure $ mkClosurePtr w)+      if rawClosureSize rc < 8+        then do+          res <- dereferenceCCSDirect ccsPtr+          traceShowM ("Warning!!: block decoding failed, report this as a bug:" ++ show (ccsPtr, res))+          return res+        else do+          v <- version+          pure $ D.decodeCCS v rc++dereferenceCC :: CCPtr -> DebugM CCPayload+dereferenceCC it = request (RequestCC it)++dereferenceIndexTableDirect :: IndexTablePtr -> DebugM IndexTable+dereferenceIndexTableDirect it = request (RequestIndexTable it)++dereferenceIndexTable :: IndexTablePtr -> DebugM IndexTable+dereferenceIndexTable idxTablePtr@(IndexTablePtr w)+  | not (heapAlloced $ mkClosurePtr w) = dereferenceIndexTableDirect idxTablePtr+  | otherwise = do+      rc <- requestBlock (LookupClosure $ mkClosurePtr w)+      if rawClosureSize rc < 8+        then do+          res <- dereferenceIndexTableDirect idxTablePtr+          traceShowM ("Warning!!: block decoding failed, report this as a bug:" ++ show (idxTablePtr, res))+          return res+        else do+          v <- version+          pure $ D.decodeIndexTable v rc

@@ -4,6 +4,7 @@ module GHC.Debug.Client.RequestCache(RequestCache                                     , cacheReq                                     , lookupReq+                                    , lookupBlocks                                     , emptyRequestCache                                     , clearMovableRequests                                     , putCache@@ -33,6 +34,21 @@     coerceResult :: AnyResp -> resp     coerceResult (AnyResp a _) = unsafeCoerce a +lookupBlocks :: RequestCache -> [RawBlock]+lookupBlocks c@(RequestCache rc) =+  let all_blocks = case lookupReq RequestAllBlocks c of+                        Just bs -> bs+                        Nothing -> []++      get_block :: AnyReq -> AnyResp -> [RawBlock] -> [RawBlock]+      get_block (AnyReq (RequestBlock {})) (AnyResp resp _) bs = unsafeCoerce resp : bs+      get_block _ _ bs = bs++      individual_blocks = HM.foldrWithKey get_block [] rc++  in (all_blocks ++ individual_blocks)++ emptyRequestCache :: RequestCache emptyRequestCache = RequestCache HM.empty @@ -41,13 +57,12 @@ -- amount of input.  getResponseBinary :: Request a -> Get a-getResponseBinary RequestVersion       = Version <$> get <*> get+getResponseBinary RequestVersion       = Version <$> get <*> get <*> getProfilingMode <*> get getResponseBinary (RequestPause {})    = get getResponseBinary RequestResume        = get getResponseBinary RequestRoots         = get getResponseBinary (RequestClosure {}) = get-getResponseBinary (RequestInfoTable itps) =-      (\(it, r) -> (StgInfoTableWithPtr itps it, r)) <$> getInfoTable+getResponseBinary (RequestInfoTable{}) = getInfoTable getResponseBinary (RequestSRT {}) = get getResponseBinary (RequestStackBitmap {}) = get getResponseBinary (RequestFunBitmap {}) = get@@ -57,14 +72,18 @@ getResponseBinary (RequestSourceInfo _c) = getIPE getResponseBinary RequestAllBlocks = get getResponseBinary RequestBlock {}  = get+getResponseBinary RequestCCS {}  = getCCS+getResponseBinary RequestCC {}  = getCC+getResponseBinary RequestIndexTable {}  = getIndexTable+getResponseBinary RequestCCSMainPtr {}  = getCCSMainPtr  putResponseBinary :: Request a -> a -> Put-putResponseBinary RequestVersion (Version w1 w2) = put w1 >> put w2+putResponseBinary RequestVersion (Version w1 w2 vprof tntc) = put w1 >> put w2 >> putProfilingMode vprof >> put tntc putResponseBinary (RequestPause {}) w  = put w putResponseBinary RequestResume w      = put w putResponseBinary RequestRoots  rs     = put rs putResponseBinary (RequestClosure {}) rcs = put rcs-putResponseBinary (RequestInfoTable {}) (_, r) = putInfoTable r+putResponseBinary (RequestInfoTable {}) r = putInfoTable r putResponseBinary (RequestSRT {}) rcs = put rcs putResponseBinary (RequestStackBitmap {}) pbm = put pbm putResponseBinary (RequestFunBitmap {}) pbm = put pbm@@ -74,6 +93,10 @@ putResponseBinary (RequestSourceInfo _c) ipe = putIPE ipe putResponseBinary RequestAllBlocks rs = put rs putResponseBinary RequestBlock {} r = put r+putResponseBinary RequestCCS{} r = putCCS r+putResponseBinary RequestCC{} r = putCC r+putResponseBinary RequestIndexTable{} r = putIndexTable r+putResponseBinary RequestCCSMainPtr{} r = putCCSMainPtr r  putConstrDescCache :: ConstrDesc -> Put putConstrDescCache (ConstrDesc a b c) = do

@@ -16,7 +16,7 @@     where       predicate h = checkConstrTable (hgeClosure h) -      checkConstrTable (ConstrClosure _ _ _ (ConstrDesc _ _ n)) = n == con_name+      checkConstrTable (ConstrClosure _ _ _ _ (ConstrDesc _ _ n)) = n == con_name       checkConstrTable _ = False  findWithInfoTable :: InfoTablePtr -> HeapGraph a -> [HeapGraphEntry a]

@@ -0,0 +1,129 @@+{-# LANGUAGE BangPatterns #-}+module GHC.Debug.CostCentres+  ( findAllChildrenOfCC+  , findExactlyByCC+  , findAllCCSPayloads+  , traverseCCSPayloads+  -- * Helper functions for working with `IndexTable`'s+  , flattenIndexTable+  , traverseIndexTable+  , foldIndexTable+  -- * Efficient representation of CCSPtr sets+  , CCSSet(..)+  , memberCCSSet+  ) where++import qualified Data.Set as Set+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import GHC.Debug.Client+import GHC.Debug.Types.Ptr (CCSPtr(..))+import Data.Coerce (coerce)++newtype CCSSet = CCSSet IntSet++memberCCSSet :: CCSPtr -> CCSSet -> Bool+memberCCSSet (CCSPtr k) set = IntSet.member (fromIntegral k) (coerce set)++-- | Find all Cost Centre Stacks that reference precisely the cost centre with the given id.+findExactlyByCC :: (CCPayload -> Bool) -> DebugM (Set.Set CCSPtr)+findExactlyByCC isRelevantCC = do+  ccsMain <- requestCCSMain+  collectNode Set.empty ccsMain+  where+    collectNode :: Set.Set CCSPtr -> CCSPtr -> DebugM (Set.Set CCSPtr)+    collectNode !seen !ccsPtr = do+      ccsPl <- dereferenceCCS ccsPtr+      ccPl <- dereferenceCC (ccsCc ccsPl)+      let newSeen = if isRelevantCC ccPl+            then ccsPtr `Set.insert` seen+            else seen+      foldIndexTable (\_ ptr backEdge !seen' -> do+        if backEdge+          then pure seen'+          else collectNode seen' ptr)+        newSeen+        (ccsIndexTable ccsPl)++-- | Find all cost centre stack parts that are transitively children of the cost+-- centre with the given id.+findAllChildrenOfCC :: (CCPayload -> Bool) -> DebugM (Set.Set CCSPtr)+findAllChildrenOfCC isRelevantCC = do+  ccsMain <- requestCCSMain+  findCostCentre Set.empty ccsMain+  where+    findCostCentre :: Set.Set CCSPtr -> CCSPtr -> DebugM (Set.Set CCSPtr)+    findCostCentre !seen !ccsPtr = do+      ccsPl <- dereferenceCCS ccsPtr+      ccPl <- dereferenceCC (ccsCc ccsPl)+      if isRelevantCC ccPl+        then collectNodes seen ccsPtr+        else+          foldIndexTable  (\_ ptr backEdge !seen' -> do+            if backEdge+              then pure seen'+              else findCostCentre seen' ptr)+            seen+            (ccsIndexTable ccsPl)++    collectNodes :: Set.Set CCSPtr -> CCSPtr -> DebugM (Set.Set CCSPtr)+    collectNodes !seen !ccsPtr = do+      ccsPl <- dereferenceCCS ccsPtr+      foldIndexTable  (\_ ptr backEdge !seen' -> do+        let seen'' = ptr `Set.insert` seen'+        if backEdge+          then pure seen''+          else collectNodes seen'' ptr)+        (ccsPtr `Set.insert` seen)+        (ccsIndexTable ccsPl)++findAllCCSPayloads :: DebugM CCSSet+findAllCCSPayloads = do+  ccsMain <- requestCCSMain+  CCSSet <$> collectNodes IntSet.empty ccsMain+  where+    collectNodes :: IntSet.IntSet -> CCSPtr -> DebugM (IntSet.IntSet)+    collectNodes !seen ccsPtr@(CCSPtr w_) = do+      ccsPl <- dereferenceCCS ccsPtr+      foldIndexTable  (\_ ptr@(CCSPtr w) backEdge !seen' -> do+        let seen'' = fromIntegral w `IntSet.insert` seen'+        if backEdge+          then pure seen''+          else collectNodes seen'' ptr)+        (fromIntegral w_ `IntSet.insert` seen)+        (ccsIndexTable ccsPl)++traverseCCSPayloads :: DebugM ()+traverseCCSPayloads = do+  ccsMain <- requestCCSMain+  collectNodes ccsMain+  where+    collectNodes :: CCSPtr -> DebugM ()+    collectNodes ccsPtr = do+      ccsPl <- dereferenceCCS ccsPtr+      foldIndexTable  (\_ ptr backEdge () -> do+        if backEdge+          then pure ()+          else collectNodes ptr)+        ()+        (ccsIndexTable ccsPl)++traverseIndexTable :: Maybe IndexTablePtr -> (CCPtr -> CCSPtr -> Bool -> DebugM a) -> DebugM [a]+traverseIndexTable Nothing _ = pure []+traverseIndexTable (Just ptr) f = do+  idxTable <- dereferenceIndexTable ptr+  x <- f (itCostCentre idxTable) (itCostCentreStack idxTable) (itBackEdge idxTable)+  rest <- traverseIndexTable (itNext idxTable) f+  pure $ x:rest++foldIndexTable :: (CCPtr -> CCSPtr -> Bool -> a -> DebugM a) -> a -> Maybe IndexTablePtr -> DebugM a+foldIndexTable _f acc Nothing = pure acc+foldIndexTable f acc (Just ptr) = do+  idxTable <- dereferenceIndexTable ptr+  acc' <- f (itCostCentre idxTable) (itCostCentreStack idxTable) (itBackEdge idxTable) acc+  foldIndexTable f acc' (itNext idxTable)++-- | Flatten an optional index table pointer into a list of CCS Payloads.+flattenIndexTable :: Maybe IndexTablePtr -> DebugM [CCSPayload]+flattenIndexTable root = traverseIndexTable root (\_ ccsPtr _ -> dereferenceCCS ccsPtr)

@@ -12,36 +12,29 @@ parCount :: [ClosurePtr] -> DebugM CensusStats parCount = traceParFromM funcs . map (ClosurePtrWithInfo ())   where-    nop = const (return ())-    funcs = TraceFunctionsIO nop nop nop clos (const (const (return mempty))) nop+    nop = const (return mempty)+    nop2 = const (return mempty)+    funcs = TraceFunctionsIO nop nop nop clos (const (const (return mempty))) nop2 nop (const nop2)      clos :: ClosurePtr -> SizedClosure -> ()               -> DebugM ((), CensusStats, DebugM () -> DebugM ())-    clos _cp sc _ = do-      return ((), mkCS (dcSize sc), id)+    clos cp sc _ = do+      return ((), mkCS cp (dcSize sc), id)  -- | Simple statistics about a heap, total objects, size and maximum object -- size count :: [ClosurePtr] -> DebugM CensusStats-count cps = snd <$> runStateT (traceFromM funcs cps) (CS 0 0 0)+count cps = snd <$> runStateT (traceFromM funcs cps) mempty   where-    funcs = TraceFunctions {-               papTrace = const (return ())-              , srtTrace = const (return ())-              , stackTrace = const (return ())-              , closTrace = closAccum-              , visitedVal = const (return ())-              , conDescTrace = const (return ())--            }+    funcs = justClosures closAccum      closAccum  :: ClosurePtr                -> SizedClosure                ->  (StateT CensusStats DebugM) ()                ->  (StateT CensusStats DebugM) ()-    closAccum _cp s k = do-      modify' (go s)+    closAccum cp s k = do+      modify' (go cp s)       k -    go :: SizedClosure -> CensusStats -> CensusStats-    go sc cs = mkCS (dcSize sc) <> cs+    go :: ClosurePtr -> SizedClosure -> CensusStats -> CensusStats+    go cp sc cs = mkCS cp (dcSize sc) <> cs

@@ -47,7 +47,7 @@     go cp d =       let s :: Size           s = dcSize d-          v =  mkCS s+          v =  mkCS cp s            k :: BlockPtr           k = applyMBlockMask cp@@ -63,7 +63,7 @@     go cp d =       let s :: Size           s = dcSize d-          v =  mkCS s+          v =  mkCS cp s            k = applyBlockMask cp       in if heapAlloced cp@@ -86,7 +86,7 @@           -> DebugM (Maybe (BlockPtr, PinnedCensusStats))     go cp d =       let v :: CensusStats-          v = mkCS (dcSize d)+          v = mkCS cp (dcSize d)            bp = applyBlockMask cp @@ -102,7 +102,7 @@ findBadPtrs :: Map.Map k PinnedCensusStats             -> [((Count, [ClosurePtr]), String)] findBadPtrs mb_census  =-      let fragged_blocks = Map.filter (\(PinnedCensusStats (CS _ (Size s) _, _)) -> fromIntegral s / fromIntegral blockMaxSize <= (0.1 :: Double))  mb_census+      let fragged_blocks = Map.filter (\(PinnedCensusStats (CS _ (Size s) _ _, _)) -> fromIntegral s / fromIntegral blockMaxSize <= (0.1 :: Double))  mb_census           all_arr_words :: [(String, (Count, [ClosurePtr]))]           all_arr_words = concatMap (\(PinnedCensusStats (_, i)) -> map (\(c,d) -> (displayArrWords d, (Count 1, [c]))) i) (Map.elems fragged_blocks)           swap (a, b) = (b, a)@@ -125,7 +125,7 @@ histogram maxSize m =   mapM_ (putStrLn . displayLine) (bin 0 (map calcPercentage (sortBy (comparing cssize) m )))   where-    calcPercentage (CS _ (Size tot) _) =+    calcPercentage (CS _ (Size tot) _ _) =       ((fromIntegral tot/ fromIntegral maxSize) * 100 :: Double)      displayLine (l, h, n) = show l ++ "%-" ++ show h ++ "%: " ++ show n

@@ -101,7 +101,7 @@             <> "]\n"          gmlShowCensus :: CensusStats -> String-        gmlShowCensus (CS (Count c) (Size s) (Max (Size m))) =+        gmlShowCensus (CS (Count c) (Size s) (Max (Size m)) _) =           "count " <> show c <> "\n"           <> "size " <> show s <> "\n"           <> "max " <> show m <> "\n"

@@ -86,21 +86,13 @@ checkSize :: ObjectEquivState -> Int checkSize (ObjectEquivState e1 _ _) = PS.size e1 -type PtrClosure = DebugClosureWithSize SrtPayload PapPayload ConstrDesc StackFrames ClosurePtr+type PtrClosure = DebugClosureWithSize CCSPtr SrtPayload PapPayload ConstrDesc StackFrames ClosurePtr  -- | General function for performing a heap census in constant memory censusObjectEquiv :: [ClosurePtr] -> DebugM ObjectEquivState censusObjectEquiv cps = snd <$> runStateT (traceFromM funcs cps) (ObjectEquivState PS.empty IM.empty IM.empty)   where-    funcs = TraceFunctions {-               papTrace = const (return ())-              , srtTrace = const (return ())-              , stackTrace = const (return ())-              , closTrace = closAccum-              , visitedVal = const (return ())-              , conDescTrace = const (return ())--            }+    funcs = justClosures closAccum     -- Add cos     closAccum  :: ClosurePtr                -> SizedClosure@@ -111,10 +103,10 @@       -- for this cp       -- Step 1: Decode a bit more of the object, so we can see all the       -- pointers.-      s' <- lift $ quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc dereferenceStack pure s+      s' <- lift $ hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc dereferenceStack pure s       -- Step 2: Replace all the pointers in the closure by things they are       -- equivalent to we have already seen.-      s''  <- quintraverse (traverse rep_c) (traverse rep_c) pure (traverse rep_c) rep_c s'+      s''  <- hextraverse pure (traverse rep_c) (traverse rep_c) pure (traverse rep_c) rep_c s'       -- Step 3: Have we seen a closure like this one before?       modify' (addEquiv cp s'') 

@@ -5,7 +5,9 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-}+ -- | Functions to support the constant space traversal of a heap. -- This module is like the Trace module but performs the tracing in -- parellel. The speed-up is quite modest but hopefully can be improved in@@ -30,9 +32,12 @@ import Data.IORef import Control.Exception.Base import Control.Concurrent.STM+import Data.Bitraversable+import Data.Coerce ( coerce )+import GHC.Conc (numCapabilities)  threads :: Int-threads = 64+threads = numCapabilities  type InChan = TChan type OutChan = TChan@@ -43,14 +48,17 @@ -- * Outer map, segmented by MBlock --  * Inner map, blocks for that MBlock --    * Inner IOBitArray, visited information for that block-data ThreadState s = ThreadState (IM.IntMap (IM.IntMap (IOBitArray Word16))) (IORef s)+data ThreadState s = ThreadState+  { visitedPtrs :: IM.IntMap (IM.IntMap (IOBitArray Word16))+  , globalState :: IORef s+  }  newtype ThreadInfo a = ThreadInfo (InChan (ClosurePtrWithInfo a))  -- | A 'ClosurePtr' with some additional information which needs to be -- communicated across to another thread. data ClosurePtrWithInfo a = ClosurePtrWithInfo !a !ClosurePtr-+                          | CCSPtrWithInfo CCSPtr  -- | Map from Thread -> Information about the thread type ThreadMap a = IM.IntMap (ThreadInfo a)@@ -80,6 +88,12 @@   case IM.lookup mkey st of     Nothing -> error $ "Not enough chans:" ++ show mkey ++ show threads     Just (ThreadInfo ic) -> atomically $ writeTChan ic cpi+sendToChan ts cpi@(CCSPtrWithInfo ccsPtr) = DebugM $ liftIO $ do+  let st = visited ts+      mkey = getMBlockKey (coerce ccsPtr)+  case IM.lookup mkey st of+    Nothing -> error $ "Not enough chans:" ++ show mkey ++ show threads+    Just (ThreadInfo ic) -> atomically $ writeTChan ic cpi  initThread :: Monoid s =>               Int@@ -129,13 +143,27 @@           unsafeLiftIO $ writeIORef r m'           if b             then do-              s <- visitedVal k cp a+              s <- visitedClosVal k cp a               unsafeLiftIO $ modifyIORef' ref (s <>)             else do               sc <- dereferenceClosure cp               (a', s, cont) <- closTrace k cp sc a               unsafeLiftIO $ modifyIORef' ref (s <>)-              cont (() <$ quintraverse (gosrt r a') (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)+              cont (() <$ hextraverse (goCCS r) (gosrt r a') (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc)+    deref r (CCSPtrWithInfo cp) = do+        m <- unsafeLiftIO $ readIORef r+        do+          (m', b) <- unsafeLiftIO $ checkVisit (coerce cp) m+          unsafeLiftIO $ writeIORef r m'+          if b+            then do+              s <- visitedCcsVal k cp+              unsafeLiftIO $ modifyIORef' ref (s <>)+            else do+              ccs' <- dereferenceCCS cp+              s <- ccsTrace k cp ccs'+              unsafeLiftIO $ modifyIORef' ref (s <>)+              () <$ bitraverse (goCCS r) goCC ccs'      goc r c@(ClosurePtrWithInfo _i cp) =       let mkey = getMBlockKey cp@@ -148,12 +176,21 @@     gos r a st = do       st' <- dereferenceStack st       stackTrace k st'-      () <$ traverse (goc r . ClosurePtrWithInfo a) st'+      () <$ bitraverse (gosrt r a) (goc r . ClosurePtrWithInfo a) st'      gocd d = do       cd <- dereferenceConDesc d       conDescTrace k cd +    goCCS r cp =+        let mkey = getMBlockKey (coerce cp)+        in if (mkey == n)+            then deref r (CCSPtrWithInfo cp)+            else go (CCSPtrWithInfo cp)++    goCC p = do+      () <$ dereferenceCC p+     gop r a p = do       p' <- dereferencePapPayload p       papTrace k p'@@ -193,33 +230,31 @@       (st', res) <- handleBlockLevel bk offset bm       return (ThreadState (IM.insert mbk st' v) ref, res) ---- data TraceFunctionsIO a s =       TraceFunctionsIO { papTrace :: !(GenPapPayload ClosurePtr -> DebugM ())       , srtTrace :: !(GenSrtPayload ClosurePtr -> DebugM ())       , stackTrace :: !(GenStackFrames SrtCont ClosurePtr -> DebugM ())       , closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))-      , visitedVal :: !(ClosurePtr -> a -> DebugM s)+      , visitedClosVal :: !(ClosurePtr -> a -> DebugM s)+      , visitedCcsVal :: !(CCSPtr -> DebugM s)       , conDescTrace :: !(ConstrDesc -> DebugM ())+      , ccsTrace :: !(CCSPtr -> CCSPayload -> DebugM s)       }   -- | A generic heap traversal function which will use a small amount of--- memory linear in the heap size. Using this function with appropiate+-- memory linear in the heap size. Using this function with appropriate -- accumulation functions you should be able to traverse quite big heaps in -- not a huge amount of memory. ----- The performance of this parralel version depends on how much contention+-- The performance of this parallel version depends on how much contention -- the functions given in 'TraceFunctionsIO' content for the handle -- connecting for the debuggee (which is protected by an 'MVar'). With no -- contention, and precached blocks, the workload can be very evenly -- distributed leading to high core utilisation. -- -- As performance depends highly on contention, snapshot mode is much more--- amenable to parrelisation where the time taken for requests is much+-- amenable to parallelisation where the time taken for requests is much -- lower. traceParFromM :: Monoid s => TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s traceParFromM k cps = do@@ -231,8 +266,9 @@       go  = sendToChan (TraceState ts_map)   as <- sequence (map ($ go) start )   mapM_ go cps-  unsafeLiftIO $ waitFinish work_actives-  unsafeLiftIO $ mapM_ cancel as+  wait_finish <- unsafeLiftIO $ async (waitFinish work_actives)+  unsafeLiftIO $ waitAny $ (() <$ wait_finish) : (map ((<$) ()) as)+  unsafeLiftIO $ mconcat <$> mapM cancel as   unsafeLiftIO $ mconcat <$> mapM wait as  waitFinish :: [STM Bool] -> IO ()@@ -245,12 +281,21 @@       -- active work and empty chan)       if b then checkDone xs else retry --- | A parellel tracing function.+-- | A parallel tracing function. tracePar :: [ClosurePtr] -> DebugM () tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ())   where     nop = const (return ())-    funcs = TraceFunctionsIO nop nop stack clos (const (const (return ()))) nop+    funcs = TraceFunctionsIO+      { papTrace = nop+      , srtTrace = nop+      , stackTrace = stack+      , closTrace = clos+      , visitedClosVal = const (const (return ()))+      , visitedCcsVal = nop+      , conDescTrace = nop+      , ccsTrace = const (const (return ()))+      }      stack :: GenStackFrames SrtCont ClosurePtr -> DebugM ()     stack fs =@@ -263,5 +308,3 @@       let itb = info (noSize sc)       _traced <- getSourceInfo (tableId itb)       return ((), (), id)--

@@ -9,6 +9,8 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+ {- | Functions for performing whole heap census in the style of the normal - heap profiling -} module GHC.Debug.Profile( censusClosureType@@ -17,9 +19,22 @@                         , CensusByClosureType                         , writeCensusByClosureType                         , CensusStats(..)+                        , ProfileKey(..)+                        , ProfileKeyArgs(..)+                        , prettyProfileKey+                        , prettyShortProfileKey+                        , prettyProfileKeyArgs+                        , prettyProfileKeyArgs'+                        , prettyShortProfileKeyArgs                         , mkCS                         , Count(..)-                        , closureToKey ) where+                        , closureToKey+                        , ConstrDescText+                        , packConstrDesc+                        , pkgsText+                        , modlText+                        , nameText+                        ) where  import GHC.Debug.Client.Monad import GHC.Debug.Client@@ -28,15 +43,18 @@ import GHC.Debug.Profile.Types  import qualified Data.Map.Strict as Map-import Control.Monad.State+import Control.Monad.State.Strict import Data.List (sortBy) import Data.Ord-import Data.Text (pack, Text, unpack)+import Data.Text (pack, Text) import Data.Semigroup import qualified Data.Text as T+import qualified Data.Text.IO as T import qualified Data.Map.Monoidal.Strict as MMap import Data.Bitraversable import Control.Monad+import qualified Data.Set as Set+import qualified Data.Vector as V  --import Control.Concurrent --import Eventlog.Types@@ -45,32 +63,95 @@ --import Eventlog.HtmlTemplate --import Eventlog.Args (defaultArgs, Option(..)) --type CensusByClosureType = Map.Map Text CensusStats+type CensusByClosureType = Map.Map (ProfileKey, ProfileKeyArgs) CensusStats  -- | Perform a heap census in the same style as the -hT profile. censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType censusClosureType = closureCensusBy go   where     go :: ClosurePtr -> SizedClosure-       -> DebugM (Maybe (Text, CensusStats))-    go _ s = do-      d <- quintraverse pure pure dereferenceConDesc pure pure s+       -> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats))+    go cp s = do+      d <- hextraverse pure pure pure dereferenceConDesc pure pure s       let siz :: Size           siz = dcSize d-          v =  mkCS siz-      return $ Just (closureToKey (noSize d), v)--+          v =  mkCS cp siz+      return $ Just ((closureToProfileKey (noSize d), NoArgs), v) -closureToKey :: DebugClosure srt a ConstrDesc c d -> Text+closureToKey :: DebugClosure ccs srt a ConstrDesc c d -> Text closureToKey d =   case d of      ConstrClosure { constrDesc = ConstrDesc a b c }        -> pack a <> ":" <> pack b <> ":" <> pack c      _ -> pack (show (tipe (decodedTable (info d)))) +-- | 'ConstrDescText' wraps a 'ConstrDesc' but is backed by a 'Text'.+--+-- More efficient to keep around than 'ConstrDesc'.+newtype ConstrDescText = ConstrDescText+  { descText :: Text+    -- ^ Contains the name, module name and package name. Values are separated by ';'.+  } deriving (Show, Ord, Eq) +pkgsText :: ConstrDescText -> Text+pkgsText desc = case T.splitOn ";" (descText desc) of+  _:_:pkgs:_ -> pkgs+  _ -> error $ "pkgsText: invariant violation: " <> T.unpack (descText desc)+++modlText :: ConstrDescText -> Text+modlText desc = case T.splitOn ";" (descText desc) of+  _:modl:_:_ -> modl+  _ -> error $ "modlText: invariant violation: " <> T.unpack (descText desc)++nameText  :: ConstrDescText -> Text+nameText desc = case T.splitOn ";" (descText desc) of+  name:_:_:_ -> name+  _ -> error $ "nameText: invariant violation: " <> T.unpack (descText desc)++packConstrDesc :: ConstrDesc -> ConstrDescText+packConstrDesc constrDesc = ConstrDescText+  { descText = T.intercalate ";" [T.pack (name constrDesc), T.pack (modl constrDesc), T.pack (pkg constrDesc)]+  }++data ProfileKey+  = ProfileConstrDesc !ConstrDescText+  | ProfileClosureDesc !Text+  deriving (Show, Ord, Eq)++-- | Show the full 'ProfileKey', including package and module locations if available.+prettyProfileKey :: ProfileKey -> Text+prettyProfileKey (ProfileClosureDesc k) = k+prettyProfileKey (ProfileConstrDesc desc) = pkgsText desc <> ":" <> modlText desc <> ":" <> nameText desc++-- | Show the 'ProfileKey' in a shortened form if possible.+-- For example, it omits package and module locations for 'ProfileConstrDesc'.+prettyShortProfileKey :: ProfileKey -> Text+prettyShortProfileKey (ProfileClosureDesc k) = k+prettyShortProfileKey (ProfileConstrDesc desc) = nameText desc++closureToProfileKey :: DebugClosure ccs srt a ConstrDesc c d -> ProfileKey+closureToProfileKey d =+  case d of+     ConstrClosure { constrDesc = constrDesc } -> ProfileConstrDesc $ packConstrDesc constrDesc+     _ -> ProfileClosureDesc $ pack (show (tipe (decodedTable (info d))))+data ProfileKeyArgs+  = ArrKeyArgs !ProfileKey !Int+  | AllKeyArgs !(V.Vector ProfileKey)+  | NoArgs+  deriving (Show, Ord, Eq)++prettyProfileKeyArgs :: ProfileKeyArgs -> Text+prettyProfileKeyArgs = prettyProfileKeyArgs' prettyProfileKey++prettyShortProfileKeyArgs :: ProfileKeyArgs -> Text+prettyShortProfileKeyArgs = prettyProfileKeyArgs' prettyShortProfileKey++prettyProfileKeyArgs' :: (ProfileKey -> Text) -> ProfileKeyArgs -> Text+prettyProfileKeyArgs' prettyKey (ArrKeyArgs typ num) = "[" <> prettyKey typ <> ": " <> T.pack (show num) <> "]"+prettyProfileKeyArgs' prettyKey (AllKeyArgs args) = "[" <> T.intercalate "," (map prettyKey $ V.toList args) <> "]"+prettyProfileKeyArgs' _  NoArgs = ""+ -- | General function for performing a heap census in constant memory closureCensusBy :: forall k v . (Semigroup v, Ord k)                 => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))@@ -84,9 +165,10 @@               , srtTrace = const (return ())               , stackTrace = const (return ())               , closTrace = closAccum-              , visitedVal = const (const (return MMap.empty))+              , visitedClosVal = const (const (return MMap.empty))+              , visitedCcsVal = const (return MMap.empty)               , conDescTrace = const (return ())-+              , ccsTrace = const (const (return mempty))             }     -- Add cos     closAccum  :: ClosurePtr@@ -105,36 +187,49 @@ census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType census2LevelClosureType cps = snd <$> runStateT (traceFromM funcs cps) Map.empty   where-    funcs = TraceFunctions {-               papTrace = const (return ())-              , srtTrace = const (return ())-              , stackTrace = const (return ())-              , closTrace = closAccum-              , visitedVal = const (return ())-              , conDescTrace = const (return ())--            }+    funcs = justClosures closAccum     -- Add cos     closAccum  :: ClosurePtr                -> SizedClosure                -> (StateT CensusByClosureType DebugM) ()                -> (StateT CensusByClosureType DebugM) ()-    closAccum _ s k = do-      s' <- lift $ quintraverse dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure s+    closAccum cp s k = do+      s' <- lift $ hextraverse pure dereferenceSRT dereferencePapPayload dereferenceConDesc (bitraverse dereferenceSRT pure <=< dereferenceStack) pure s       pts <- lift $ mapM dereferenceClosure (allClosures (noSize s'))-      pts' <- lift $ mapM (quintraverse pure pure dereferenceConDesc pure pure) pts+      pts' <- lift $ mapM (hextraverse pure pure pure dereferenceConDesc pure pure) pts  -      modify' (go s' pts')+      modify' (go cp s' pts')       k -    go d args =-      let k = closureToKey (noSize d)-          kargs = map (closureToKey . noSize) args-          final_k :: Text-          final_k = k <> "[" <> T.intercalate "," kargs <> "]"-      in Map.insertWith (<>) final_k (mkCS (dcSize d))+    closureArgsToKeyArgs (ProfileClosureDesc k) kargs =+      if k `Set.member` mutArrConstants && Set.size (Set.fromList kargs) == 1+        then ArrKeyArgs (head kargs) (length kargs)+        else AllKeyArgs $! V.fromList kargs+    closureArgsToKeyArgs (ProfileConstrDesc _) kargs =+      AllKeyArgs $ V.fromList kargs +    go cp d args =+      let !k = closureToProfileKey (noSize d)+          kargs = map (closureToProfileKey . noSize) args+          !keyArgs = closureArgsToKeyArgs k kargs+      in Map.insertWith (<>) (k, keyArgs) (mkCS cp (dcSize d))++    -- We handle these closure types differently as they can list each entry as an arg.+    -- That leads to huge results, so we try to compress these closure types if and only if+    -- they describe a constructor homogenous array. Thus, it works well for product types+    -- but not for sum types.+    mutArrConstants = Set.fromList $ map (T.pack . show)+      [ MUT_ARR_PTRS_CLEAN+      , MUT_ARR_PTRS_DIRTY+      , MUT_ARR_PTRS_FROZEN_DIRTY+      , MUT_ARR_PTRS_FROZEN_CLEAN+      , SMALL_MUT_ARR_PTRS_CLEAN+      , SMALL_MUT_ARR_PTRS_DIRTY+      , SMALL_MUT_ARR_PTRS_FROZEN_DIRTY+      , SMALL_MUT_ARR_PTRS_FROZEN_CLEAN+      ]+ {- -- | Parallel heap census parCensus :: [RawBlock] -> [ClosurePtr] -> DebugM (Map.Map Text CensusStats)@@ -148,7 +243,7 @@     clos :: ClosurePtr -> SizedClosure -> ()               -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ())     clos _cp sc () = do-      d <- quintraverse pure dereferenceConDesc pure pure sc+      d <- hextraverse pure dereferenceConDesc pure pure sc       let s :: Size           s = dcSize sc           v =  mkCS s@@ -159,10 +254,18 @@ writeCensusByClosureType :: FilePath -> CensusByClosureType -> IO () writeCensusByClosureType outpath c = do   let res = sortBy (flip (comparing (cssize . snd))) (Map.toList c)-      showLine (k, CS (Count n) (Size s) (Max (Size mn))) =-        concat [unpack k, ":", show s,":", show n, ":", show mn,":", show @Double (fromIntegral s / fromIntegral n)]-  writeFile outpath (unlines $ "key, total, count, max, avg" : map showLine res)-+  T.writeFile outpath (T.unlines $ "key; total; count; max; avg" : map showLine res)+  where+    separator = "; "+    showKey k args = prettyProfileKey k <> prettyProfileKeyArgs args+    showLine ((k, kargs), CS (Count n) (Size s) (Max (Size mn)) _) =+      T.intercalate separator+        [ showKey k kargs+        , T.pack (show s)+        , T.pack (show n)+        , T.pack (show mn)+        , T.pack (show @Double (fromIntegral s / fromIntegral n))+        ]  {- -- | Peform a profile at the given interval (in seconds), the result will

@@ -5,17 +5,33 @@ import Data.Monoid import Data.Semigroup -newtype Count = Count Int+newtype Count = Count {getCount :: Int }                 deriving (Semigroup, Monoid, Num) via Sum Int                 deriving (Show, Ord, Eq) -data CensusStats = CS { cscount :: !Count, cssize :: !Size, csmax :: !(Max Size) } deriving (Show, Eq)+newtype Sample = Sample { getSamples :: [ClosurePtr] } deriving (Show, Eq) -mkCS :: Size -> CensusStats-mkCS i = CS (Count 1) i (Max i)+instance Monoid Sample where+  mempty = Sample [] +instance Semigroup Sample where+  (Sample a) <> (Sample b) =+    case (take 5 (a ++ b)) of+      xs@(_:_:_:_:_:_) -> Sample xs+      xs -> Sample xs++++data CensusStats = CS { cscount :: !Count+                        , cssize :: !Size+                        , csmax :: !(Max Size)+                        , sample :: !Sample } deriving (Show, Eq)++mkCS :: ClosurePtr -> Size -> CensusStats+mkCS cp i = CS (Count 1) i (Max i) (Sample [cp])+ instance Monoid CensusStats where-  mempty = CS mempty mempty (Max (Size 0))+  mempty = CS mempty mempty (Max (Size 0)) mempty  instance Semigroup CensusStats where-  (CS a b c) <> (CS a1 b1 c1) = CS (a <> a1) (b <> b1) (c <> c1)+  (CS a b c d) <> (CS a1 b1 c1 d1) = CS (a <> a1) (b <> b1) (c <> c1) (d <> d1)

@@ -1,7 +1,24 @@ {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-} -- | Functions for computing retainers-module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainersOfInfoTable, findRetainers, addLocationToStack, displayRetainerStack, addLocationToStack', displayRetainerStack') where+module GHC.Debug.Retainers+  ( findRetainers+  , findRetainersOf+  , findRetainersOfConstructor+  , findRetainersOfConstructorExact+  , findRetainersOfInfoTable+  , addLocationToStack+  , displayRetainerStack+  , addLocationToStack'+  , displayRetainerStack'+  , findRetainersOfArrWords+  , EraRange(..)+  , profHeaderInEraRange+  , ClosureFilter(..)+  , profHeaderReferencesCCS+  , findRetainersOfEra) where +import Prelude hiding (filter) import GHC.Debug.Client import Control.Monad.State import GHC.Debug.Trace@@ -10,64 +27,131 @@  import qualified Data.Set as Set import Control.Monad.RWS+import Data.Word -addOne :: [ClosurePtr] -> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])+addOne :: a -> (Maybe Int, [a]) -> (Maybe Int, [a]) addOne _ (Just 0, cp) = (Just 0, cp)-addOne cp (n, cps)    = (subtract 1 <$> n, cp:cps)+addOne cp (n, cps)    = (subtract 1 <$> n, cp : cps) +data EraRange+  = EraRange { startEra :: Word64, endEra :: Word64} -- inclusive+  deriving (Eq, Ord, Show)++inEraRange :: Word64 -> Maybe EraRange -> Bool+inEraRange _ Nothing = True+inEraRange n (Just (EraRange s e)) = s <= n && n <= e++profHeaderReferencesCCS :: Maybe ProfHeaderWithPtr -> Set.Set CCSPtr -> Bool+profHeaderReferencesCCS Nothing _ = False+profHeaderReferencesCCS (Just profHeader) f = ccs profHeader `Set.member` f++profHeaderInEraRange :: Maybe (ProfHeader a) -> Maybe EraRange -> Bool+profHeaderInEraRange Nothing _ = True+profHeaderInEraRange (Just ph) eras+  = case hp ph of+      EraWord w -> w `inEraRange` eras+      _ -> True -- Don't filter if no era profiling++data ClosureFilter+ = ConstructorDescFilter (ConstrDesc -> Bool)+ | InfoFilter (StgInfoTable -> Bool)+ | InfoPtrFilter (InfoTablePtr -> Bool)+ | InfoSourceFilter (SourceInformation -> Bool)+ | SizeFilter (Size -> Bool)+ | ProfHeaderFilter (Maybe ProfHeaderWithPtr -> Bool)+ | AddressFilter (ClosurePtr -> Bool)+ | AndFilter ClosureFilter ClosureFilter+ | OrFilter ClosureFilter ClosureFilter+ | NotFilter ClosureFilter+ | PureFilter Bool++matchesFilter :: ClosureFilter -> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool+matchesFilter filter ptr sc parents = case filter of+  ConstructorDescFilter p -> case noSize sc of+    ConstrClosure _ _ _ _ cd -> do+      cd' <- dereferenceConDesc cd+      return $ p cd'+    _ -> pure False+  InfoFilter p -> pure $ p (decodedTable (info (noSize sc)))+  InfoPtrFilter p -> pure $ p (tableId (info (noSize sc)))+  InfoSourceFilter p -> do+    loc <- getSourceInfo (tableId (info (noSize sc)))+    case loc of+      Nothing -> return False+      Just cur_loc -> pure $ p cur_loc+  SizeFilter p -> pure $ p (dcSize sc)+  ProfHeaderFilter p -> pure $ p (profHeader $ noSize sc)+  AddressFilter p -> pure $ p ptr+  AndFilter f1 f2 -> do+    r1 <- matchesFilter f1 ptr sc parents+    case r1 of+      False -> pure False+      True -> matchesFilter f2 ptr sc parents+  OrFilter f1 f2 -> do+    r1 <- matchesFilter f1 ptr sc parents+    case r1 of+      True -> pure True+      False -> matchesFilter f2 ptr sc parents+  NotFilter f1  -> do+    r1 <- matchesFilter f1 ptr sc parents+    pure (not r1)+  PureFilter b -> pure b+ findRetainersOf :: Maybe Int                 -> [ClosurePtr]                 -> [ClosurePtr]                 -> DebugM [[ClosurePtr]]-findRetainersOf limit cps bads = findRetainers limit cps (\cp _ -> return (cp `Set.member` bad_set))+findRetainersOf limit cps bads =+  findRetainers limit (AddressFilter (`Set.member` bad_set)) cps   where     bad_set = Set.fromList bads -findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]+findRetainersOfConstructor :: Maybe Int+                           -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]] findRetainersOfConstructor limit rroots con_name =-  findRetainers limit rroots go-  where-    go _ sc =-      case noSize sc of-        ConstrClosure _ _ _ cd -> do-          ConstrDesc _ _  cname <- dereferenceConDesc cd-          return $ cname == con_name-        _ -> return $ False+  findRetainers limit (ConstructorDescFilter ((== con_name) . name)) rroots -findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]+findRetainersOfConstructorExact+  :: Maybe Int+  -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]] findRetainersOfConstructorExact limit rroots clos_name =-  findRetainers limit rroots go+  findRetainers limit (InfoSourceFilter ((== clos_name) . infoName)) rroots++findRetainersOfEra+  :: Maybe Int+  -> EraRange+  -> [ClosurePtr] -> DebugM [[ClosurePtr]]+findRetainersOfEra limit eras rroots =+  findRetainers limit filter rroots   where-    go _ sc = do-      loc <- getSourceInfo (tableId (info (noSize sc)))-      case loc of-        Nothing -> return False-        Just cur_loc ->+    filter = ProfHeaderFilter (`profHeaderInEraRange` (Just eras)) -          return $ (infoName cur_loc) == clos_name+findRetainersOfArrWords+  :: Maybe Int+  -> [ClosurePtr] -> Size -> DebugM [[ClosurePtr]]+findRetainersOfArrWords limit rroots lim =+  findRetainers limit filter rroots+  where+    -- TODO : this is the size of the entire closure, not the size of the ArrWords+    filter = AndFilter (InfoFilter ((== ARR_WORDS) . tipe))+                       (SizeFilter (>= lim)) -findRetainersOfInfoTable :: Maybe Int -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]]+findRetainersOfInfoTable+  :: Maybe Int+  -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]] findRetainersOfInfoTable limit rroots info_ptr =-  findRetainers limit rroots go-  where-    go _ sc = return $ tableId (info (noSize sc)) == info_ptr+  findRetainers limit (InfoPtrFilter (== info_ptr)) rroots  -- | From the given roots, find any path to one of the given pointers. -- Note: This function can be quite slow! The first argument is a limit to -- how many paths to find. You should normally set this to a small number -- such as 10.-findRetainers :: Maybe Int -> [ClosurePtr] -> (ClosurePtr -> SizedClosure -> DebugM Bool) -> DebugM [[ClosurePtr]]-findRetainers limit rroots p = (\(_, r, _) -> snd r) <$> runRWST (traceFromM funcs rroots) [] (limit, [])+findRetainers :: Maybe Int+  -> ClosureFilter+  -> [ClosurePtr] -> DebugM [[ClosurePtr]]+findRetainers limit filter rroots = (\(_, r, _) -> snd r) <$> runRWST (traceFromM funcs rroots) [] (limit, [])   where-    funcs = TraceFunctions {-               papTrace = const (return ())-              , srtTrace = const (return ())-              , stackTrace = const (return ())-              , closTrace = closAccum-              , visitedVal = const (return ())-              , conDescTrace = const (return ())--            }+    funcs = justClosures closAccum     -- Add clos     closAccum  :: ClosurePtr                -> SizedClosure@@ -75,19 +159,17 @@                -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()     closAccum _ (noSize -> WeakClosure {}) _ = return ()     closAccum cp sc k = do-      b <- lift $ p cp sc+      ctx <- ask+      b <- lift $ matchesFilter filter cp sc ctx       if b-        then do-          ctx <- ask-          modify' (addOne (cp: ctx))-          local (cp:) k-          -- Don't call k, there might be more paths to the pointer but we-          -- probably just care about this first one.-        else do-          (lim, _) <- get-          case lim of-            Just 0 -> return ()-            _ -> local (cp:) k+      then do+        modify' (addOne (cp: ctx))+        local (cp:) k+      else do+        (lim, _) <- get+        case lim of+          Just 0 -> return ()+          _ -> local (cp:) k  addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureP, Maybe SourceInformation)] addLocationToStack r = do

@@ -13,14 +13,18 @@ import GHC.Debug.Client import Control.Monad.Identity import Control.Monad.Trans+import GHC.Debug.CostCentres (findAllChildrenOfCC)+import Control.Monad+import GHC.Debug.Types.Version  -- | Make a snapshot of the current heap and save it to the given file. snapshot :: FilePath -> DebugM () snapshot fp = do   precacheBlocks-  version+  ver <- version   rs <- gcRoots   _so <- savedObjects+  when (isProfiledRTS ver) (() <$ findAllChildrenOfCC (const False))   tracePar rs   saveCache fp @@ -29,8 +33,7 @@ traceFrom :: [ClosurePtr] -> DebugM () traceFrom cps = runIdentityT (traceFromM funcs cps)   where-    nop = const (return ())-    funcs = TraceFunctions nop nop nop clos (const (return ())) nop+    funcs = justClosures clos      clos :: ClosurePtr -> SizedClosure -> (IdentityT DebugM) ()               ->  (IdentityT DebugM) ()

@@ -7,7 +7,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} module GHC.Debug.Strings ( stringProgram, arrWordsProgram-                         , arrWordsAnalysis, stringAnalysis) where+                         , arrWordsAnalysis, stringAnalysis, decodeString) where  import GHC.Debug.Client import GHC.Debug.Types.Ptr@@ -61,15 +61,7 @@ stringAnalysis :: [ClosurePtr] -> DebugM (Map.Map String (S.Set ClosurePtr)) stringAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) False (Map.empty)   where-    funcs = TraceFunctions {-               papTrace = const (return ())-              , srtTrace = const (return ())-              , stackTrace = const (return ())-              , closTrace = closAccum-              , visitedVal = const (return ())-              , conDescTrace = const (return ())--            }+    funcs = justClosures closAccum      -- First time we have visited a closure     closAccum  :: ClosurePtr@@ -78,7 +70,7 @@                -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()     closAccum cp sc k = do       case noSize sc of-        ConstrClosure _ _ _ cd -> do+        ConstrClosure _ _ _ _ cd -> do           cd' <- lift $ dereferenceConDesc cd           case cd' of             ConstrDesc _ _ cd2 | cd2 == ":" -> do@@ -89,7 +81,7 @@         process :: ClosurePtr -> SizedClosure                 -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()         process p_cp clos = do-          clos' <- lift $ quintraverse pure pure dereferenceConDesc return return (noSize clos)+          clos' <- lift $ hextraverse pure pure pure dereferenceConDesc return return (noSize clos)           checked <- lift $ check_bin clos'           if checked             then do@@ -105,25 +97,36 @@         process_2 p_cp = do           cp' <- dereferenceClosure p_cp           case noSize cp' of-            (ConstrClosure _ _ _ cd) -> do+            (ConstrClosure _ _ _ _ cd) -> do               (ConstrDesc _ _ cn) <- dereferenceConDesc cd               return (cn == "C#")+            (IndClosure _ _ i) ->+              process_2 i             _ -> return False -        check_bin (ConstrClosure _ [h,_] _ (ConstrDesc _ _ ":")) = process_2 h+        check_bin (ConstrClosure _ _ [h,_] _ (ConstrDesc _ _ ":")) = process_2 h+        check_bin (IndClosure _ _ i) = do+          sizedI <- dereferenceClosure i+          clos' <- hextraverse pure pure pure dereferenceConDesc return return (noSize sizedI)+          check_bin clos'         check_bin _ = return False  decodeString :: ClosurePtr -> DebugM String decodeString cp = do   cp' <- dereferenceClosure cp   case noSize cp' of-    (ConstrClosure _ [p,ps] _ _) -> do-      cp'' <- dereferenceClosure p-      case noSize cp'' of-        (ConstrClosure _ _ [w] _) -> do-          (chr (fromIntegral w):) <$> decodeString ps-        _ -> return []+    (IndClosure _ _ i) -> decodeString i+    (ConstrClosure _ _ [p,ps] _ _) -> do+      go p ps     _ -> return []+    where+  go headp tailp = do+    cp'' <- dereferenceClosure headp+    case noSize cp'' of+      (IndClosure _ _ i) -> go i tailp+      (ConstrClosure _ _ _ [w] _) -> do+        (chr (fromIntegral w):) <$> decodeString tailp+      _ -> return []   printResult :: Show a => Map.Map a Count -> IO [a]@@ -140,15 +143,7 @@ arrWordsAnalysis :: [ClosurePtr] -> DebugM (Map.Map ByteString (S.Set ClosurePtr)) arrWordsAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) () (Map.empty)   where-    funcs = TraceFunctions {-               papTrace = const (return ())-              , srtTrace = const (return ())-              , stackTrace = const (return ())-              , closTrace = closAccum-              , visitedVal = const (return ())-              , conDescTrace = const (return ())--            }+    funcs = justClosures closAccum      -- First time we have visited a closure     closAccum  :: ClosurePtr@@ -157,7 +152,7 @@                -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()     closAccum cp sc k = do           case (noSize sc) of-            ArrWordsClosure _ _ p ->  do+            ArrWordsClosure _ _ _ p ->  do               modify' (Map.insertWith (<>) (arrWordsBS p) (S.singleton cp))               k             _ -> k

@@ -0,0 +1,29 @@+module GHC.Debug.Thunks where++import GHC.Debug.Types+import GHC.Debug.Client.Monad+import GHC.Debug.Profile.Types+import qualified Data.Map.Strict as Map+import Control.Monad.RWS+import GHC.Debug.Trace+import GHC.Debug.Client.Query+++thunkAnalysis :: [ClosurePtr] -> DebugM (Map.Map (Maybe SourceInformation) Count)+thunkAnalysis rroots = (\(_, r, _) -> r) <$> runRWST (traceFromM funcs rroots) () (Map.empty)+  where+    funcs = justClosures closAccum++    getSourceLoc c = getSourceInfo (tableId (info (noSize c)))++    closAccum  :: ClosurePtr+               -> SizedClosure+               -> (RWST () () (Map.Map (Maybe SourceInformation) Count) DebugM) ()+               -> (RWST () () (Map.Map (Maybe SourceInformation) Count) DebugM) ()+    closAccum _ sc k = do+          case (noSize sc) of+            ThunkClosure {} ->  do+              loc <- lift $ getSourceLoc sc+              modify' (Map.insertWith (<>) loc (Count 1))+              k+            _ -> k

@@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} -- | Functions to support the constant space traversal of a heap. module GHC.Debug.Trace ( traceFromM, TraceFunctions(..), justClosures ) where @@ -14,6 +15,8 @@ import Control.Monad import Data.IORef import Data.Word+import Data.Bitraversable+import Data.Coerce  newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16)) @@ -53,16 +56,14 @@       , closTrace :: !(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())       , visitedVal :: !(ClosurePtr -> (m DebugM) ())       , conDescTrace :: !(ConstrDesc -> m DebugM ())+      , ccsTrace :: !(CCSPtr -> CCSPayload -> m DebugM ())       }  justClosures :: C m => (ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()) -> TraceFunctions m-justClosures f = TraceFunctions nop nop nop f nop nop+justClosures f = TraceFunctions nop nop nop f nop nop (const nop)   where     nop = const (return ()) --- type C m = (MonadTrans m, Monad (m DebugM))  -- | A generic heap traversal function which will use a small amount of@@ -92,7 +93,7 @@         else do         sc <- lift $ lift $ dereferenceClosure cp         ReaderT $ \st -> closTrace k cp sc-         (runReaderT (() <$ quintraverse gosrt gop gocd gos go sc) st)+         (runReaderT (() <$ hextraverse goccs gosrt gop gocd gos go sc) st)       gos st = do@@ -113,3 +114,16 @@       p' <- lift $ lift $ dereferenceSRT p       lift $ srtTrace k p'       () <$ traverse go p'++    goccs p = do+      mref <- ask+      (mnum_visited, b) <- lift $ lift $ unsafeLiftIO (checkVisit (coerce p) mref)+      if b+        then return ()+        else do+          p' <- lift $ lift $ dereferenceCCS p+          lift $ ccsTrace k p p'+          () <$ bitraverse goccs pure p'+++

@@ -75,14 +75,15 @@ typePointsFrom cs = traceParFromM funcs (map (ClosurePtrWithInfo Root) cs)    where-    nop = const (return ())-    funcs = TraceFunctionsIO nop nop nop clos visit nop+    nop = const (return mempty)+    nop2 = const (return mempty)+    funcs = TraceFunctionsIO nop nop nop clos visit nop2 nop (const nop2)      visit :: ClosurePtr -> Context -> DebugM TypePointsFrom     visit cp ctx = do       sc <- dereferenceClosure cp       let k = tableId $ info (noSize sc)-          v = mkCS (dcSize sc)+          v = mkCS cp (dcSize sc)           parent_edge = case ctx of                           Root -> []                           Parent pk -> [(Edge k pk, v)]@@ -92,11 +93,11 @@      clos :: ClosurePtr -> SizedClosure -> Context               -> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ())-    clos _cp sc ctx = do+    clos cp sc ctx = do       let k = tableId $ info (noSize sc)       let s :: Size           s = dcSize sc-          v =  mkCS s+          v =  mkCS cp s            -- Edges point from the object TO what retains it           parent_edge = case ctx of