ghc-debug-client 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+34/−194 lines, 5 filesdep −haxldep ~ghc-debug-commondep ~ghc-debug-conventiondep ~hashablePVP ok

version bump matches the API change (PVP)

Dependencies removed: haxl

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

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−2
• ghc-debug-client.cabal +3/−5
• src/GHC/Debug/Client/Monad.hs +0/−3
• src/GHC/Debug/Client/Monad/Haxl.hs +0/−183
• src/GHC/Debug/Retainers.hs +25/−1

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

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

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

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

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