ghc-debug-client 0.2.1.0 → 0.3.0.0

raw patch · 14 files changed

+284/−55 lines, 14 filesdep +bytestringdep +contra-tracerdep ~ghc-debug-commondep ~ghc-debug-conventionPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, contra-tracer

Dependency ranges changed: ghc-debug-common, ghc-debug-convention

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• ghc-debug-client.cabal +7/−4
• src/GHC/Debug/Client.hs +1/−1
• src/GHC/Debug/Client/Monad.hs +17/−4
• src/GHC/Debug/Client/Monad/Class.hs +2/−1
• src/GHC/Debug/Client/Monad/Simple.hs +20/−12
• src/GHC/Debug/Client/Query.hs +19/−7
• src/GHC/Debug/Client/RequestCache.hs +2/−4
• src/GHC/Debug/ParTrace.hs +8/−6
• src/GHC/Debug/Retainers.hs +31/−10
• src/GHC/Debug/Snapshot.hs +1/−0
• src/GHC/Debug/Strings.hs +161/−0
• src/GHC/Debug/Trace.hs +6/−6
• src/GHC/Debug/TypePointsFrom.hs +1/−0

@@ -1,5 +1,13 @@ # Revision history for ghc-debug-client +## 0.3 -- 2022-10-06++* Abstract away tracing functions to allow configuration of progress reporting.+* Add stringAnalysis and arrWordsAnalysis in GHC.Debug.Strings+* Make block decoding more robust if the cache lookup fails for some reason.+* Fix bug in snapshots where we weren't storing stack frame source locations or+  version.+ ## 0.2.1.0 -- 2022-05-06  * Fix findRetainersOfConstructorExact

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                ghc-debug-client-version:             0.2.1.0+version:             0.3.0.0 synopsis:            Useful functions for writing heap analysis tools which use                      ghc-debug. description:         Useful functions for writing heap analysis tools which use@@ -27,6 +27,7 @@                        GHC.Debug.Trace,                        GHC.Debug.ParTrace,                        GHC.Debug.Count,+                       GHC.Debug.Strings,                        GHC.Debug.TypePointsFrom,                        GHC.Debug.Snapshot,                        GHC.Debug.Dominators,@@ -41,8 +42,8 @@                        network >= 2.6 ,                        containers ^>= 0.6,                        unordered-containers ^>= 0.2.13,-                       ghc-debug-common == 0.2.1.0,-                       ghc-debug-convention == 0.2.0.0,+                       ghc-debug-common == 0.3.0.0,+                       ghc-debug-convention == 0.3.0.0,                        text ^>= 1.2.4,                        process ^>= 1.6,                        filepath ^>= 1.4,@@ -58,7 +59,9 @@                        monoidal-containers >= 0.6,                        language-dot ^>= 0.1,                        ghc-prim ^>= 0.8,-                       stm ^>= 2.5+                       stm ^>= 2.5,+                       bytestring,+                       contra-tracer    hs-source-dirs:      src   default-language:    Haskell2010

@@ -12,7 +12,7 @@         precacheBlocks         (r:_) <- gcRoots         buildHeapGraph (Just 10) r-  putStrLn (ppHeapGraph (const "") h)+  putStrLn (ppHeapGraph (const "") g) @  -}

