Skip to content
Snippets Groups Projects

Draft: Progress MR for BLeak Analysis

Open Ethan Kiang requested to merge zyklotomic/ghc-debug:feature/bleak-analysis into master
17 files
+ 1106
50
Compare changes
  • Side-by-side
  • Inline
Files
17
+ 264
0
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GHC.Debug.BLeak where
-- import GHC.Debug.Client.Monad
import GHC.Debug.Types.Ptr()
import GHC.Debug.Client
import GHC.Debug.Types.Closures()
import GHC.Debug.Trace
import GHC.Exts.Heap.ClosureTypes()
import GHC.Debug.ObjectEquivEthan
import qualified Algebra.Graph.AdjacencyMap as G
import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NonEmpty
import qualified Algebra.Graph.AdjacencyIntMap as GI
import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as GIA
import qualified Algebra.Graph.AdjacencyMap.Algorithm as GA
import Control.Monad (forM)
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class
import qualified Control.Monad.State.Strict as State
import qualified Data.Map as M
import qualified Data.Map.Monoidal as MM
import Data.Semigroup
import qualified Data.Set as S
import qualified Data.List.NonEmpty as NE
import Data.Coerce
import qualified Data.IntSet as IntS
import Data.Maybe (catMaybes, fromMaybe, fromJust)
import Debug.Trace
newtype Count = Count Integer deriving (Ord, Eq, Num, Show)
-- A node still being tracked is implicitly growing, since
-- we no longer consider a node if it ever was *not* growing
-- in any iteration.
-- src: page 20 of BLeak, n'.growing = n.growing && |E| < |E'|
-- GrowthHistory in reverse chrono order
newtype GrowthHistory = GrowthHistory (NE.NonEmpty Count) deriving Show
prevCnt :: GrowthHistory -> Count
prevCnt = NE.head . coerce
insertCnt :: Count -> GrowthHistory -> GrowthHistory
insertCnt c (GrowthHistory h) = GrowthHistory (c `NE.cons` h)
-- `components` is a map from closure representative to equivalence class,
-- defined by the partition of strongly connected components
newtype SccRep = SccRep Int deriving (Eq, Ord) -- TODO: Make the adjacency IntMap type safe
data SccDAG = SccDAG
{ dag :: GI.AdjacencyIntMap
, components :: M.Map ClosurePtr SccRep
}
-- SccDAG where each scc node has a corresponding weight
data SccDAGWeighted a where
SccDAGWeighted :: (Num a) =>
{ sccDag :: SccDAG
, weightMap :: M.Map SccRep a
} -> SccDAGWeighted a
-- SccDAG, but with the net size of each scc
-- data SizedSccDAG = SizedSccDAG { sizes :: M.Map Int Integer }
-- Directed graph representing closure pointing to
-- closure relationships
type BLeakGraph = G.AdjacencyMap ClosurePtr
-- Intermediary data structure representing maximum number
-- of reachable nodes found per closure representative, used to
-- later determine whether said representative is growing or not
-- type ReachableCounts a = MM.MonoidalMap ClosureRepresentative (Max a)
-- Map from SCC to reachable counts
type ReachableCountsScc a = M.Map SccRep a
-- Maximum reachable count per closure
type MaxReachableClosureRep a = M.Map ClosureRep a
-- Growth status of each closure representative found per iteration
type BLeakGrowthMap = MaxReachableClosureRep GrowthHistory
-- Map containing maximum reachable transitive size per closure rep
type TransitiveSizeMap = MaxReachableClosureRep Size
bleakFirstIteration :: [ClosurePtr] -> DebugM BLeakGrowthMap
bleakFirstIteration cp =
buildBLeakGraph (const True) cp
>>= maxReachableClosCount
>>= return . firstIterGrowth
bleakIteration :: [ClosurePtr] -> BLeakGrowthMap -> DebugM BLeakGrowthMap
bleakIteration cps prevGrowth =
buildBLeakGraph cond cps
>>= maxReachableClosCount
>>= return . propogateGrowth prevGrowth
where
cond = const True
buildBLeakGraph :: (ClosureRep -> Bool) -> [ClosurePtr] -> DebugM BLeakGraph
buildBLeakGraph cond cp = execStateT (traceFromM (traceClosurePtrs cond) cp) G.empty
buildTransitiveSizeMap :: [ClosurePtr] -> DebugM TransitiveSizeMap
buildTransitiveSizeMap cp = buildBLeakGraph (const True) cp >>= maxReachableTransitiveSize
maxReachableClosCount :: BLeakGraph -> DebugM (MaxReachableClosureRep Count)
maxReachableClosCount bg = calcMaxReachableByClosRep d r
where
d :: SccDAG
d = buildSccDAG bg
d' :: SccDAGWeighted Count
d' = addSccSetSize d
r :: ReachableCountsScc Count
r = memoizedReachable d'
-- TODO: Prevent calculation of scc twice, by passing it from a bleak iteration
maxReachableTransitiveSize :: BLeakGraph -> DebugM (MaxReachableClosureRep Size)
maxReachableTransitiveSize bg = do
d' <- addSccNetClosuresSize d
calcMaxReachableByClosRep d (memoizedReachable d')
where
d = buildSccDAG bg
buildSccDAG :: BLeakGraph -> SccDAG
buildSccDAG bg = SccDAG scc comps
where
scc' :: G.AdjacencyMap (NonEmpty.AdjacencyMap ClosurePtr)
scc' = GA.scc bg
comps :: M.Map ClosurePtr SccRep
comps = M.fromList $ do
(component, idx) <- zip ((S.toList . G.vertexSet) scc') [0..]
(cp, idx) <- map (,idx) ((S.toList . NonEmpty.vertexSet) component)
return (cp, SccRep idx)
scc :: GI.AdjacencyIntMap
scc = GI.fromAdjacencyMap adjM
where
componentToEquiv :: NonEmpty.AdjacencyMap ClosurePtr -> SccRep
componentToEquiv comp = fromJust (M.lookup cp comps)
where
cp = head . S.toList . NonEmpty.vertexSet $ comp
-- TODO: Fix because of newtype-ed SccRep
adjM = G.gmap (coerce . componentToEquiv) scc'
addSccSetSize :: SccDAG -> SccDAGWeighted Count
addSccSetSize s@(SccDAG d comps) = SccDAGWeighted s w
where
w :: M.Map SccRep Count
w = fmap (Count . getSum) $ MM.getMonoidalMap . mconcat $
-- Count the number of elements for each representative
map (\(_cp, rep) -> (MM.singleton rep (Sum 1))) (M.toList comps)
addSccNetClosuresSize :: SccDAG -> DebugM (SccDAGWeighted Size)
addSccNetClosuresSize s@(SccDAG d comps) = do
weights :: M.Map SccRep Size <- MM.getMonoidalMap . mconcat <$> do
forM (M.toList comps) $ \(cp, rep) -> do
closSize <- dcSize <$> dereferenceClosure cp
return $ MM.singleton rep closSize
return $ SccDAGWeighted s weights
-- TODO: Allow newtype Int within IntSet / IntMap
-- Note: Num a typeclass restriction should already be in SccDAGWeighted
-- maybe GHC can't infer at the moment?
memoizedReachable :: forall a. Num a => SccDAGWeighted a -> ReachableCountsScc a
memoizedReachable sccw = State.execState (mapM_ dfs vtxs) mempty
where
dag' = (dag . sccDag) sccw
vtxs = fmap SccRep $ GI.vertexList $ (dag . sccDag) sccw
weights = weightMap sccw
dfs :: SccRep -> State.State (ReachableCountsScc a) a
dfs rep = do
isVisited <- M.lookup rep <$> get
case isVisited of
Just cnt -> return cnt
Nothing -> do
let adjVtxs = GI.postIntSet (coerce rep) dag'
-- The weight should be in the weightMap due to its construction
repWeight = fromJust $ M.lookup rep weights
if IntS.null adjVtxs
then do
modify' (M.insert rep repWeight)
return repWeight
else do
childReachables <- mapM dfs (SccRep <$> (IntS.toList adjVtxs))
let netReachable = sum (repWeight : childReachables)
modify' (M.insert rep netReachable)
return netReachable
-- Might have a use in it being general, with LeakShare
-- Note: Same issue as memoizedReachable, unable
-- to infer typeclasses
calcMaxReachableByClosRep :: forall a. (Num a, Ord a)
=> SccDAG
-> ReachableCountsScc a
-> DebugM (MaxReachableClosureRep a)
calcMaxReachableByClosRep s@(SccDAG _ comps) rcs = do
mmap :: MM.MonoidalMap ClosureRep (Max a) <- mconcat <$> do
forM (M.toList comps) $ \(cp, sccRep) -> do
sc <- dereferenceClosure cp
closRep <- quotientClosure sc
let reachableCnt = fromJust $ M.lookup sccRep rcs
return $ MM.singleton closRep (Max reachableCnt)
return $ getMax <$> MM.getMonoidalMap mmap
firstIterGrowth :: MaxReachableClosureRep Count -> BLeakGrowthMap
firstIterGrowth = fmap singletonGrowth
where
-- Page 19 of BLeak, conservatively mark all as "Growing"
singletonGrowth :: Count -> GrowthHistory
singletonGrowth c = GrowthHistory (NE.singleton c)
propogateGrowth :: BLeakGrowthMap
-> MaxReachableClosureRep Count
-> BLeakGrowthMap
propogateGrowth prevGrowth r = M.mapMaybeWithKey cmp prevGrowth
where
-- Compare with previous growth status
cmp :: ClosureRep -> GrowthHistory -> Maybe GrowthHistory
cmp cr gs = case M.lookup cr r of
Nothing -> Nothing
Just c -> if (prevCnt gs) < c
then (Just (insertCnt c gs))
else Nothing
-- TODO: Use the Graph module directly instead?
-- Would require a rewrite of propogateGrowth, because
-- we are taking advantage of the algorithms implemented
-- in the alga library
traceClosurePtrs :: (ClosureRep -> Bool) -> TraceFunctions (StateT BLeakGraph)
traceClosurePtrs cond = TraceFunctions
{ papTrace = const (return ())
, stackTrace = const (return ())
, closTrace = go
, visitedVal = const (return ())
, conDescTrace = const (return ())
}
where
go cp sc m = do
cr <- lift $ quotientClosure sc
if cond cr
-- TODO: Maybe add singleton vertices if no adjacent closuresr from `getPtrs`?
then mapM_ (\ptr -> modify' (G.overlay (G.edge cp ptr))) (getPtrs (noSize sc))
else return ()
m
Loading