diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/ghc-debug-client.cabal b/ghc-debug-client.cabal --- a/ghc-debug-client.cabal +++ b/ghc-debug-client.cabal @@ -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 diff --git a/src/GHC/Debug/Client.hs b/src/GHC/Debug/Client.hs --- a/src/GHC/Debug/Client.hs +++ b/src/GHC/Debug/Client.hs @@ -12,7 +12,7 @@ precacheBlocks (r:_) <- gcRoots buildHeapGraph (Just 10) r - putStrLn (ppHeapGraph (const "") h) + putStrLn (ppHeapGraph (const "") g) @ -} diff --git a/src/GHC/Debug/Client/Monad.hs b/src/GHC/Debug/Client/Monad.hs --- a/src/GHC/Debug/Client/Monad.hs +++ b/src/GHC/Debug/Client/Monad.hs @@ -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'. diff --git a/src/GHC/Debug/Client/Monad/Class.hs b/src/GHC/Debug/Client/Monad/Class.hs --- a/src/GHC/Debug/Client/Monad/Class.hs +++ b/src/GHC/Debug/Client/Monad/Class.hs @@ -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 () diff --git a/src/GHC/Debug/Client/Monad/Simple.hs b/src/GHC/Debug/Client/Monad/Simple.hs --- a/src/GHC/Debug/Client/Monad/Simple.hs +++ b/src/GHC/Debug/Client/Monad/Simple.hs @@ -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. diff --git a/src/GHC/Debug/Client/Query.hs b/src/GHC/Debug/Client/Query.hs --- a/src/GHC/Debug/Client/Query.hs +++ b/src/GHC/Debug/Client/Query.hs @@ -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 diff --git a/src/GHC/Debug/Client/RequestCache.hs b/src/GHC/Debug/Client/RequestCache.hs --- a/src/GHC/Debug/Client/RequestCache.hs +++ b/src/GHC/Debug/Client/RequestCache.hs @@ -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 diff --git a/src/GHC/Debug/ParTrace.hs b/src/GHC/Debug/ParTrace.hs --- a/src/GHC/Debug/ParTrace.hs +++ b/src/GHC/Debug/ParTrace.hs @@ -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 ()) diff --git a/src/GHC/Debug/Retainers.hs b/src/GHC/Debug/Retainers.hs --- a/src/GHC/Debug/Retainers.hs +++ b/src/GHC/Debug/Retainers.hs @@ -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 diff --git a/src/GHC/Debug/Snapshot.hs b/src/GHC/Debug/Snapshot.hs --- a/src/GHC/Debug/Snapshot.hs +++ b/src/GHC/Debug/Snapshot.hs @@ -18,6 +18,7 @@ snapshot :: FilePath -> DebugM () snapshot fp = do precacheBlocks + version rs <- gcRoots _so <- savedObjects tracePar rs diff --git a/src/GHC/Debug/Strings.hs b/src/GHC/Debug/Strings.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Strings.hs @@ -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 diff --git a/src/GHC/Debug/Trace.hs b/src/GHC/Debug/Trace.hs --- a/src/GHC/Debug/Trace.hs +++ b/src/GHC/Debug/Trace.hs @@ -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 diff --git a/src/GHC/Debug/TypePointsFrom.hs b/src/GHC/Debug/TypePointsFrom.hs --- a/src/GHC/Debug/TypePointsFrom.hs +++ b/src/GHC/Debug/TypePointsFrom.hs @@ -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