@@ -20,9 +20,11 @@   , withDebuggeeConnect   , debuggeeRun   , debuggeeConnect+  , debuggeeConnectWithTracer   , debuggeeClose   -- * Snapshot run   , snapshotInit+  , snapshotInitWithTracer   , snapshotRun     -- * Logging   , outputRequestLog@@ -36,6 +38,7 @@ import GHC.Debug.Types (Request(..)) import qualified GHC.Debug.Client.Monad.Simple as S import System.IO+import Control.Tracer  type DebugM = S.DebugM @@ -88,19 +91,29 @@     -- Now connect to the socket the debuggeeProcess just started     debuggeeConnect socketName +debuggeeConnect :: FilePath -> IO Debuggee+debuggeeConnect = debuggeeConnectWithTracer debugTracer+ -- | Connect to a debuggee on the given socket. Use @debuggeeClose@ when you're done.-debuggeeConnect :: FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)+debuggeeConnectWithTracer+                :: Tracer IO String+                -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)                 -> IO Debuggee-debuggeeConnect socketName = do+debuggeeConnectWithTracer tracer socketName = do     s <- socket AF_UNIX Stream defaultProtocol     connect s (SockAddrUnix socketName)     hdl <- socketToHandle s ReadWriteMode-    new_env <- newEnv @DebugM (SocketMode hdl)+    new_env <- newEnv @DebugM tracer (SocketMode hdl)     return (Debuggee new_env)  -- | Create a debuggee by loading a snapshot created by 'snapshot'. snapshotInit :: FilePath -> IO Debuggee-snapshotInit fp = Debuggee <$> newEnv @DebugM (SnapshotMode fp)+snapshotInit = snapshotInitWithTracer debugTracer++snapshotInitWithTracer :: Tracer IO String -> FilePath -> IO Debuggee+snapshotInitWithTracer tracer fp =+  Debuggee <$> newEnv @DebugM tracer (SnapshotMode fp)+  -- | Start an analysis session using a snapshot. This will not connect to a -- debuggee. The snapshot is created by 'snapshot'.

@@ -5,6 +5,7 @@ import Data.Typeable import GHC.Debug.Client.BlockCache import GHC.Debug.Types+import Control.Tracer import System.IO  class (MonadFail m, Monad m) => DebugMonad m where@@ -15,7 +16,7 @@   printRequestLog :: DebugEnv m -> IO ()   runDebug :: DebugEnv m -> m a -> IO a   runDebugTrace :: DebugEnv m -> m a -> IO (a, [String])-  newEnv :: Mode -> IO (DebugEnv m)+  newEnv :: Tracer IO String -> Mode -> IO (DebugEnv m)    saveCache :: FilePath -> m ()   loadCache :: FilePath -> m ()

