diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for ghc-debug-client -## 0.1.0.0 -- YYYY-mm-dd +## 0.2.0.0 -- 2021-12-06 -* First version. Released on an unsuspecting world. +* Second version. + +## 0.1.0.0 -- 2021-06-14 + +* First version. 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.1.0.0 +version: 0.2.0.0 synopsis: Useful functions for writing heap analysis tools which use ghc-debug. description: Useful functions for writing heap analysis tools which use @@ -35,21 +35,19 @@ GHC.Debug.Client.BlockCache, GHC.Debug.Client.RequestCache, GHC.Debug.Client.Monad.Class, - GHC.Debug.Client.Monad.Haxl, GHC.Debug.Client.Monad.Simple build-depends: base >=4.16 && < 4.17, network >= 2.6 , containers ^>= 0.6, unordered-containers ^>= 0.2.13, - ghc-debug-common ^>= 0.1, - ghc-debug-convention ^>= 0.1, + ghc-debug-common ^>= 0.2, + ghc-debug-convention ^>= 0.2, text ^>= 1.2.4, process ^>= 1.6, filepath ^>= 1.4, directory ^>= 1.3, bitwise ^>= 1.0, - haxl ^>= 2.3, hashable ^>= 1.3, mtl ^>= 2.2, eventlog2html >= 0.8.3, 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 @@ -34,12 +34,9 @@ import System.Environment import GHC.Debug.Client.Monad.Class import GHC.Debug.Types (Request(..)) -import qualified GHC.Debug.Client.Monad.Haxl as H import qualified GHC.Debug.Client.Monad.Simple as S import System.IO --- Modify this to switch between the haxl/non-haxl implementations --- type DebugM = H.DebugM type DebugM = S.DebugM newtype Debuggee = Debuggee { debuggeeEnv :: DebugEnv DebugM } diff --git a/src/GHC/Debug/Client/Monad/Haxl.hs b/src/GHC/Debug/Client/Monad/Haxl.hs deleted file mode 100644 --- a/src/GHC/Debug/Client/Monad/Haxl.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module GHC.Debug.Client.Monad.Haxl - ( Debuggee(..) - , Request(..) - , DebugM - , Env(..) - ) where - -import GHC.Debug.Types -import qualified Data.HashMap.Strict as HM -import System.IO -import Control.Concurrent - -import GHC.Debug.Client.BlockCache -import GHC.Debug.Client.Monad.Class - -import Haxl.Core hiding (Request, env) -import Data.Typeable - -import Data.IORef - -data Debuggee = Debuggee { -- Keep track of how many of each request we make - debuggeeRequestCount :: IORef (HM.HashMap CommandId Int) - , debuggeeBatchMode :: BatchMode - } - -data BatchMode = Batch | OneByOne deriving (Eq, Show) - -instance DebugMonad (GenHaxl Debuggee String) where - type DebugEnv (GenHaxl Debuggee String) = Env Debuggee String - request = dataFetch - requestBlock = dataFetch - traceMsg = tellWrite - printRequestLog = traceRequestLog - runDebug = runHaxl - runDebugTrace = runHaxlWithWrites - newEnv args = - case args of - SnapshotMode _e -> error "Loading from snapshot not supported" - SocketMode h -> mkEnv h - - saveCache = error "TODO" - loadCache = error "TODO" - unsafeLiftIO = error "TODO" - -type DebugM = GenHaxl Debuggee String - - -{- MP: -- In some profiles it seemed that the caching step was causing quite a bit -- of overhead, but still using the cache is about 2-3x faster than without -- a cache. (ie using `doRequest` directly or `uncachedRequest`. --} - --- | Send a request to a 'Debuggee' paused with 'withPause'. ---request :: (Show resp, Typeable resp) => Request resp -> DebugM resp ---request = dataFetch - - -instance StateKey Request where - data State Request = RequestState (MVar Handle) - -instance DataSourceName Request where - dataSourceName Proxy = "ghc-debug" - -instance ShowP Request where - showp = show - -{- --- | Group together RequestClosures and RequestInfoTables to avoid --- some context switching. -groupFetches :: MVar Handle -> [([ClosurePtr], ResultVar [RawClosure])] -> [([InfoTablePtr], ResultVar [(StgInfoTableWithPtr, RawInfoTable)])] -> [BlockedFetch Request] -> [BlockedFetch Request] -> IO () -groupFetches h cs is todo [] = dispatch h cs is (reverse todo) -groupFetches h cs is todo (b@(BlockedFetch r resp) : bs) = - case r of - RequestInfoTables is' -> groupFetches h cs ((is', resp):is) todo bs - RequestClosures cs' -> groupFetches h ((cs', resp):cs) is todo bs - _ -> groupFetches h cs is (b:todo) bs - -dispatch :: MVar Handle - -> [([ClosurePtr], ResultVar [RawClosure])] - -> [([InfoTablePtr], ResultVar [(StgInfoTableWithPtr, RawInfoTable)])] - -> [BlockedFetch Request] - -> IO () -dispatch h cs its other = do - mapM_ do_one other - -- These can be used to inspect how much batching is happening --- print ("BATCHED_CLOSURES", length cs, map fst cs) --- print (length its, map fst its) - do_many RequestClosures cs - do_many RequestInfoTables its - where - do_one (BlockedFetch req resp) = do - res <- doRequest h req - putSuccess resp res - - do_many :: ([a] -> Request [b]) -> [([a], ResultVar [b])] -> IO () - do_many _ [] = return () - do_many mk_req ms = do - let req = mk_req (concatMap fst ms) - results <- doRequest h req - recordResults results ms - - - --- | Write the correct number of results to each result var -recordResults :: [a] -> [([b], ResultVar [a])] -> IO () -recordResults [] [] = return () -recordResults res ((length -> n, rvar):xs) = - putSuccess rvar here >> recordResults later xs - where - (here, later) = splitAt n res -recordResults _ _ = error ("Impossible recordResults") --} - -_singleFetches :: MVar Handle -> [BlockedFetch Request] -> IO () -_singleFetches h bs = mapM_ do_one bs - where - do_one (BlockedFetch req resp) = do - res <- doRequest h req - putSuccess resp res - -instance DataSource Debuggee Request where - fetch (RequestState h) _fs u = - -- Grouping together fetches only shaves off about 0.01s on the simple - -- benchmark - SyncFetch $ - case debuggeeBatchMode u of - --Batch -> groupFetches h [] [] [] - _ -> _singleFetches h - - - -instance StateKey BlockCacheRequest where - data State BlockCacheRequest = BCRequestState (IORef BlockCache) (MVar Handle) - -instance DataSourceName BlockCacheRequest where - dataSourceName Proxy = "block-cache" - -instance ShowP BlockCacheRequest where - showp = show - - -instance DataSource u BlockCacheRequest where - fetch (BCRequestState ref h) _fs _u = - SyncFetch (mapM_ do_one) - where - do_one :: BlockedFetch BlockCacheRequest -> IO () - do_one (BlockedFetch bcr resp) = do - res <- handleBlockReq (doRequest h) ref bcr - putSuccess resp res - - - -mkEnv :: Handle -> IO (Env Debuggee String) -mkEnv hdl = do - requestMap <- newIORef HM.empty - bc <- newIORef emptyBlockCache - mhdl <- newMVar hdl - let ss = stateSet (BCRequestState bc mhdl) (stateSet (RequestState mhdl) stateEmpty) - new_env <- initEnv ss (Debuggee requestMap Batch) - -- Turn on data fetch stats with report = 3 - let new_flags = defaultFlags { report = 0 } - return $ new_env { Haxl.Core.flags = new_flags } - --- | Print out the number of request made for each request type -traceRequestLog :: Env u w -> IO () -traceRequestLog d = do - s <- readIORef (statsRef d) - putStrLn (ppStats s) - -_traceProfile :: Env u w -> IO () -_traceProfile e = do - p <- readIORef (profRef e) - print (profile p) 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,5 +1,6 @@ +{-# LANGUAGE ViewPatterns #-} -- | Functions for computing retainers -module GHC.Debug.Retainers(findRetainersOf, findRetainers, addLocationToStack, displayRetainerStack) where +module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainers, addLocationToStack, displayRetainerStack) where import GHC.Debug.Client import Control.Monad.State @@ -21,6 +22,27 @@ where bad_set = Set.fromList bads +findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]] +findRetainersOfConstructor limit roots con_name = + findRetainers limit roots go + where + go cp sc = + case noSize sc of + ConstrClosure _ _ _ cd -> do + ConstrDesc _ _ cname <- dereferenceConDesc cd + return $ cname == con_name + _ -> return $ False + +findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]] +findRetainersOfConstructorExact limit roots clos_name = + findRetainers limit roots go + where + go cp sc = do + loc <- getSourceInfo (tableId (info (noSize sc))) + case loc of + Nothing -> return False + Just loc -> return $ infoLabel 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 -- how many paths to find. You should normally set this to a small number @@ -41,12 +63,14 @@ -> SizedClosure -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM () -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM () + closAccum _ (noSize -> WeakClosure {}) _ = return () closAccum cp sc k = do b <- lift $ p cp sc 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