diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ghc-debug-client + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Ben Gamari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ben Gamari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ghc-debug-client.cabal b/ghc-debug-client.cabal new file mode 100644 --- /dev/null +++ b/ghc-debug-client.cabal @@ -0,0 +1,68 @@ +cabal-version: 3.0 +name: ghc-debug-client +version: 0.1.0.0 +synopsis: Useful functions for writing heap analysis tools which use + ghc-debug. +description: Useful functions for writing heap analysis tools which use + ghc-debug. +homepage: https://gitlab.haskell.org/ghc/ghc-debug +license: BSD-3-Clause +license-file: LICENSE +author: Ben Gamari, Matthew Pickering, David Eichmann +maintainer: matthewtpickering@gmail.com +copyright: (c) 2019-2021 Ben Gamari, Matthew Pickering +category: Development +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: GHC.Debug.Client, + GHC.Debug.Retainers, + GHC.Debug.GML, + GHC.Debug.Fragmentation, + GHC.Debug.ObjectEquiv, + GHC.Debug.Client.Search, + GHC.Debug.Profile, + GHC.Debug.Profile.Types, + GHC.Debug.Trace, + GHC.Debug.ParTrace, + GHC.Debug.Count, + GHC.Debug.TypePointsFrom, + GHC.Debug.Snapshot, + GHC.Debug.Dominators, + GHC.Debug.Client.Query, + GHC.Debug.Client.Monad, + 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, + 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, + binary ^>= 0.8, + psqueues ^>= 0.2, + dom-lt ^>= 0.2, + async ^>= 2.2, + monoidal-containers >= 0.6, + language-dot ^>= 0.1, + ghc-prim ^>= 0.8, + stm ^>= 2.5 + + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: ApplicativeDo + ghc-options: -Wall diff --git a/src/GHC/Debug/Client.hs b/src/GHC/Debug/Client.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client.hs @@ -0,0 +1,124 @@ +{- | The main API for creating debuggers. For example, this API can be used +to connect to an instrumented process, query the GC roots and then decode +the first root up to depth 10 and displayed to the user. + +@ +main = withDebuggeeConnect "\/tmp\/ghc-debug" p1 + +p1 :: Debuggee -> IO () +p1 e = do + pause e + g <- run e $ do + precacheBlocks + (r:_) <- gcRoots + buildHeapGraph (Just 10) r + putStrLn (ppHeapGraph (const "") h) +@ + +-} +module GHC.Debug.Client + ( -- * Running/Connecting to a debuggee + Debuggee + , DebugM + , debuggeeRun + , debuggeeConnect + , debuggeeClose + , withDebuggeeRun + , withDebuggeeConnect + , socketDirectory + , snapshotRun + + -- * Running DebugM + , run + , runTrace + , runAnalysis + + -- * Pause/Resume + , pause + , fork + , pauseThen + , resume + , pausePoll + , withPause + + -- * Basic Requests + , version + , gcRoots + , allBlocks + , getSourceInfo + , savedObjects + , precacheBlocks + , dereferenceClosure + , dereferenceClosures + , dereferenceStack + , dereferencePapPayload + , dereferenceConDesc + , dereferenceInfoTable + + , Quadtraversable(..) + + -- * Building a Heap Graph + , buildHeapGraph + , multiBuildHeapGraph + , HG.HeapGraph(..) + , HG.HeapGraphEntry(..) + + -- * Printing a heap graph + , HG.ppHeapGraph + + -- * Tracing + , traceWrite + , traceMsg + + -- * Caching + , saveCache + , loadCache + + -- * Types + , module GHC.Debug.Types.Closures + , SourceInformation(..) + , RawBlock(..) + , BlockPtr + , StackPtr + , ClosurePtr + , InfoTablePtr + , HG.StackHI + , HG.PapHI + , HG.HeapGraphIndex + ) where + +import GHC.Debug.Types +import GHC.Debug.Types.Closures +import GHC.Debug.Convention (socketDirectory) +import GHC.Debug.Client.Monad +import GHC.Debug.Client.Query +import qualified GHC.Debug.Types.Graph as HG +import Data.List.NonEmpty (NonEmpty) + +derefFuncM :: HG.DerefFunction DebugM Size +derefFuncM c = do + c' <- dereferenceClosure c + quadtraverse dereferencePapPayload dereferenceConDesc 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 +-- to a small number ~ 10, as otherwise you can easily run out of memory. +buildHeapGraph :: Maybe Int -> ClosurePtr -> DebugM (HG.HeapGraph Size) +buildHeapGraph = HG.buildHeapGraph derefFuncM + +-- | Build a heap graph starting from multiple roots. The first argument +-- controls how many levels to recurse. You nearly always want to set this +-- value to a small number ~ 10 as otherwise you can easily run out of +-- memory. +multiBuildHeapGraph :: Maybe Int -> NonEmpty ClosurePtr -> DebugM (HG.HeapGraph Size) +multiBuildHeapGraph = HG.multiBuildHeapGraph derefFuncM + +-- | Perform the given analysis whilst the debuggee is paused, then resume +-- and apply the continuation to the result. +runAnalysis :: DebugM a -> (a -> IO r) -> Debuggee -> IO r +runAnalysis a k e = do + pause e + r <- run e a + resume e + k r + diff --git a/src/GHC/Debug/Client/BlockCache.hs b/src/GHC/Debug/Client/BlockCache.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/BlockCache.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE RankNTypes #-} +-- The BlockCache stores the currently fetched blocks +-- and is consulted first to avoid requesting too much +-- from the debuggee. The BlockCache can either be populated +-- via a call to RequestBlocks or on demand on a cache miss. + +module GHC.Debug.Client.BlockCache(BlockCache, BlockCacheRequest(..) + , handleBlockReq, emptyBlockCache, bcSize, addBlocks) where + +import GHC.Debug.Types.Ptr +import GHC.Debug.Types +import qualified Data.HashMap.Strict as HM +import GHC.Word +import Data.Hashable +import Data.IORef +import Data.Bits +import Data.List (sort) +import Data.Binary + +newtype BlockCache = BlockCache (HM.HashMap Word64 RawBlock) + +instance Binary BlockCache where + get = BlockCache . HM.fromList <$> get + put (BlockCache hm) = put (HM.toList hm) + +emptyBlockCache :: BlockCache +emptyBlockCache = BlockCache HM.empty + +addBlock :: RawBlock -> BlockCache -> BlockCache +addBlock rb@(RawBlock (BlockPtr bp) _ _) (BlockCache bc) = + BlockCache (HM.insert bp rb bc) + + +addBlocks :: [RawBlock] -> BlockCache -> BlockCache +addBlocks bc bs = Prelude.foldr addBlock bs bc + +lookupClosure :: ClosurePtr -> BlockCache -> Maybe RawBlock +lookupClosure (ClosurePtr cp) (BlockCache b) = + HM.lookup (cp .&. complement blockMask) b + +bcSize :: BlockCache -> Int +bcSize (BlockCache b) = HM.size b + +_bcKeys :: BlockCache -> [ClosurePtr] +_bcKeys (BlockCache b) = sort $ map mkClosurePtr (HM.keys b) + +data BlockCacheRequest a where + LookupClosure :: ClosurePtr -> BlockCacheRequest RawClosure + PopulateBlockCache :: BlockCacheRequest [RawBlock] + +deriving instance Show (BlockCacheRequest a) +deriving instance Eq (BlockCacheRequest a) + +instance Hashable (BlockCacheRequest a) where + hashWithSalt s (LookupClosure cpt) = s `hashWithSalt` (1 :: Int) `hashWithSalt` cpt + hashWithSalt s PopulateBlockCache = s `hashWithSalt` (2 :: Int) + +handleBlockReq :: (forall a . Request a -> IO a) -> IORef BlockCache -> BlockCacheRequest resp -> IO resp +handleBlockReq do_req ref (LookupClosure cp) = do + bc <- readIORef ref + let mrb = lookupClosure cp bc + rb <- case mrb of + Nothing -> do + rb <- do_req (RequestBlock cp) + atomicModifyIORef' ref (\bc' -> (addBlock rb bc', ())) + return rb + Just rb -> do + return rb + return (extractFromBlock cp rb) +handleBlockReq do_req ref PopulateBlockCache = do + blocks <- do_req RequestAllBlocks +-- mapM_ (\rb -> print ("NEW", rawBlockAddr rb)) blocks + print ("CACHING", length blocks) + atomicModifyIORef' ref ((,()) . addBlocks blocks) + return blocks + + + diff --git a/src/GHC/Debug/Client/Monad.hs b/src/GHC/Debug/Client/Monad.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/Monad.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module GHC.Debug.Client.Monad + ( DebugMonad(..) + , run + , DebugM + , Debuggee + , traceWrite + , runTrace + -- * Running/Connecting to a debuggee + , withDebuggeeRun + , withDebuggeeConnect + , debuggeeRun + , debuggeeConnect + , debuggeeClose + -- * Snapshot run + , snapshotInit + , snapshotRun + -- * Logging + , outputRequestLog + ) where + +import Control.Exception (finally) +import Network.Socket +import System.Process +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 } + +runTrace :: Debuggee -> DebugM a -> IO a +runTrace (Debuggee e) act = do + (r, ws) <- runDebugTrace e act + mapM_ putStrLn ws + return r + +traceWrite :: DebugMonad m => Show a => a -> m () +traceWrite = traceMsg . show + +-- | Run a @DebugM a@ in the given environment. +run :: Debuggee -> DebugM a -> IO a +run (Debuggee d) = runDebug d + +-- | Bracketed version of @debuggeeRun@. Runs a debuggee, connects to it, runs +-- the action, kills the process, then closes the debuggee. +withDebuggeeRun :: FilePath -- ^ path to executable to run as the debuggee + -> FilePath -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@) + -> (Debuggee -> IO a) + -> IO a +withDebuggeeRun exeName socketName action = do + -- Start the process we want to debug + cp <- debuggeeProcess exeName socketName + withCreateProcess cp $ \_ _ _ _ -> do + -- Now connect to the socket the debuggeeProcess just started + withDebuggeeConnect socketName action + +-- | Bracketed version of @debuggeeConnect@. Connects to a debuggee, runs the +-- action, then closes the debuggee. +withDebuggeeConnect :: FilePath -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@) + -> (Debuggee -> IO a) + -> IO a +withDebuggeeConnect socketName action = do + new_env <- debuggeeConnect socketName + action new_env + `finally` + debuggeeClose new_env + +-- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done. +debuggeeRun :: FilePath -- ^ path to executable to run as the debuggee + -> FilePath -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@) + -> IO Debuggee +debuggeeRun exeName socketName = do + -- Start the process we want to debug + _ <- createProcess =<< debuggeeProcess exeName socketName + -- Now connect to the socket the debuggeeProcess just started + debuggeeConnect socketName + +-- | Connect to a debuggee on the given socket. Use @debuggeeClose@ when you're done. +debuggeeConnect :: FilePath -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@) + -> IO Debuggee +debuggeeConnect socketName = do + s <- socket AF_UNIX Stream defaultProtocol + connect s (SockAddrUnix socketName) + hdl <- socketToHandle s ReadWriteMode + new_env <- newEnv @DebugM (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) + +-- | Start an analysis session using a snapshot. This will not connect to a +-- debuggee. The snapshot is created by 'snapshot'. +snapshotRun :: FilePath -> (Debuggee -> IO a) -> IO a +snapshotRun fp k = do + denv <- snapshotInit fp + k denv + +-- | Close the connection to the debuggee. +debuggeeClose :: Debuggee -> IO () +debuggeeClose d = run d $ request RequestResume + +debuggeeProcess :: FilePath -> FilePath -> IO CreateProcess +debuggeeProcess exe sockName = do + e <- getEnvironment + return $ + (proc exe []) { env = Just (("GHC_DEBUG_SOCKET", sockName) : e) } + +outputRequestLog :: Debuggee -> IO () +outputRequestLog = printRequestLog @DebugM . debuggeeEnv + diff --git a/src/GHC/Debug/Client/Monad/Class.hs b/src/GHC/Debug/Client/Monad/Class.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/Monad/Class.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module GHC.Debug.Client.Monad.Class where + +import Data.Typeable +import GHC.Debug.Client.BlockCache +import GHC.Debug.Types +import System.IO + +class (MonadFail m, Monad m) => DebugMonad m where + type DebugEnv m + request :: (Show resp, Typeable resp) => Request resp -> m resp + requestBlock :: (Show resp, Typeable resp) => BlockCacheRequest resp -> m resp + traceMsg :: String -> m () + printRequestLog :: DebugEnv m -> IO () + runDebug :: DebugEnv m -> m a -> IO a + runDebugTrace :: DebugEnv m -> m a -> IO (a, [String]) + newEnv :: Mode -> IO (DebugEnv m) + + saveCache :: FilePath -> m () + loadCache :: FilePath -> m () + + unsafeLiftIO :: IO a -> m a + + +data Mode = SnapshotMode FilePath | SocketMode Handle diff --git a/src/GHC/Debug/Client/Monad/Haxl.hs b/src/GHC/Debug/Client/Monad/Haxl.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/Monad/Haxl.hs @@ -0,0 +1,183 @@ +{-# 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/Client/Monad/Simple.hs b/src/GHC/Debug/Client/Monad/Simple.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/Monad/Simple.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +-- | This module provides a simple implementation, which can be a lot faster if +-- network latency is not an issue. +module GHC.Debug.Client.Monad.Simple + ( Debuggee + , DebugM(..) + , runSimple + ) where + +import Control.Concurrent +import GHC.Debug.Types +import qualified Data.HashMap.Strict as HM +import System.IO +import Data.IORef +import Data.List +import Data.Ord + +import GHC.Debug.Client.BlockCache +import GHC.Debug.Client.RequestCache +import GHC.Debug.Client.Monad.Class + +import Control.Monad.Fix +import Control.Monad.Reader +import Data.Binary +--import Debug.Trace + + +data Debuggee = Debuggee { -- Keep track of how many of each request we make + debuggeeRequestCount :: Maybe (IORef (HM.HashMap CommandId FetchStats)) + , debuggeeBlockCache :: IORef BlockCache + , debuggeeRequestCache :: MVar RequestCache + , debuggeeHandle :: Maybe (MVar Handle) + } + +data FetchStats = FetchStats { _networkRequests :: !Int, _cachedRequests :: !Int } + +logRequestIO :: Bool -> IORef (HM.HashMap CommandId FetchStats) -> Request resp -> IO () +logRequestIO cached hmref req = + atomicModifyIORef' hmref ((,()) . HM.alter alter_fn (requestCommandId req)) + + where + alter_fn = Just . maybe emptyFetchStats upd_fn + emptyFetchStats = FetchStats 1 0 + upd_fn (FetchStats nr cr) + | cached = FetchStats nr (cr + 1) + | otherwise = FetchStats (nr + 1) cr + +logRequest :: Bool -> Request resp -> ReaderT Debuggee IO () +logRequest cached req = do + mhm <- asks debuggeeRequestCount + case mhm of + Just hm -> liftIO $ logRequestIO cached hm req + Nothing -> return () + +ppRequestLog :: HM.HashMap CommandId FetchStats -> String +ppRequestLog hm = unlines (map row items) + where + row (cid, FetchStats net cache) = unwords [show cid ++ ":", show net, show cache] + items = sortBy (comparing fst) (HM.toList hm) + +data Snapshot = Snapshot { + _version :: Word32 + , _rqc :: RequestCache + } + +snapshotVersion :: Word32 +snapshotVersion = 0 + +instance Binary Snapshot where + get = do + v <- get + if v == snapshotVersion + then Snapshot v <$> get + else fail ("Wrong snapshot version.\nGot: " ++ show v ++ "\nExpected: " ++ show snapshotVersion) + put (Snapshot v c1) = do + put v + put c1 + + +instance DebugMonad DebugM where + type DebugEnv DebugM = Debuggee + request = DebugM . simpleReq + requestBlock = blockReq + traceMsg = DebugM . liftIO . putStrLn + printRequestLog e = do + case debuggeeRequestCount e of + Just hm_ref -> do + readIORef hm_ref >>= putStrLn . ppRequestLog + 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 + + loadCache fp = DebugM $ do + (Snapshot _ new_req_cache) <- lift $ decodeFile fp + Debuggee{..} <- ask + _old_rc <- lift $ swapMVar debuggeeRequestCache new_req_cache + -- Fill up the block cache with the cached blocks + let block_c = initBlockCacheFromReqCache new_req_cache + lift $ writeIORef debuggeeBlockCache block_c + + saveCache fp = DebugM $ do + Debuggee{..} <- ask + Just req_cache <- lift $ tryReadMVar debuggeeRequestCache + lift $ encodeFile fp (Snapshot snapshotVersion req_cache) + + unsafeLiftIO f = DebugM $ liftIO f + + +initBlockCacheFromReqCache :: RequestCache -> BlockCache +initBlockCacheFromReqCache new_req_cache = + case lookupReq RequestAllBlocks new_req_cache of + Just bs -> addBlocks bs emptyBlockCache + Nothing -> emptyBlockCache + + + +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 + 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 + +mkHandleEnv :: Handle -> IO Debuggee +mkHandleEnv h = mkEnv (emptyRequestCache, emptyBlockCache) (Just h) + +mkSnapshotEnv :: FilePath -> IO Debuggee +mkSnapshotEnv fp = do + Snapshot _ req_c <- decodeFile fp + let block_c = initBlockCacheFromReqCache req_c + mkEnv (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. +simpleReq :: Request resp -> ReaderT Debuggee IO resp +simpleReq req | isWriteRequest req = ask >>= \Debuggee{..} -> liftIO $ withWriteRequest req (error "non-write") $ \wreq -> do + case debuggeeHandle of + Just h -> do + atomicModifyIORef' debuggeeBlockCache (const (emptyBlockCache, ())) + modifyMVar_ debuggeeRequestCache (return . clearMovableRequests) + doRequest h wreq + -- Ignore write requests in snapshot mode + Nothing -> return () +simpleReq req = do + rc_var <- asks debuggeeRequestCache + rc <- liftIO $ readMVar rc_var + case lookupReq req rc of + Just res -> do + logRequest True req + return res + Nothing -> do + mh <- asks debuggeeHandle + case mh of + Nothing -> error ("Cache Miss:" ++ show req) + Just h -> do + res <- liftIO $ doRequest h req + liftIO $ modifyMVar_ rc_var (return . cacheReq req res) + logRequest False req + return res + +blockReq :: BlockCacheRequest resp -> DebugM resp +blockReq req = DebugM $ do + bc <- asks debuggeeBlockCache + env <- ask + liftIO $ handleBlockReq (\r -> runReaderT (simpleReq r) env) bc req + +newtype DebugM a = DebugM (ReaderT Debuggee IO a) + -- Only derive the instances that DebugMonad needs + deriving (MonadFail, Functor, Applicative, Monad, MonadFix) + + diff --git a/src/GHC/Debug/Client/Query.hs b/src/GHC/Debug/Client/Query.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/Query.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +module GHC.Debug.Client.Query + ( -- * Pause/Resume + pause + , fork + , pauseThen + , resume + , pausePoll + , withPause + + -- * General Requests + , precacheBlocks + , gcRoots + , allBlocks + , getSourceInfo + , savedObjects + , version + + -- * Dereferencing functions + , dereferenceClosures + , dereferenceClosure + , dereferenceClosureDirect + , dereferenceClosureC + , dereferenceStack + , dereferencePapPayload + , dereferenceConDesc + , dereferenceInfoTable + + ) where + +import Control.Exception +import GHC.Debug.Types +import GHC.Debug.Decode +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 + +-- | Pause the debuggee +pause :: Debuggee -> IO () +pause e = do + run e $ request (RequestPause Pause) + +fork :: Debuggee -> IO () +fork e = do + run e $ request (RequestPause Fork) + +-- | Resume the debuggee +resume :: Debuggee -> IO () +resume e = run e $ request RequestResume + +-- | Like pause, but wait for the debuggee to pause itself. It currently +-- impossible to resume after a pause caused by a poll.?????????? Is that true???? can we not just call resume???? +pausePoll :: Debuggee -> IO () +pausePoll e = do + run e $ request RequestPoll + +-- | Bracketed version of pause/resume. +withPause :: Debuggee -> IO a -> IO a +withPause dbg act = bracket_ (pause dbg) (resume dbg) act + + +lookupInfoTable :: RawClosure -> DebugM (StgInfoTableWithPtr, RawInfoTable, RawClosure) +lookupInfoTable rc = do + let ptr = getInfoTblPtr rc + (itbl, rit) <- request (RequestInfoTable ptr) + return (itbl,rit, rc) + +pauseThen :: Debuggee -> DebugM b -> IO b +pauseThen e d = + pause e >> run e d + + +dereferenceClosureC :: ClosurePtr -> DebugM SizedClosureC +dereferenceClosureC cp = do + c <- dereferenceClosure cp + quadtraverse pure dereferenceConDesc pure pure c + +-- | Decode a closure corresponding to the given 'ClosurePtr' +-- You should not use this function directly unless you know what you are +-- doing. 'dereferenceClosure' will be much faster in general. +dereferenceClosureDirect :: ClosurePtr -> DebugM SizedClosure +dereferenceClosureDirect c = do + raw_c <- request (RequestClosure c) + let it = getInfoTblPtr raw_c + raw_it <- request (RequestInfoTable it) + return $ decodeClosure raw_it (c, raw_c) + +dereferenceClosures :: [ClosurePtr] -> DebugM [SizedClosure] +dereferenceClosures cs = mapM dereferenceClosure cs + +-- | Deference some StackFrames from a given 'StackCont' +dereferenceStack :: StackCont -> DebugM StackFrames +dereferenceStack (StackCont sp stack) = do +-- req_stack <- request (RequestStack (coerce cp)) + let get_bitmap o = request (RequestStackBitmap sp o) + get_info_table rc = (\(a, _, _) -> a) <$> lookupInfoTable rc +-- traceShowM ("BAD", printStack stack, rawStackSize stack) +-- traceShowM ("GOOD", printStack req_stack, rawStackSize req_stack) + decodeStack get_info_table get_bitmap stack + +-- | Derference the PapPayload from the 'PayloadCont' +dereferencePapPayload :: PayloadCont -> DebugM PapPayload +dereferencePapPayload (PayloadCont fp raw) = do + bm <- request (RequestFunBitmap (fromIntegral $ length raw) fp) + return $ GenPapPayload (evalState (traversePtrBitmap decodeField bm) raw) + where + getWord = do + v <- gets head + modify tail + return v + + decodeField True = SPtr . mkClosurePtr <$> getWord + decodeField False = SNonPtr <$> getWord + + +dereferenceConDesc :: ConstrDescCont -> DebugM ConstrDesc +dereferenceConDesc i = request (RequestConstrDesc i) + +_noConDesc :: ConstrDescCont -> DebugM ConstrDesc +_noConDesc c = traceShow c (return emptyConDesc) + +emptyConDesc :: ConstrDesc +emptyConDesc = ConstrDesc "" "" "" + +{- +-- | 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) + -} + +-- | Consult the 'BlockCache' for the block which contains a specific +-- closure, if it's not there then try to fetch the right block, if that +-- fails, call 'dereferenceClosureDirect' +dereferenceClosure :: ClosurePtr -> DebugM SizedClosure +dereferenceClosure cp + | 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) + +-- | Fetch all the blocks from the debuggee and add them to the block cache +precacheBlocks :: DebugM [RawBlock] +precacheBlocks = requestBlock PopulateBlockCache + +-- | Query the debuggee for the list of GC Roots +gcRoots :: DebugM [ClosurePtr] +gcRoots = request RequestRoots + +-- | Query the debuggee for all the blocks it knows about +allBlocks :: DebugM [RawBlock] +allBlocks = request RequestAllBlocks + +-- | Query the debuggee for source information about a specific info table. +-- This requires your executable to be built with @-finfo-table-map@. +getSourceInfo :: InfoTablePtr -> DebugM (Maybe SourceInformation) +getSourceInfo = request . RequestSourceInfo + +-- | Query the debuggee for the list of saved objects. +savedObjects :: DebugM [ClosurePtr] +savedObjects = request RequestSavedObjects + +-- | Query the debuggee for the protocol version +version :: DebugM Word32 +version = request RequestVersion + +dereferenceInfoTable :: InfoTablePtr -> DebugM StgInfoTable +dereferenceInfoTable it = decodedTable . fst <$> request (RequestInfoTable it) + diff --git a/src/GHC/Debug/Client/RequestCache.hs b/src/GHC/Debug/Client/RequestCache.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/RequestCache.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +module GHC.Debug.Client.RequestCache(RequestCache + , cacheReq + , lookupReq + , emptyRequestCache + , clearMovableRequests + , putCache + , getCache ) where + +import qualified Data.HashMap.Strict as HM +import GHC.Debug.Types +import Unsafe.Coerce +import Data.Binary +import Control.Monad +import Data.Binary.Put +import Data.Binary.Get + +newtype RequestCache = RequestCache (HM.HashMap AnyReq AnyResp) + +instance Binary RequestCache where + get = getCache + put = putCache + +cacheReq :: Request resp -> resp -> RequestCache -> RequestCache +cacheReq req resp (RequestCache rc) + -- Don't cache the results of writes, such as pause/unpause + | isWriteRequest req = RequestCache rc + | otherwise = RequestCache (HM.insert (AnyReq req) (AnyResp resp (putResponseBinary req)) rc) + +lookupReq :: forall resp . Request resp -> RequestCache -> Maybe resp +lookupReq req (RequestCache rc) = coerceResult <$> HM.lookup (AnyReq req) rc + where + coerceResult :: AnyResp -> resp + coerceResult (AnyResp a _) = unsafeCoerce a + +emptyRequestCache :: RequestCache +emptyRequestCache = RequestCache HM.empty + +-- These get/put functions are a lot like the ones for serialising info +-- to/from the debuggee but we are careful that each one reads a bounded +-- amount of input. + +getResponseBinary :: Request a -> Get a +getResponseBinary RequestVersion = getWord32be +getResponseBinary (RequestPause {}) = get +getResponseBinary RequestResume = get +getResponseBinary RequestRoots = get +getResponseBinary (RequestClosure {}) = get +getResponseBinary (RequestInfoTable itps) = + (\(it, r) -> (StgInfoTableWithPtr itps it, r)) <$> getInfoTable +getResponseBinary (RequestStackBitmap {}) = get +getResponseBinary (RequestFunBitmap {}) = get +getResponseBinary (RequestConstrDesc _) = getConstrDescCache +getResponseBinary RequestPoll = get +getResponseBinary RequestSavedObjects = get +getResponseBinary (RequestSourceInfo _c) = getIPE +getResponseBinary RequestAllBlocks = get +getResponseBinary RequestBlock {} = get + +putResponseBinary :: Request a -> a -> Put +putResponseBinary RequestVersion w = putWord32be w +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 (RequestStackBitmap {}) pbm = put pbm +putResponseBinary (RequestFunBitmap {}) pbm = put pbm +putResponseBinary (RequestConstrDesc _) cd = putConstrDescCache cd +putResponseBinary RequestPoll r = put r +putResponseBinary RequestSavedObjects os = putList os +putResponseBinary (RequestSourceInfo _c) ipe = putIPE ipe +putResponseBinary RequestAllBlocks rs = put rs +putResponseBinary RequestBlock {} r = put r + +putConstrDescCache :: ConstrDesc -> Put +putConstrDescCache (ConstrDesc a b c) = do + put a + put b + put c + +getConstrDescCache :: Get ConstrDesc +getConstrDescCache = + ConstrDesc <$> get <*> get <*> get + +putLine :: AnyReq -> AnyResp -> Put -> Put +putLine (AnyReq req) (AnyResp resp p) k = putRequest req >> p resp >> k + +getCacheLine :: Get (AnyReq, AnyResp) +getCacheLine = do + AnyReq req <- getRequest + resp <- getResponseBinary req + return (AnyReq req, AnyResp resp (putResponseBinary req)) + +putCache :: RequestCache -> Put +putCache (RequestCache rc) = do + put (HM.size rc) + HM.foldrWithKey putLine (return ()) rc + +getCache :: Get RequestCache +getCache = do + n <- get + RequestCache . HM.fromList <$> replicateM n getCacheLine + +-- | Clear the part of the cache which will become invalid after pausing +-- For example, we need to clear blocks, but can keep the info table +-- caches. +clearMovableRequests :: RequestCache -> RequestCache +clearMovableRequests (RequestCache rc) = RequestCache (HM.filterWithKey (\(AnyReq r) _ -> isImmutableRequest r) rc) diff --git a/src/GHC/Debug/Client/Search.hs b/src/GHC/Debug/Client/Search.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Client/Search.hs @@ -0,0 +1,25 @@ +module GHC.Debug.Client.Search(module GHC.Debug.Client.Search, HeapGraph(..), HeapGraphEntry(..)) where + +import GHC.Debug.Types +import GHC.Debug.Types.Graph +import qualified Data.IntMap as IM + +-- Find all entries in the HeapGraph matching a specific predicate +findClosures :: (HeapGraphEntry a -> Bool) -> HeapGraph a -> [HeapGraphEntry a] +findClosures f = go + where + go (HeapGraph _ gs) = + IM.foldl' (\hges hge -> if f hge then hge:hges else hges) [] gs + +findConstructors :: String -> HeapGraph a -> [HeapGraphEntry a] +findConstructors con_name hg = findClosures predicate hg + where + predicate h = checkConstrTable (hgeClosure h) + + checkConstrTable (ConstrClosure _ _ _ (ConstrDesc _ _ n)) = n == con_name + checkConstrTable _ = False + +findWithInfoTable :: InfoTablePtr -> HeapGraph a -> [HeapGraphEntry a] +findWithInfoTable itp = findClosures p + where + p = (itp ==) . tableId . info . hgeClosure diff --git a/src/GHC/Debug/Count.hs b/src/GHC/Debug/Count.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Count.hs @@ -0,0 +1,46 @@ +module GHC.Debug.Count where + +import GHC.Debug.Types +import GHC.Debug.Client.Monad +import GHC.Debug.Profile +import GHC.Debug.Trace +import GHC.Debug.ParTrace hiding (TraceFunctionsIO(..)) +import GHC.Debug.ParTrace (TraceFunctionsIO(TraceFunctionsIO)) +import Control.Monad.State + + +parCount :: [ClosurePtr] -> DebugM CensusStats +parCount = traceParFromM funcs . map (ClosurePtrWithInfo ()) + where + nop = const (return ()) + funcs = TraceFunctionsIO nop nop clos (const (const (return mempty))) nop + + clos :: ClosurePtr -> SizedClosure -> () + -> DebugM ((), CensusStats, DebugM () -> DebugM ()) + clos _cp sc _ = do + return ((), mkCS (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) + where + funcs = TraceFunctions { + papTrace = const (return ()) + , stackTrace = const (return ()) + , closTrace = closAccum + , visitedVal = const (return ()) + , conDescTrace = const (return ()) + + } + + closAccum :: ClosurePtr + -> SizedClosure + -> (StateT CensusStats DebugM) () + -> (StateT CensusStats DebugM) () + closAccum _cp s k = do + modify' (go s) + k + + go :: SizedClosure -> CensusStats -> CensusStats + go sc cs = mkCS (dcSize sc) <> cs diff --git a/src/GHC/Debug/Dominators.hs b/src/GHC/Debug/Dominators.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Dominators.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Debug.Dominators (computeDominators + , retainerSize + , convertToHeapGraph + , annotateWithRetainerSize ) where + +import Data.Maybe ( catMaybes, fromJust ) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import GHC.Debug.Types.Ptr +import GHC.Debug.Types.Closures +import qualified Data.List.NonEmpty as NE +import qualified Data.Foldable as F +import qualified Data.Graph.Dom as DO +import qualified Data.Tree as Tree +import GHC.Debug.Types.Graph + + + +-- Dominators +closurePtrToInt :: ClosurePtr -> Int +closurePtrToInt (ClosurePtr p) = fromIntegral p + +intToClosurePtr :: Int -> ClosurePtr +intToClosurePtr i = mkClosurePtr (fromIntegral i) + +convertToDom :: HeapGraph a -> DO.Rooted +convertToDom (HeapGraph groots is) = (0, new_graph) + where + rootNodes = IS.fromList (map closurePtrToInt (NE.toList groots)) + new_graph = IM.insert 0 rootNodes (IM.foldlWithKey' collectNodes IM.empty is) + collectNodes newMap k h = IM.insert k (IS.fromList (map closurePtrToInt (catMaybes (allClosures (hgeClosure h))))) newMap + +computeDominators :: HeapGraph a -> [Tree.Tree (HeapGraphEntry a)] +computeDominators hg = map (fmap (fromJust . flip lookupHeapGraph hg . intToClosurePtr)) gentries + where + gentries = case DO.domTree (convertToDom hg) of + Tree.Node 0 es -> es + _ -> error "Dominator tree must contain 0" + +retainerSize :: HeapGraph Size -> [Tree.Tree (HeapGraphEntry (Size, RetainerSize))] +retainerSize hg = map bottomUpSize doms + where + doms = computeDominators hg + +annotateWithRetainerSize :: HeapGraph Size -> HeapGraph (Size, RetainerSize) +annotateWithRetainerSize h@(HeapGraph rs _) = + HeapGraph rs (foldMap convertToHeapGraph (retainerSize h)) + +bottomUpSize :: Tree.Tree (HeapGraphEntry Size) -> Tree.Tree (HeapGraphEntry (Size, RetainerSize)) +bottomUpSize (Tree.Node rl sf) = + let ts = map bottomUpSize sf + s'@(Size s) = hgeData rl + RetainerSize children_size = foldMap (snd . hgeData . Tree.rootLabel) ts + inclusive_size :: RetainerSize + !inclusive_size = RetainerSize (s + children_size) + rl' = rl { hgeData = (s', inclusive_size) } + in Tree.Node rl' ts + +convertToHeapGraph :: Tree.Tree (HeapGraphEntry a) -> IM.IntMap (HeapGraphEntry a) +convertToHeapGraph t = IM.fromList ([(fromIntegral cp, c) | c <- F.toList t, let ClosurePtr cp = hgeClosurePtr c ]) + + + diff --git a/src/GHC/Debug/Fragmentation.hs b/src/GHC/Debug/Fragmentation.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Fragmentation.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Functions for analysing memory fragmentation +module GHC.Debug.Fragmentation (summariseBlocks + , censusByMBlock + , printMBlockCensus + , censusByBlock + , printBlockCensus + , censusPinnedBlocks + , PinnedCensusStats(..) + + , findBadPtrs + , histogram + ) where + +import GHC.Debug.Profile +import GHC.Debug.Client +import GHC.Debug.Types +--import GHC.Debug.Client.Monad + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List (nub, sortBy) +import Data.Ord +import Data.Word + +-- | Print a summary of the given raw blocks +-- This is useful to see how many MBlocks and how many pinned blocks there +-- are. +summariseBlocks :: [RawBlock] -> IO () +summariseBlocks bs = do + putStrLn ("TOTAL BLOCKS: " ++ show (length bs)) + putStrLn ("PINNED BLOCKS: " ++ show (length $ filter isPinnedBlock bs)) + putStrLn ("MBLOCK: " ++ show n_mblocks) + putStrLn ("PINNED MBLOCKS: " ++ show n_pmblocks) + where + n_mblocks :: Int + n_mblocks = length (nub (map (blockMBlock . rawBlockAddr) bs)) + + n_pmblocks = length (nub (map (blockMBlock . rawBlockAddr) (filter isPinnedBlock bs))) + +-- | Perform a heap census by which MBlock each closure lives in +censusByMBlock :: [ClosurePtr] -> DebugM (Map.Map BlockPtr CensusStats) +censusByMBlock = closureCensusBy go + where + go cp d = + let s :: Size + s = dcSize d + v = mkCS s + + k :: BlockPtr + k = applyMBlockMask cp + in if heapAlloced cp + then return $ Just (k, v) + -- Ignore static things + else return $ Nothing + +-- | Perform a census based on which block each closure resides in. +censusByBlock :: [ClosurePtr] -> DebugM (Map.Map BlockPtr CensusStats) +censusByBlock = closureCensusBy go + where + go cp d = + let s :: Size + s = dcSize d + v = mkCS s + + k = applyBlockMask cp + in if heapAlloced cp + then return $ Just (k, v) + -- Ignore static things + else return Nothing + +newtype PinnedCensusStats = + PinnedCensusStats (CensusStats, [(ClosurePtr, SizedClosure)]) + deriving (Semigroup) + +-- | Only census the given (pinned) blocks +censusPinnedBlocks :: [RawBlock] + -> [ClosurePtr] + -> DebugM (Map.Map BlockPtr PinnedCensusStats) +censusPinnedBlocks bs = closureCensusBy go + where + pbs = Set.fromList (map rawBlockAddr (filter isPinnedBlock bs)) + go :: ClosurePtr -> SizedClosure + -> DebugM (Maybe (BlockPtr, PinnedCensusStats)) + go cp d = + let v :: CensusStats + v = mkCS (dcSize d) + + bp = applyBlockMask cp + + in return $ if bp `Set.member` pbs + then Just (bp, PinnedCensusStats (v, [(cp, d)])) + -- Ignore static things + else Nothing + + +-- | Given a pinned block census, find the ARR_WORDS objects which are in the +-- blocks which are < 10 % utilised. The return list is sorted by how many +-- times each distinct ARR_WORDS appears on the heap. +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 + 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) + dups = map swap (reverse $ sortBy (comparing snd) (Map.toList (Map.fromListWith (<>) all_arr_words))) + in dups + +displayArrWords :: SizedClosure -> String +displayArrWords d = + case noSize d of + ArrWordsClosure { arrWords } -> show (arrWordsBS arrWords) + _ -> error "Not ARR_WORDS" + +printMBlockCensus, printBlockCensus :: Map.Map BlockPtr CensusStats -> IO () +printMBlockCensus = histogram mblockMaxSize . Map.elems +-- | Print out a block census +printBlockCensus = histogram blockMaxSize . Map.elems + +-- | Print either a MBlock or Block census as a histogram +histogram :: Word64 -> [CensusStats] -> IO () +histogram maxSize m = + mapM_ (putStrLn . displayLine) (bin 0 (map calcPercentage (sortBy (comparing cssize) m ))) + where + calcPercentage (CS _ (Size tot) _) = + ((fromIntegral tot/ fromIntegral maxSize) * 100 :: Double) + + displayLine (l, h, n) = show l ++ "%-" ++ show h ++ "%: " ++ show n + + bin _ [] = [] + bin k xs = case now of + [] -> bin (k + 10) later + _ -> (k, k+10, length now) : bin (k + 10) later + where + (now, later) = span ((<= k + 10)) xs + diff --git a/src/GHC/Debug/GML.hs b/src/GHC/Debug/GML.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/GML.hs @@ -0,0 +1,120 @@ +module GHC.Debug.GML (writeTpfToGML, addSourceInfo, typePointsFromToGML) where + +import GHC.Debug.TypePointsFrom as TPF +import GHC.Debug.Types (SourceInformation(..)) +import GHC.Debug.Types.Closures (Size(..)) +import GHC.Debug.Profile.Types (CensusStats(..), Count(..)) +import GHC.Debug.Client.Monad +import GHC.Debug.Client.Query (getSourceInfo, gcRoots) + +import Data.Map as Map +import Data.Int (Int32) +import Data.Semigroup +import qualified Data.Map.Monoidal.Strict as MMap +import qualified Data.Foldable as F + +import System.IO + +type SourceInfoMap = Map.Map TPF.Key SourceInformation + +typePointsFromToGML :: FilePath -> Debuggee -> IO () +typePointsFromToGML path e = do + (tpf, infoMap) <- run e $ do + roots <- gcRoots + tpf <- TPF.typePointsFrom roots + si <- addSourceInfo tpf + return (tpf, si) + writeTpfToGML path tpf infoMap + +-- | Exports TypePointsFrom graph to a GML file +addSourceInfo :: TypePointsFrom -> DebugM SourceInfoMap +addSourceInfo tpf = do + -- Generate a map of InfoTablePtr to SourceInformation pairs + let ptrs = MMap.keys . TPF.nodes $ tpf + infos <- mapM getSourceInfo ptrs + + let kvPairs :: [(TPF.Key, SourceInformation)] + kvPairs = do + (k, Just si) <- zip ptrs infos + return (k, si) + + infoMap :: SourceInfoMap + infoMap = Map.fromList kvPairs + + return (infoMap) + + +writeTpfToGML :: FilePath -> TPF.TypePointsFrom -> SourceInfoMap -> IO () +writeTpfToGML path tpf infoMap = do + outHandle <- openFile path WriteMode + writeGML outHandle + hClose outHandle + where + ixMap :: Map.Map TPF.Key Int32 + ixMap = Map.fromList $ zip ((MMap.keys . nodes) tpf) [1..] + + lookupId :: TPF.Key -> Int32 + lookupId key' = case Map.lookup key' ixMap of + Nothing -> error "This shouldn't happen, see function ixMap" + Just i -> i + + writeGML :: Handle -> IO () + writeGML outHandle = do + let nodesKvPairs = MMap.assocs . TPF.nodes $ tpf + edgesKvPairs = MMap.assocs . TPF.edges $ tpf + + -- Beginning of GML file + hPutStrLn stderr $ "Writing to file " <> path <> "..." + writeOpenGML + + F.forM_ nodesKvPairs (uncurry writeNode) + F.forM_ edgesKvPairs (uncurry writeEdge) + + writeCloseGML + hPutStrLn stderr $ "Finished writing to GML file..." + -- End of GML file + where + write = hPutStr outHandle + + writeOpenGML = + write $ "graph[\n" + <> "comment \"this is a graph in GML format\"\n" + <> "directed 1\n" + + writeCloseGML = + write $ "]\n" + + writeNode :: TPF.Key -> CensusStats -> IO () + writeNode key' cs = + write $ "node [\n" + <> "id " <> showPtr key' <> "\n" + <> gmlShowCensus cs + <> gmlShowSourceInfo key' + <> "]\n" + + writeEdge :: TPF.Edge -> CensusStats -> IO () + writeEdge edge cs = + write $ "edge [\n" + <> "source " <> (showPtr . TPF.edgeSource) edge <> "\n" + <> "target " <> (showPtr . TPF.edgeTarget) edge <> "\n" + <> gmlShowCensus cs + <> "]\n" + + gmlShowCensus :: CensusStats -> String + gmlShowCensus (CS (Count c) (Size s) (Max (Size m))) = + "count " <> show c <> "\n" + <> "size " <> show s <> "\n" + <> "max " <> show m <> "\n" + + gmlShowSourceInfo :: TPF.Key -> String + gmlShowSourceInfo key = case Map.lookup key infoMap of + Nothing -> mempty + Just si -> "infoName \"" <> infoName si <> "\"\n" + <> "infoClosureType \"" <> (show . infoClosureType) si <> "\"\n" + <> "infoType \"" <> infoType si <> "\"\n" + <> "infoLabel \"" <> infoLabel si <> "\"\n" + <> "infoModule \"" <> infoModule si <> "\"\n" + <> "infoPosition \"" <> infoPosition si <> "\"\n" + + showPtr :: TPF.Key -> String + showPtr = show . lookupId diff --git a/src/GHC/Debug/ObjectEquiv.hs b/src/GHC/Debug/ObjectEquiv.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/ObjectEquiv.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ViewPatterns #-} +-- | Attempt to find duplicate objects on the heap. The analysis is not +-- exact but attempts to find closures which are identical, and could be +-- shared. +module GHC.Debug.ObjectEquiv(objectEquiv, objectEquivAnalysis, printObjectEquiv, EquivMap) where + +import GHC.Debug.Client.Monad +import GHC.Debug.Client +import GHC.Debug.Trace +import GHC.Debug.Profile +import GHC.Debug.Types.Graph (ppClosure) +import GHC.Debug.Types(ClosurePtr(..)) + +import Control.Monad.State +import Data.List (sortBy) +import Data.Ord +import Debug.Trace +import qualified Data.OrdPSQ as PS +import qualified Data.IntMap.Strict as IM +import Data.List.NonEmpty(NonEmpty(..)) + +type CensusByObjectEquiv = IM.IntMap CensusStats + +-- | How big to allow the priority queue to grow to +limit :: Int +limit = 100_000 +-- | How many times an object must appear per 100 000 closures to be +-- "interesting" and kept for the future. +of_interest :: Int +of_interest = 1000 + +-- Pick a representative ClosurePtr for each object +type EquivMap = PS.OrdPSQ PtrClosure -- Object + Int + ClosurePtr -- Representative of equivalence class + +type Equiv2Map = IM.IntMap -- Pointer + ClosurePtr -- Representative of equivalence class + +data ObjectEquivState = ObjectEquivState { + emap :: !EquivMap + , emap2 :: !Equiv2Map + , _census :: !CensusByObjectEquiv + } +-- Don't need to add identity mapping in emap2 because lookup failure is +-- the identity anyway. +addEquiv :: ClosurePtr -> PtrClosure -> ObjectEquivState -> ObjectEquivState +addEquiv cp pc (trimMap -> o) = + let (res, new_m) = PS.alter g pc (emap o) + new_emap2 = case res of + Left _ -> emap2 o + -- Only remap objects which have a hit + -- in the cache + Right new_cp -> addNewMap cp new_cp (emap2 o) + in ( o { emap = new_m + , emap2 = new_emap2 }) + where + g Nothing = (Left cp, Just (0, cp)) + g (Just (p, v)) = (Right v, Just (p + 1, v)) + +addNewMap :: ClosurePtr -> ClosurePtr -> Equiv2Map -> Equiv2Map +addNewMap (ClosurePtr cp) equiv_cp o = IM.insert (fromIntegral cp) equiv_cp o + +-- Trim down map to keep objects which have only been seen 100 times or +-- more within the last 10 000 seen objects +trimMap :: ObjectEquivState -> ObjectEquivState +trimMap o = if checkSize o > limit + then let new_o = o { emap = snd $ PS.atMostView of_interest (emap o) } + in traceShow (checkSize new_o) new_o + -- TODO: Here would be good to also keep everything + -- which is referenced by the kept closures, otherwise + -- you end up with duplicates in the map + + else o + +-- | O(1) due to psqueues implementation +checkSize :: ObjectEquivState -> Int +checkSize (ObjectEquivState e1 _ _) = PS.size e1 + +type PtrClosure = DebugClosureWithSize 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 ()) + , stackTrace = const (return ()) + , closTrace = closAccum + , visitedVal = const (return ()) + , conDescTrace = const (return ()) + + } + -- Add cos + closAccum :: ClosurePtr + -> SizedClosure + -> (StateT ObjectEquivState DebugM) () + -> (StateT ObjectEquivState DebugM) () + closAccum cp s k = do + -- Step 0: Check to see whether there is already an equivalence class + -- for this cp + -- Step 1: Decode a bit more of the object, so we can see all the + -- pointers. + s' <- lift $ quadtraverse 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'' <- quadtraverse (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'') + +{- + -- Yes, we have seen something of identical shape + -- 1. Update equivalence maps to map this closure into the right + -- equivalence class + Just new_cp -> do + n <- checkSize <$> lift get + traceShowM n + lift $ modify' (addNewMap cp new_cp) + return new_cp + -- + -- No, never seen something like this before + -- Add the mapping to emap + Nothing -> do + lift $ modify' (addNewEquiv cp s'') + return cp + -} + + -- Step 4: Update the census, now we know the equivalence class of + -- the object + --lift $ modify' (go new_cp s'') + -- Step 5: Call the continuation to carry on with the analysis + k + + rep_c cp@(ClosurePtr k) = do + m <- gets emap2 + case IM.lookup (fromIntegral k) m of + -- There is an equivalence class already + Just cp' -> return cp' + -- No equivalence class yet + Nothing -> return cp + +printObjectEquiv :: EquivMap -> IO () +printObjectEquiv c = do + let cmp (_, b,_) = b + res = sortBy (flip (comparing cmp)) (PS.toList c) + showLine (k, p, v) = + concat [show v, ":", show p,":", ppClosure "" (\_ -> show) 0 (noSize k)] + mapM_ (putStrLn . showLine) res +-- writeFile "profile/profile_out.txt" (unlines $ "key, total, count, max, avg" : (map showLine res)) + +objectEquivAnalysis :: DebugM (EquivMap, HeapGraph Size) +objectEquivAnalysis = do + precacheBlocks + rs <- gcRoots + traceWrite (length rs) + r1 <- emap <$> censusObjectEquiv rs + let elems = snd $ PS.atMostView of_interest r1 + cmp (_, b,_) = b + cps = map (\(_, _, cp) -> cp) (sortBy (flip (comparing cmp)) (PS.toList elems)) + -- Use this code if we are returning ClosurePtr not SourceInformation + r2 <- case cps of + [] -> error "None" + (c:cs) -> multiBuildHeapGraph (Just 10) (c :| cs) + return (r1, r2) + +objectEquiv :: Debuggee -> IO () +objectEquiv = runAnalysis objectEquivAnalysis $ \(rmap, hg) -> do + printObjectEquiv rmap + putStrLn $ ppHeapGraph show hg diff --git a/src/GHC/Debug/ParTrace.hs b/src/GHC/Debug/ParTrace.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/ParTrace.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# 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 +-- future. +-- +-- The tracing functions create a thread for each MBlock which we +-- traverse, closures are then sent to the relevant threads to be +-- dereferenced and thread-local storage is accumulated. +module GHC.Debug.ParTrace ( traceParFromM, tracePar, TraceFunctionsIO(..), ClosurePtrWithInfo(..) ) where + +import GHC.Debug.Types +import GHC.Debug.Client.Query + +import qualified Data.IntMap as IM +import Data.Array.BitArray.IO hiding (map) +import Control.Monad.Reader +import Data.Word +import GHC.Debug.Client.Monad.Simple +import Control.Concurrent.Async +import Data.IORef +import Control.Exception.Base +import Debug.Trace +import Control.Concurrent.STM + +threads :: Int +threads = 64 + +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: +-- +-- * 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) + +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 + + +-- | Map from Thread -> Information about the thread +type ThreadMap a = IM.IntMap (ThreadInfo a) + +newtype TraceState a = TraceState { visited :: (ThreadMap a) } + + +getKeyTriple :: ClosurePtr -> (Int, Int, Word16) +getKeyTriple cp = + let BlockPtr raw_bk = applyBlockMask cp + bk = fromIntegral raw_bk `div` 8 + offset = getBlockOffset cp `div` 8 + BlockPtr raw_mbk = applyMBlockMask cp + mbk = fromIntegral raw_mbk `div` 8 + in (mbk, bk, fromIntegral offset) + +getMBlockKey :: ClosurePtr -> Int +getMBlockKey cp = + let BlockPtr raw_bk = applyMBlockMask cp + -- Not sure why I had to divide this by 4, but I did. + in (fromIntegral raw_bk `div` fromIntegral mblockMask `div` 4) `mod` threads + +sendToChan :: TraceState a -> ClosurePtrWithInfo a -> DebugM () +sendToChan ts cpi@(ClosurePtrWithInfo _ cp) = DebugM $ liftIO $ do + let st = visited ts + mkey = getMBlockKey cp + 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 + -> TraceFunctionsIO a s + -> DebugM (ThreadInfo a, STM Bool, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)) +initThread n k = DebugM $ do + e <- ask + ic <- liftIO $ newTChanIO + let oc = ic + ref <- liftIO $ newIORef mempty + worker_active <- liftIO $ newTVarIO True + let start go = unsafeLiftIO $ async $ runSimple e $ workerThread n k worker_active ref go oc + finished = do + active <- not <$> readTVar worker_active + empty <- isEmptyTChan ic + return (active && empty) + + return (ThreadInfo ic, finished, start) + +workerThread :: forall s a . Monoid s => Int -> TraceFunctionsIO a s -> TVar Bool -> IORef s -> (ClosurePtrWithInfo a -> DebugM ()) -> OutChan (ClosurePtrWithInfo a) -> DebugM s +workerThread n k worker_active ref go oc = DebugM $ do + d <- ask + r <- liftIO $ newIORef (ThreadState IM.empty ref) + liftIO $ runSimple d (loop r) + where + loop r = do + mcp <- unsafeLiftIO $ try $ do + atomically $ writeTVar worker_active False + atomically $ do + v <- readTChan oc + writeTVar worker_active True + return v + case mcp of + -- The thread gets blocked on readChan when the work is finished so + -- when this happens, catch the exception and return the accumulated + -- state for the thread. Each thread has a reference to all over + -- threads, so the exception is only raised when ALL threads are + -- waiting for work. + Left AsyncCancelled -> do + unsafeLiftIO $ readIORef ref + Right cpi -> deref r cpi >> loop r + + deref r (ClosurePtrWithInfo a cp) = do + m <- unsafeLiftIO $ readIORef r + do + (m', b) <- unsafeLiftIO $ checkVisit cp m + unsafeLiftIO $ writeIORef r m' + if b + then do + s <- visitedVal 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 (() <$ quadtraverse (gop r a') gocd (gos r a') (goc r . ClosurePtrWithInfo a') sc) + + goc r c@(ClosurePtrWithInfo _i cp) = + let mkey = getMBlockKey cp + in if (mkey == n) + then deref r c + else go c + + -- Just do the other dereferencing in the same thread for other closure + -- types as they are not as common. + gos r a st = do + st' <- dereferenceStack st + stackTrace k st' + () <$ traverse (goc r . ClosurePtrWithInfo a) st' + + gocd d = do + cd <- dereferenceConDesc d + conDescTrace k cd + + gop r a p = do + p' <- dereferencePapPayload p + papTrace k p' + () <$ traverse (goc r . ClosurePtrWithInfo a) p' + + +handleBlockLevel :: IM.Key + -> Word16 + -> IM.IntMap (IOBitArray Word16) + -> IO (IM.IntMap (IOBitArray Word16), Bool) + +handleBlockLevel bk offset m = do + case IM.lookup bk m of + Nothing -> do + na <- newArray (0, fromIntegral (blockMask `div` 8)) False + writeArray na offset True + return (IM.insert bk na m, False) + Just bm -> do + res <- readArray bm offset + unless res (writeArray bm offset True) + return (m, res) + +checkVisit :: ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool) +checkVisit cp st = do + let (mbk, bk, offset) = getKeyTriple cp + ThreadState v ref = st + case IM.lookup mbk v of + Nothing -> do + (st', res) <- handleBlockLevel bk offset IM.empty + return (ThreadState (IM.insert mbk st' v) ref, res) + Just bm -> do + (st', res) <- handleBlockLevel bk offset bm + return (ThreadState (IM.insert mbk st' v) ref, res) + + + + + +data TraceFunctionsIO a s = + TraceFunctionsIO { papTrace :: !(GenPapPayload ClosurePtr -> DebugM ()) + , stackTrace :: !(GenStackFrames ClosurePtr -> DebugM ()) + , closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ())) + , visitedVal :: !(ClosurePtr -> a -> DebugM s) + , conDescTrace :: !(ConstrDesc -> DebugM ()) + } + + +-- | A generic heap traversal function which will use a small amount of +-- memory linear in the heap size. Using this function with appropiate +-- 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 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 +-- lower. +traceParFromM :: Monoid s => TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s +traceParFromM k cps = do + traceM ("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] + let ts_map = IM.fromList init_mblocks + go = sendToChan (TraceState ts_map) + as <- sequence (map ($ go) start ) + mapM_ go cps + unsafeLiftIO $ waitFinish work_actives + unsafeLiftIO $ mapM_ cancel as + unsafeLiftIO $ mconcat <$> mapM wait as + +waitFinish :: [STM Bool] -> IO () +waitFinish working = atomically (checkDone working) + where + checkDone [] = return () + checkDone (x:xs) = do + b <- x + -- The variable tracks whether the thread thinks it's finished (no + -- active work and empty chan) + if b then checkDone xs else retry + +-- | A parellel tracing function. +tracePar :: [ClosurePtr] -> DebugM () +tracePar = traceParFromM funcs . map (ClosurePtrWithInfo ()) + where + nop = const (return ()) + funcs = TraceFunctionsIO nop nop clos (const (const (return ()))) nop + + clos :: ClosurePtr -> SizedClosure -> () + -> DebugM ((), (), DebugM () -> DebugM ()) + clos _cp sc _ = do + let itb = info (noSize sc) + _traced <- getSourceInfo (tableId itb) + return ((), (), id) + + diff --git a/src/GHC/Debug/Profile.hs b/src/GHC/Debug/Profile.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Profile.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RecordWildCards #-} +{- | Functions for performing whole heap census in the style of the normal +- heap profiling -} +module GHC.Debug.Profile( profile + , censusClosureType + , census2LevelClosureType + , closureCensusBy + , CensusByClosureType + , writeCensusByClosureType + , CensusStats(..) + , mkCS + , Count(..) + , closureToKey ) where + +import GHC.Debug.Client.Monad +import GHC.Debug.Client +import GHC.Debug.Trace +import GHC.Debug.ParTrace +import GHC.Debug.Profile.Types + +import qualified Data.Map.Strict as Map +import Control.Monad.State +import Data.List (sortBy) +import Data.Ord +import Control.Concurrent +import Eventlog.Types +import Eventlog.Data +import Eventlog.Total +import Eventlog.HtmlTemplate +import Eventlog.Args (defaultArgs) +import Data.Text (pack, Text, unpack) +import Data.Semigroup +import qualified Data.Text as T +import qualified Data.Map.Monoidal.Strict as MMap + + + +type CensusByClosureType = Map.Map Text 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 <- quadtraverse pure dereferenceConDesc pure pure s + let siz :: Size + siz = dcSize d + v = mkCS siz + return $ Just (closureToKey (noSize d), v) + + + +closureToKey :: DebugClosure 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)))) + + +-- | General function for performing a heap census in constant memory +closureCensusBy :: forall k v . (Semigroup v, Ord k) + => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v))) + -> [ClosurePtr] -> DebugM (Map.Map k v) +closureCensusBy f cps = do + () <$ precacheBlocks + MMap.getMonoidalMap <$> traceParFromM funcs (map (ClosurePtrWithInfo ()) cps) + where + funcs = TraceFunctionsIO { + papTrace = const (return ()) + , stackTrace = const (return ()) + , closTrace = closAccum + , visitedVal = const (const (return MMap.empty)) + , conDescTrace = const (return ()) + + } + -- Add cos + closAccum :: ClosurePtr + -> SizedClosure + -> () + -> DebugM ((), MMap.MonoidalMap k v, a -> a) + closAccum cp s () = do + r <- f cp s + return . (\s' -> ((), s', id)) $ case r of + Just (k, v) -> MMap.singleton k v + Nothing -> MMap.empty + +-- | Perform a 2-level census where the keys are the type of the closure +-- in addition to the type of ptrs of the closure. This can be used to +-- distinguish between lists of different type for example. +census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType +census2LevelClosureType cps = snd <$> runStateT (traceFromM funcs cps) Map.empty + where + funcs = TraceFunctions { + papTrace = const (return ()) + , stackTrace = const (return ()) + , closTrace = closAccum + , visitedVal = const (return ()) + , conDescTrace = const (return ()) + + } + -- Add cos + closAccum :: ClosurePtr + -> SizedClosure + -> (StateT CensusByClosureType DebugM) () + -> (StateT CensusByClosureType DebugM) () + closAccum _ s k = do + s' <- lift $ quadtraverse dereferencePapPayload dereferenceConDesc dereferenceStack pure s + pts <- lift $ mapM dereferenceClosure (allClosures (noSize s')) + pts' <- lift $ mapM (quadtraverse pure dereferenceConDesc pure pure) pts + + + modify' (go 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)) + +{- +-- | Parallel heap census +parCensus :: [RawBlock] -> [ClosurePtr] -> DebugM (Map.Map Text CensusStats) +parCensus bs cs = do + MMap.getMonoidalMap <$> (traceParFromM bs funcs (map (ClosurePtrWithInfo ()) cs)) + + where + nop = const (return ()) + funcs = TraceFunctionsIO nop nop clos (const (const (return mempty))) nop + + clos :: ClosurePtr -> SizedClosure -> () + -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ()) + clos _cp sc () = do + d <- quadtraverse pure dereferenceConDesc pure pure sc + let s :: Size + s = dcSize sc + v = mkCS s + return $ ((), MMap.singleton (closureToKey (noSize d)) v, id) + -} + + +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) + + +-- | Peform a profile at the given interval (in seconds), the result will +-- be rendered after each iteration using @eventlog2html@. +profile :: FilePath -> Int -> Debuggee -> IO () +profile outpath interval e = loop [(0, Map.empty)] 0 + where + loop :: [(Int, CensusByClosureType)] -> Int -> IO () + loop ss i = do + threadDelay (interval * 1_000_000) + pause e + r <- runTrace e $ do + precacheBlocks + rs <- gcRoots + traceWrite (length rs) + census2LevelClosureType rs + resume e + writeCensusByClosureType outpath r + let new_data = ((i + 1) * interval, r) : ss + renderProfile new_data + loop new_data (i + 1) + + +mkFrame :: (Int, CensusByClosureType) -> Frame +mkFrame (t, m) = Frame (fromIntegral t / 10e6) (Map.foldrWithKey (\k v r -> mkSample k v : r) [] m) + +mkSample :: Text -> CensusStats -> Sample +mkSample k (CS _ (Size v) _) = + Sample (Bucket k) (fromIntegral v) + +mkProfData :: [(Int, CensusByClosureType)] -> ProfData +mkProfData raw_fs = + let fs = map mkFrame raw_fs + (counts, totals) = total fs + -- Heap profiles don't contain any other information than the simple bucket name + binfo = Map.mapWithKey (\(Bucket k) (t,s,g) -> BucketInfo k Nothing t s g) totals + -- Heap profiles do not support traces + header = Header "ghc-debug" "" (Just HeapProfBreakdownClosureType) "" "" "" counts Nothing + in ProfData header binfo mempty fs [] (HeapInfo [] [] []) mempty + +renderProfile :: [(Int, CensusByClosureType)] -> IO () +renderProfile ss = do + let pd = mkProfData ss + as <- defaultArgs "unused" + (header, data_json, descs, closure_descs) <- generateJsonData as pd + let html = templateString header data_json descs closure_descs as + writeFile "profile/ht.html" html + return () + + diff --git a/src/GHC/Debug/Profile/Types.hs b/src/GHC/Debug/Profile/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Profile/Types.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DerivingVia #-} +module GHC.Debug.Profile.Types where + +import GHC.Debug.Types +import Data.Monoid +import Data.Semigroup + +newtype Count = Count 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) + +mkCS :: Size -> CensusStats +mkCS i = CS (Count 1) i (Max i) + +instance Monoid CensusStats where + mempty = CS mempty mempty (Max (Size 0)) + +instance Semigroup CensusStats where + (CS a b c) <> (CS a1 b1 c1) = CS (a <> a1) (b <> b1) (c <> c1) diff --git a/src/GHC/Debug/Retainers.hs b/src/GHC/Debug/Retainers.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Retainers.hs @@ -0,0 +1,77 @@ +-- | Functions for computing retainers +module GHC.Debug.Retainers(findRetainersOf, findRetainers, addLocationToStack, displayRetainerStack) where + +import GHC.Debug.Client +import Control.Monad.State +import GHC.Debug.Trace +import GHC.Debug.Types.Graph + +import qualified Data.Set as Set +import Control.Monad.RWS + +addOne :: [ClosurePtr] -> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]]) +addOne _ (Just 0, cp) = (Just 0, cp) +addOne cp (n, cps) = (subtract 1 <$> n, cp:cps) + +findRetainersOf :: Maybe Int + -> [ClosurePtr] + -> [ClosurePtr] + -> DebugM [[ClosurePtr]] +findRetainersOf limit cps bads = findRetainers limit cps (\cp _ -> return (cp `Set.member` bad_set)) + where + bad_set = Set.fromList bads + +-- | 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, []) + where + funcs = TraceFunctions { + papTrace = const (return ()) + , stackTrace = const (return ()) + , closTrace = closAccum + , visitedVal = const (return ()) + , conDescTrace = const (return ()) + + } + -- Add clos + closAccum :: ClosurePtr + -> SizedClosure + -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM () + -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM () + closAccum cp sc k = do + b <- lift $ p cp sc + if b + then do + ctx <- ask + modify' (addOne (cp: ctx)) + -- 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 + +addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureC, Maybe SourceInformation)] +addLocationToStack r = do + cs <- dereferenceClosures r + cs' <- mapM (quadtraverse pure dereferenceConDesc pure pure) cs + locs <- mapM getSourceLoc cs' + return $ (zip 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 + do_one k (l, stack) = do + putStrLn (show k ++ "-------------------------------------") + print l + mapM (putStrLn . disp) stack + zipWithM_ do_one [0 :: Int ..] rs diff --git a/src/GHC/Debug/Snapshot.hs b/src/GHC/Debug/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Snapshot.hs @@ -0,0 +1,46 @@ +-- | Functions for creating and running snapshots. +module GHC.Debug.Snapshot ( -- * Generating snapshots + snapshot + , makeSnapshot + -- * Using a snapshot + , snapshotRun + -- * Low level + , traceFrom ) where + +import GHC.Debug.Trace +import GHC.Debug.ParTrace +import GHC.Debug.Client.Monad +import GHC.Debug.Client +import Control.Monad.Identity +import Control.Monad.Trans + +-- | Make a snapshot of the current heap and save it to the given file. +snapshot :: FilePath -> DebugM () +snapshot fp = do + precacheBlocks + rs <- gcRoots + _so <- savedObjects + tracePar rs + saveCache fp + +-- | Traverse the tree from GC roots, to populate the caches +-- with everything necessary. +traceFrom :: [ClosurePtr] -> DebugM () +traceFrom cps = runIdentityT (traceFromM funcs cps) + where + nop = const (return ()) + funcs = TraceFunctions nop nop clos (const (return ())) nop + + clos :: ClosurePtr -> SizedClosure -> (IdentityT DebugM) () + -> (IdentityT DebugM) () + clos _cp sc k = do + let itb = info (noSize sc) + _traced <- lift $ getSourceInfo (tableId itb) + k + +-- | Pause the process and create a snapshot of +-- the heap. The snapshot can then be loaded with +-- 'snapshotRun' in order to perform offline analysis. +makeSnapshot :: Debuggee -> FilePath -> IO () +makeSnapshot e fp = runAnalysis (snapshot fp) (const (return ())) e + diff --git a/src/GHC/Debug/Trace.hs b/src/GHC/Debug/Trace.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Trace.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE BangPatterns #-} +-- | Functions to support the constant space traversal of a heap. +module GHC.Debug.Trace ( traceFromM, TraceFunctions(..) ) where + +import GHC.Debug.Types +import GHC.Debug.Client.Monad +import GHC.Debug.Client.Query + +import qualified Data.IntMap as IM +import Data.Array.BitArray.IO +import Control.Monad.Reader +import Data.IORef +import Data.Word +import System.IO + +newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16)) + +data TraceState = TraceState { visited :: !VisitedSet, n :: !Int } + + +getKeyPair :: ClosurePtr -> (Int, Word16) +getKeyPair cp = + let BlockPtr raw_bk = applyBlockMask cp + bk = fromIntegral raw_bk `div` 8 + offset = getBlockOffset cp `div` 8 + in (bk, fromIntegral offset) + +checkVisit :: ClosurePtr -> IORef TraceState -> IO Bool +checkVisit cp mref = do + st <- readIORef mref + let VisitedSet v = visited st + num_visited = n st + (bk, offset) = getKeyPair cp + case IM.lookup bk v of + Nothing -> do + 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 + Just bm -> do + res <- readArray bm offset + unless res (writeArray bm offset True) + return res + + + +data TraceFunctions m = + TraceFunctions { papTrace :: !(GenPapPayload ClosurePtr -> m DebugM ()) + , stackTrace :: !(GenStackFrames ClosurePtr -> m DebugM ()) + , closTrace :: !(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()) + , visitedVal :: !(ClosurePtr -> (m DebugM) ()) + , conDescTrace :: !(ConstrDesc -> m DebugM ()) + } + + + + +type C m = (MonadTrans m, Monad (m DebugM)) + +-- | A generic heap traversal function which will use a small amount of +-- memory linear in the heap size. Using this function with appropiate +-- accumulation functions you should be able to traverse quite big heaps in +-- not a huge amount of memory. +traceFromM :: C m => TraceFunctions m-> [ClosurePtr] -> m DebugM () +traceFromM k cps = do + st <- lift (unsafeLiftIO (newIORef (TraceState (VisitedSet IM.empty) 1))) + runReaderT (mapM_ (traceClosureFromM k) cps) st +{-# INLINE traceFromM #-} +{-# INLINE traceClosureFromM #-} + +traceClosureFromM :: C m + => TraceFunctions m + -> ClosurePtr + -> ReaderT (IORef TraceState) (m DebugM) () +traceClosureFromM !k = go + where + go cp = do + mref <- ask + b <- lift $ lift $ unsafeLiftIO (checkVisit cp mref) + if b + then lift $ visitedVal k cp + else do + sc <- lift $ lift $ dereferenceClosure cp + ReaderT $ \st -> closTrace k cp sc + (runReaderT (() <$ quadtraverse gop gocd gos go sc) st) + + + gos st = do + st' <- lift $ lift $ dereferenceStack st + lift $ stackTrace k st' + () <$ traverse go st' + + gocd d = do + cd <- lift $ lift $ dereferenceConDesc d + lift $ conDescTrace k cd + + gop p = do + p' <- lift $ lift $ dereferencePapPayload p + lift $ papTrace k p' + () <$ traverse go p' diff --git a/src/GHC/Debug/TypePointsFrom.hs b/src/GHC/Debug/TypePointsFrom.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/TypePointsFrom.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ViewPatterns #-} +{- | Type Points From analysis in the style of +- Cork: Dynamic Memory Leak Detectionfor Garbage-Collected Languages +- https://dl.acm.org/doi/10.1145/1190216.1190224 +- -} +module GHC.Debug.TypePointsFrom( typePointsFrom + , detectLeaks + , TypePointsFrom(..) + , getNodes + , getEdges + , edgeSource + , edgeTarget + , Key + , Edge(..) + , getKey + ) where + +import GHC.Debug.Client.Monad +import GHC.Debug.Client +import Control.Monad.State +import GHC.Debug.ParTrace +import GHC.Debug.Types.Ptr +import qualified Data.Map.Monoidal.Strict as Map +import Data.Map (Map) +import qualified Data.Map.Internal as M +import GHC.Debug.Profile +import Control.Monad.Identity +import Control.Concurrent +import Data.List (sortOn) +import Language.Dot +import qualified Data.Set as S + + +type Key = InfoTablePtr + +data Edge = Edge !Key !Key deriving (Eq, Ord, Show) + +edgeSource :: Edge -> Key +edgeTarget :: Edge -> Key +edgeSource (Edge k1 _) = k1 +edgeTarget (Edge _ k2) = k2 + +data TypePointsFrom = TypePointsFrom { nodes :: !(Map.MonoidalMap Key CensusStats) + , edges :: !(Map.MonoidalMap Edge CensusStats) + } deriving (Show) + +getNodes :: TypePointsFrom -> Map Key CensusStats +getEdges :: TypePointsFrom -> Map Edge CensusStats +getNodes = Map.getMonoidalMap . nodes +getEdges = Map.getMonoidalMap . edges + +instance Monoid TypePointsFrom where + mempty = TypePointsFrom mempty mempty + +instance Semigroup TypePointsFrom where + (TypePointsFrom a1 a2) <> (TypePointsFrom b1 b2) = TypePointsFrom (a1 <> b1) (a2 <> b2) + +singletonTPF :: Key -> CensusStats -> [(Edge, CensusStats)] -> TypePointsFrom +singletonTPF k s es = TypePointsFrom (Map.singleton k s) + (Map.fromList es) + +-- | Perform a "type points from" heap census +typePointsFrom :: [ClosurePtr] -> DebugM TypePointsFrom +typePointsFrom cs = traceParFromM funcs (map (ClosurePtrWithInfo Root) cs) + + where + nop = const (return ()) + funcs = TraceFunctionsIO nop nop clos visit nop + + visit :: ClosurePtr -> Context -> DebugM TypePointsFrom + visit cp ctx = do + sc <- dereferenceClosure cp + let k = tableId $ info (noSize sc) + v = mkCS (dcSize sc) + parent_edge = case ctx of + Root -> [] + Parent pk -> [(Edge k pk, v)] + return $ TypePointsFrom Map.empty (Map.fromList parent_edge) + + + + clos :: ClosurePtr -> SizedClosure -> Context + -> DebugM (Context, TypePointsFrom, DebugM () -> DebugM ()) + clos _cp sc ctx = do + let k = tableId $ info (noSize sc) + let s :: Size + s = dcSize sc + v = mkCS s + + -- Edges point from the object TO what retains it + parent_edge = case ctx of + Root -> [] + Parent pk -> [(Edge k pk, v)] + + return (Parent k, singletonTPF k v parent_edge, id) + + +data Context = Root | Parent Key + + +-- | Repeatedly call 'typesPointsFrom' and perform the leak detection +-- analysis. +detectLeaks :: Int -> Debuggee -> IO () +detectLeaks interval e = loop Nothing (M.empty, M.empty) 0 + where + loop :: Maybe TypePointsFrom -> RankMaps -> Int -> IO () + loop prev_census rms i = do + print i + threadDelay (interval * 1_000_000) + pause e + (gs, r, new_rmaps) <- runTrace e $ do + _ <- precacheBlocks + rs <- gcRoots + traceWrite (length rs) + res <- typePointsFrom rs + let !new_rmaps = case prev_census of + Nothing -> rms + Just pcensus -> updateRankMap rms pcensus res + let cands = chooseCandidates (fst new_rmaps) + traceWrite (length cands) + gs <- mapM (findSlice (snd new_rmaps)) (take 10 cands) + return (gs, res, new_rmaps) + resume e + zipWithM_ (\n g -> writeFile ("slices/" + ++ show @Int i ++ "-" + ++ show @Int n ++ ".dot") + (renderDot g)) [0..] gs + loop (Just r) new_rmaps (i + 1) + + +-- Analysis code +-- +getKey :: InfoTablePtr -> DebugM String +getKey itblp = do + loc <- getSourceInfo itblp + itbl <- dereferenceInfoTable itblp + case loc of + Nothing -> getKeyFallback itblp itbl + Just s -> return $ show (tipe itbl) ++ ":" ++ renderSourceInfo s + +getKeyFallback itbp itbl = do + case tipe itbl of + t | CONSTR <= t && t <= CONSTR_NOCAF -> do + ConstrDesc a b c <- dereferenceConDesc itbp + return $ a ++ ":" ++ b ++ ":" ++ c + _ -> return $ show (tipe itbl) + +type Rank = Double +type Decay = Double + +data RankInfo = RankInfo !Rank !Int deriving Show + +getRank :: RankInfo -> Rank +getRank (RankInfo r _) = r + +default_decay :: Decay +default_decay = 0.15 + +rank_threshold :: Double +rank_threshold = 100 + +min_iterations :: Int +min_iterations = 2 + +applyRankFilter :: RankInfo -> Bool +applyRankFilter (RankInfo r i) = r >= rank_threshold && i >= min_iterations + +-- | Lookup suitable candidates from the RankMap +-- , Chooses values based on 'rank_threshold' and 'min_iterations' +lookupRM :: Key -> RankMap Edge -> [(Edge, RankInfo)] +lookupRM k m = M.assocs filtered_map + where + -- TODO, work out how to use these functions O(log n) + --smaller = traceShow (M.size m) (M.dropWhileAntitone ((/= k) . edgeSource) $ m) + --res_map = traceShow (M.size smaller) (M.takeWhileAntitone ((== k) . edgeSource) smaller) + (res_map, _) = M.partitionWithKey (\e _ -> (== k) . edgeSource $ e) m + filtered_map = M.filter (\(RankInfo r _) -> r > 0) res_map + +mkDotId :: InfoTablePtr -> Id +mkDotId (InfoTablePtr w) = IntegerId (fromIntegral w) + +findSlice :: RankMap Edge -> Key -> DebugM Graph +findSlice rm k = Graph StrictGraph DirectedGraph (Just (mkDotId k)) <$> evalStateT (go 3 k) S.empty + + where + + go :: Int -> InfoTablePtr -> StateT (S.Set InfoTablePtr) DebugM [Statement] + go n cur_k = do + visited_set <- get + -- But don't stop going deep until we've seen a decent number of + -- nodes + if S.member cur_k visited_set || (n <= 0 && S.size visited_set >= 20) + then return [] + else do + label <- lift $ getKey cur_k + let next_edges = take 20 (lookupRM cur_k rm) + -- Decoding very wide is bad + edge_stmts = map mkEdge next_edges + node_stmt = NodeStatement (NodeId (mkDotId cur_k) Nothing) [AttributeSetValue (StringId "label") (StringId label) ] + mkEdge (Edge _ e, ri) = EdgeStatement [ENodeId NoEdge (NodeId (mkDotId cur_k) Nothing), ENodeId DirectedEdge (NodeId (mkDotId e) Nothing)] [AttributeSetValue (StringId "label") (StringId (show (getRank ri))) ] + + modify' (S.insert cur_k) + ss <- concat <$> mapM (go (n-1) . edgeTarget . fst) next_edges + return $ node_stmt : edge_stmts ++ ss + +renderSourceInfo :: SourceInformation -> String +renderSourceInfo s = escapeQuotes (infoName s ++ ":" ++ infoType s ++ ":" ++ infoPosition s) + +escapeQuotes :: String -> String +escapeQuotes [] = [] +escapeQuotes ('"':xs) = '\\' : '"' : escapeQuotes xs +escapeQuotes (x:xs) = x:escapeQuotes xs + + +chooseCandidates :: RankMap Key -> [Key] +chooseCandidates = map fst . reverse . sortOn (getRank . snd) . M.assocs . M.filter applyRankFilter + +type RankMap k = M.Map k RankInfo + +type RankMaps = (RankMap Key, RankMap Edge) + +type RankUpdateMap k = M.Map k RankUpdateInfo + +type RankUpdateInfo = Int -> Double -> Double + +-- | Update the current rank predictions based on the difference between +-- two censuses. +updateRankMap :: (RankMap Key, RankMap Edge) + -> TypePointsFrom + -> TypePointsFrom + -> (RankMap Key, RankMap Edge) +updateRankMap (rm_n, rm_e) t1 t2 = (ns, es) + where + !(rnodes, redges) = ratioRank t1 t2 + missingL = M.dropMissing + missingR = M.mapMissing (\_ f -> RankInfo (f 0 0) 1) + matched = M.zipWithMatched (\_ (RankInfo r iters) f -> RankInfo (f iters r) (iters + 1)) + + !ns = runIdentity $ M.mergeA missingL missingR matched rm_n rnodes + !es = runIdentity $ M.mergeA missingL missingR matched rm_e redges + + +compareSize :: CensusStats -> CensusStats -> Maybe (Int -> Double -> Double) +compareSize (cssize -> Size s1) (cssize -> Size s2) = + if fromIntegral s2 > (1 - default_decay) * fromIntegral s1 + -- Calculate "Q" + then if s1 > s2 + -- Shrinking phase, penalise rank + then Just (\phases rank -> + rank + - ((fromIntegral (phases + 1)) + * ((fromIntegral s1 / fromIntegral s2) - 1))) + else Just (\phases rank -> + rank + + ((fromIntegral (phases + 1)) + * ((fromIntegral s2 / fromIntegral s1) - 1))) + else Nothing + +-- | Compute how to update the ranks based on the difference between two +-- censuses. +ratioRank :: TypePointsFrom -> TypePointsFrom -> (RankUpdateMap Key, RankUpdateMap Edge) +ratioRank t1 t2 = (candidates, redges) + where + ns1 = getNodes t1 + ns2 = getNodes t2 + + es1 = getEdges t1 + es2 = getEdges t2 + missingL = M.dropMissing + missingR = M.dropMissing + matched = M.zipWithMaybeMatched (\_ cs1 cs2 -> compareSize cs1 cs2) + !candidates = runIdentity $ M.mergeA missingL missingR matched ns1 ns2 + + !redges = runIdentity $ M.mergeA missingL missingR matched es1 es2 + + +