@@ -21,6 +21,7 @@ import Data.IORef import Data.List import Data.Ord+import Control.Tracer  import GHC.Debug.Client.BlockCache import GHC.Debug.Client.RequestCache@@ -37,6 +38,7 @@                          , debuggeeBlockCache :: IORef BlockCache                          , debuggeeRequestCache :: MVar RequestCache                          , debuggeeHandle :: Maybe (MVar Handle)+                         , debuggeeTrace :: Tracer IO String                          }  data FetchStats = FetchStats { _networkRequests :: !Int, _cachedRequests :: !Int }@@ -88,7 +90,10 @@   type DebugEnv DebugM = Debuggee   request = DebugM . simpleReq   requestBlock = blockReq-  traceMsg = DebugM . liftIO . putStrLn+  traceMsg s = DebugM $ do+    Debuggee{..} <- ask+    liftIO $ traceWith debuggeeTrace s+   printRequestLog e = do     case debuggeeRequestCount e of       Just hm_ref -> do@@ -96,9 +101,9 @@       Nothing -> putStrLn "No request log in Simple(TM) mode"   runDebug = runSimple   runDebugTrace e a = (,[]) <$> runDebug e a-  newEnv m = case m of-               SnapshotMode f -> mkSnapshotEnv f-               SocketMode h -> mkHandleEnv h+  newEnv t m = case m of+               SnapshotMode f -> mkSnapshotEnv t f+               SocketMode h -> mkHandleEnv t h    loadCache fp = DebugM $ do     (Snapshot _ new_req_cache) <- lift $ decodeFile fp@@ -127,23 +132,26 @@ runSimple :: Debuggee -> DebugM a -> IO a runSimple d (DebugM a) = runReaderT a d -mkEnv :: (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee-mkEnv (req_c, block_c) h = do+mkEnv :: Tracer IO String+      -> (RequestCache, BlockCache)+      -> Maybe Handle+      -> IO Debuggee+mkEnv trace_msg (req_c, block_c) h = do   let enable_stats = False   mcount <- if enable_stats then Just <$> newIORef HM.empty else return Nothing   bc <- newIORef  block_c   rc <- newMVar req_c   mhdl <-  traverse newMVar h-  return $ Debuggee mcount bc rc mhdl+  return $ Debuggee mcount bc rc mhdl trace_msg -mkHandleEnv :: Handle -> IO Debuggee-mkHandleEnv h = mkEnv (emptyRequestCache, emptyBlockCache) (Just h)+mkHandleEnv :: Tracer IO String -> Handle -> IO Debuggee+mkHandleEnv trace_msg h = mkEnv trace_msg (emptyRequestCache, emptyBlockCache) (Just h) -mkSnapshotEnv :: FilePath -> IO Debuggee-mkSnapshotEnv fp = do+mkSnapshotEnv :: Tracer IO String -> FilePath -> IO Debuggee+mkSnapshotEnv trace_msg fp = do   Snapshot _ req_c <- decodeFile fp   let block_c = initBlockCacheFromReqCache req_c-  mkEnv (req_c, block_c) Nothing+  mkEnv trace_msg (req_c, block_c) Nothing  -- TODO: Sending multiple pauses will clear the cache, should keep track of -- the pause state and only clear caches if the state changes.

@@ -34,12 +34,11 @@  import           Control.Exception import           GHC.Debug.Types-import           GHC.Debug.Decode+import qualified GHC.Debug.Decode as D import           GHC.Debug.Decode.Stack import GHC.Debug.Client.Monad import           GHC.Debug.Client.BlockCache import Control.Monad.State-import Data.Word  import Debug.Trace @@ -91,8 +90,15 @@     raw_c <- request (RequestClosure c)     let it = getInfoTblPtr raw_c     raw_it <- request (RequestInfoTable it)-    return $ decodeClosure raw_it (c, raw_c)+    decodeClosure raw_it (c, raw_c) +decodeClosure :: (StgInfoTableWithPtr, RawInfoTable)+              -> (ClosurePtr, RawClosure)+              -> DebugM SizedClosure+decodeClosure it c = do+  ver <- version+  return $ D.decodeClosure ver it c+ dereferenceClosures  :: [ClosurePtr] -> DebugM [SizedClosure] dereferenceClosures cs = mapM dereferenceClosure cs @@ -151,9 +157,15 @@   | not (heapAlloced cp) = dereferenceClosureDirect cp   | otherwise = do       rc <-  requestBlock (LookupClosure cp)-      let it = getInfoTblPtr rc-      st_it <- request (RequestInfoTable it)-      return $ decodeClosure st_it (cp, rc)+      if rawClosureSize rc < 8+        then do+          res <- dereferenceClosureDirect cp+          traceShowM ("Warning!!: block decoding failed, report this as a bug:" ++ show (cp, res))+          return res+        else do+          let it = getInfoTblPtr rc+          st_it <- request (RequestInfoTable it)+          decodeClosure st_it (cp, rc)  -- | Fetch all the blocks from the debuggee and add them to the block cache precacheBlocks :: DebugM [RawBlock]@@ -177,7 +189,7 @@ savedObjects = request RequestSavedObjects  -- | Query the debuggee for the protocol version-version :: DebugM Word32+version :: DebugM Version version = request RequestVersion  dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable

@@ -14,8 +14,6 @@ import Unsafe.Coerce import Data.Binary import Control.Monad-import Data.Binary.Put-import Data.Binary.Get  newtype RequestCache = RequestCache (HM.HashMap AnyReq AnyResp) @@ -43,7 +41,7 @@ -- amount of input.  getResponseBinary :: Request a -> Get a-getResponseBinary RequestVersion       = getWord32be+getResponseBinary RequestVersion       = Version <$> get <*> get getResponseBinary (RequestPause {})    = get getResponseBinary RequestResume        = get getResponseBinary RequestRoots         = get@@ -60,7 +58,7 @@ getResponseBinary RequestBlock {}  = get  putResponseBinary :: Request a -> a -> Put-putResponseBinary RequestVersion w = putWord32be w+putResponseBinary RequestVersion (Version w1 w2) = put w1 >> put w2 putResponseBinary (RequestPause {}) w  = put w putResponseBinary RequestResume w      = put w putResponseBinary RequestRoots  rs     = put rs

@@ -24,10 +24,10 @@ import Control.Monad.Reader import Data.Word import GHC.Debug.Client.Monad.Simple+import GHC.Debug.Client.Monad.Class import Control.Concurrent.Async import Data.IORef import Control.Exception.Base-import Debug.Trace import Control.Concurrent.STM  threads :: Int@@ -36,9 +36,6 @@ type InChan = TChan type OutChan = TChan -unsafeLiftIO :: IO a -> DebugM a-unsafeLiftIO = DebugM . liftIO- -- | State local to a thread, there are $threads spawned, each which deals -- with (address `div` 8) % threads. Each thread therefore: --@@ -219,7 +216,7 @@ -- lower. traceParFromM :: Monoid s => TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s traceParFromM k cps = do-  traceM ("SPAWNING: " ++ show threads)+  traceMsg ("SPAWNING: " ++ show threads)   (init_mblocks, work_actives, start)  <- unzip3 <$> mapM (\b -> do                                     (ti, working, start) <- initThread b k                                     return ((fromIntegral b, ti), working, start)) [0 .. threads - 1]@@ -246,7 +243,12 @@ tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ())   where     nop = const (return ())-    funcs = TraceFunctionsIO nop nop clos (const (const (return ()))) nop+    funcs = TraceFunctionsIO nop stack clos (const (const (return ()))) nop++    stack :: GenStackFrames ClosurePtr -> DebugM ()+    stack fs =+      let stack_frames = getFrames fs+      in mapM_ (getSourceInfo . tableId . frame_info) stack_frames      clos :: ClosurePtr -> SizedClosure -> ()               -> DebugM ((), (), DebugM () -> DebugM ())

@@ -1,6 +1,6 @@ {-# LANGUAGE ViewPatterns #-} -- | Functions for computing retainers-module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainers, addLocationToStack, displayRetainerStack) where+module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainers, addLocationToStack, displayRetainerStack, addLocationToStack', displayRetainerStack') where  import GHC.Debug.Client import Control.Monad.State@@ -23,10 +23,10 @@     bad_set = Set.fromList bads  findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]-findRetainersOfConstructor limit roots con_name =-  findRetainers limit roots go+findRetainersOfConstructor limit rroots con_name =+  findRetainers limit rroots go   where-    go cp sc =+    go _ sc =       case noSize sc of         ConstrClosure _ _ _ cd -> do           ConstrDesc _ _  cname <- dereferenceConDesc cd@@ -34,16 +34,16 @@         _ -> return $ False  findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]-findRetainersOfConstructorExact limit roots clos_name =-  findRetainers limit roots go+findRetainersOfConstructorExact limit rroots clos_name =+  findRetainers limit rroots go   where-    go cp sc = do+    go _ sc = do       loc <- getSourceInfo (tableId (info (noSize sc)))       case loc of         Nothing -> return False-        Just loc ->+        Just cur_loc -> -          return $ (infoName loc) == clos_name+          return $ (infoName cur_loc) == clos_name  -- | 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@@ -90,12 +90,33 @@   where     getSourceLoc c = getSourceInfo (tableId (info (noSize c))) +addLocationToStack' :: [ClosurePtr] -> DebugM [(ClosurePtr, SizedClosureC, Maybe SourceInformation)]+addLocationToStack' r = do+  cs <- dereferenceClosures r+  cs' <- mapM (quadtraverse pure dereferenceConDesc pure pure) cs+  locs <- mapM getSourceLoc cs'+  return $ (zip3 r cs' locs)+  where+    getSourceLoc c = getSourceInfo (tableId (info (noSize c)))+ displayRetainerStack :: [(String, [(SizedClosureC, Maybe SourceInformation)])] -> IO () displayRetainerStack rs = do       let disp (d, l) =             (ppClosure ""  (\_ -> show) 0 . noSize $ d) ++  " <" ++ maybe "nl" tdisplay l ++ ">"             where-              tdisplay sl = infoType sl ++ ":" ++ infoModule sl ++ ":" ++ infoPosition sl+              tdisplay sl = infoName sl ++ ":" ++ infoType sl ++ ":" ++ infoModule sl ++ ":" ++ infoPosition sl+          do_one k (l, stack) = do+            putStrLn (show k ++ "-------------------------------------")+            print l+            mapM (putStrLn . disp) stack+      zipWithM_ do_one [0 :: Int ..] rs++displayRetainerStack' :: [(String, [(ClosurePtr, SizedClosureC, Maybe SourceInformation)])] -> IO ()+displayRetainerStack' rs = do+      let disp (p, d, l) =+            show p ++ ": " ++ (ppClosure ""  (\_ -> show) 0 . noSize $ d) ++  " <" ++ maybe "nl" tdisplay l ++ ">"+            where+              tdisplay sl = infoName sl ++ ":" ++ infoType sl ++ ":" ++ infoModule sl ++ ":" ++ infoPosition sl           do_one k (l, stack) = do             putStrLn (show k ++ "-------------------------------------")             print l

@@ -18,6 +18,7 @@ snapshot :: FilePath -> DebugM () snapshot fp = do   precacheBlocks+  version   rs <- gcRoots   _so <- savedObjects   tracePar rs

@@ -0,0 +1,161 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+module GHC.Debug.Strings ( stringProgram, arrWordsProgram+                         , arrWordsAnalysis, stringAnalysis) where++import GHC.Debug.Client+import GHC.Debug.Types.Ptr+import GHC.Debug.Trace+import GHC.Debug.Profile.Types+import Control.Monad.RWS+import qualified Data.Foldable as F++import qualified Data.Text as T+import qualified Data.Text.IO as T++import qualified Data.Map as Map+import qualified Data.Set as S+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS (length)+import Data.Char+import Data.Ord+import Data.List++-- | Find all the strings and then print out how many duplicates there are+stringProgram :: Debuggee -> IO ()+arrWordsProgram :: Debuggee -> IO ()+stringProgram = programX length stringAnalysis+arrWordsProgram = programX (fromIntegral . BS.length) arrWordsAnalysis++programX :: Show a => (a -> Int) -> ([ClosurePtr] -> DebugM (Map.Map a (S.Set b))) -> Debuggee -> IO ()+programX sizeOf anal e = do+  pause e+  res <- runTrace e $ do+    precacheBlocks+    rs <- gcRoots+    res <- anal rs+    return res+  printResult (Map.map (\s -> Count (S.size s)) res)+  printResult (Map.mapWithKey (\k s -> Count (fromIntegral (sizeOf k) * (S.size s))) res)+  return ()++  {-+  let anal n = do+        let cools = fromJust (Map.lookup n res)+        print cools+        stacks <- run e $ do+          roots <- gcRoots+          rets <- findRetainersOf (Just (S.size cools)) roots (S.toList cools)+          rets' <- traverse (\c -> (show (head c),) <$> (addLocationToStack' c)) rets+          return rets'+        displayRetainerStack' stacks+        -}++-- | Find the parents of Bin nodes+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 ())+              , stackTrace = const (return ())+              , closTrace = closAccum+              , visitedVal = const (return ())+              , conDescTrace = const (return ())++            }++    -- First time we have visited a closure+    closAccum  :: ClosurePtr+               -> SizedClosure+               -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()+               -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()+    closAccum cp sc k = do+      case noSize sc of+        ConstrClosure _ _ _ cd -> do+          cd' <- lift $ dereferenceConDesc cd+          case cd' of+            ConstrDesc _ _ cd2 | cd2 == ":" -> do+              process cp sc+            _ -> local (const False) k+        _  -> local (const False) k+      where+        process :: ClosurePtr -> SizedClosure+                -> (RWST Bool () (Map.Map String (S.Set ClosurePtr)) DebugM) ()+        process p_cp clos = do+          clos' <- lift $ quadtraverse pure dereferenceConDesc return return (noSize clos)+          checked <- lift $ check_bin clos'+          if checked+            then do+              parent_is_cons <- ask+              if parent_is_cons+                then local (const True) k+                else do+                  ds <- lift $ decodeString p_cp+                  modify' (Map.insertWith (<>) ds (S.singleton p_cp))+                  local (const True) k+            else local (const False) k++        process_2 p_cp = do+          cp' <- dereferenceClosure p_cp+          case noSize cp' of+            (ConstrClosure _ _ _ cd) -> do+              (ConstrDesc _ _ cn) <- dereferenceConDesc cd+              return (cn == "C#")+            _ -> return False++        check_bin (ConstrClosure _ [h,_] _ (ConstrDesc _ _ ":")) = process_2 h+        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 []+    _ -> return []+++printResult :: Show a => Map.Map a Count -> IO [a]+printResult m = do+  putStrLn $ "TOTAL: " ++ show total+  mapM_ show_line top10+  return (map fst top10)+  where+    show_line (k, Count v) = T.putStrLn (T.pack (show k) <> ": " <> T.pack (show v))+    top10 = take 1000 $ reverse (sortBy (comparing snd) (Map.toList m))+    total = F.fold (Map.elems m)++-- | Find how many distinct ArrWords there are+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 ())+              , stackTrace = const (return ())+              , closTrace = closAccum+              , visitedVal = const (return ())+              , conDescTrace = const (return ())++            }++    -- First time we have visited a closure+    closAccum  :: ClosurePtr+               -> SizedClosure+               -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()+               -> (RWST () () (Map.Map ByteString (S.Set ClosurePtr)) DebugM) ()+    closAccum cp sc k = do+          case (noSize sc) of+            ArrWordsClosure _ _ p ->  do+              modify' (Map.insertWith (<>) (arrWordsBS p) (S.singleton cp))+              k+            _ -> k

@@ -13,7 +13,6 @@ import Control.Monad.Reader import Data.IORef import Data.Word-import System.IO  newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16)) @@ -27,7 +26,7 @@       offset = getBlockOffset cp `div` 8   in (bk, fromIntegral offset) -checkVisit :: ClosurePtr -> IORef TraceState -> IO Bool+checkVisit :: ClosurePtr -> IORef TraceState -> IO (Maybe Int, Bool) checkVisit cp mref = do   st <- readIORef mref   let VisitedSet v = visited st@@ -38,12 +37,11 @@       na <- newArray (0, fromIntegral (blockMask `div` 8)) False       writeArray na offset True       writeIORef mref (TraceState (VisitedSet (IM.insert bk na v)) (num_visited + 1))-      when (num_visited `mod` 10_000 == 0) $ hPutStrLn stderr ("Traced: " ++ show num_visited)-      return False+      return (Just num_visited, False)     Just bm -> do       res <- readArray bm offset       unless res (writeArray bm offset True)-      return res+      return (Nothing, res)   @@ -79,7 +77,9 @@   where     go cp = do       mref <- ask-      b <- lift $ lift $ unsafeLiftIO (checkVisit cp mref)+      (mnum_visited, b) <- lift $ lift $ unsafeLiftIO (checkVisit cp mref)+      forM_ mnum_visited $ \num_visited ->+        lift $ lift $ when (num_visited `mod` 10_000 == 0) $ traceMsg ("Traced: " ++ show num_visited)       if b         then lift $ visitedVal k cp         else do

@@ -148,6 +148,7 @@       Nothing -> getKeyFallback itblp itbl       Just s -> return $ show (tipe itbl) ++ ":" ++ renderSourceInfo s +getKeyFallback :: ConstrDescCont -> StgInfoTable -> DebugM String getKeyFallback itbp itbl = do     case tipe itbl of       t | CONSTR <= t && t <= CONSTR_NOCAF   -> do