{-# 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 -> Int
closurePtrToInt (ClosurePtr Word64
p) = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
p

intToClosurePtr :: Int -> ClosurePtr
intToClosurePtr :: Int -> ClosurePtr
intToClosurePtr Int
i = Word64 -> ClosurePtr
mkClosurePtr (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

convertToDom :: HeapGraph a -> DO.Rooted
convertToDom :: forall a. HeapGraph a -> Rooted
convertToDom  (HeapGraph NonEmpty ClosurePtr
groots IntMap (HeapGraphEntry a)
is) = (Int
0, IntMap IntSet
new_graph)
  where
    rootNodes :: IntSet
rootNodes = [Int] -> IntSet
IS.fromList ((ClosurePtr -> Int) -> [ClosurePtr] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ClosurePtr -> Int
closurePtrToInt (NonEmpty ClosurePtr -> [ClosurePtr]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ClosurePtr
groots))
    new_graph :: IntMap IntSet
new_graph = Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
0 IntSet
rootNodes ((IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet)
-> IntMap IntSet -> IntMap (HeapGraphEntry a) -> IntMap IntSet
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
forall {a}.
IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
collectNodes IntMap IntSet
forall a. IntMap a
IM.empty IntMap (HeapGraphEntry a)
is)
    collectNodes :: IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
collectNodes IntMap IntSet
newMap Int
k HeapGraphEntry a
h =  Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k ([Int] -> IntSet
IS.fromList ((ClosurePtr -> Int) -> [ClosurePtr] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ClosurePtr -> Int
closurePtrToInt ([Maybe ClosurePtr] -> [ClosurePtr]
forall a. [Maybe a] -> [a]
catMaybes (DebugClosure
  (GenPapPayload (Maybe ClosurePtr))
  ConstrDesc
  (GenStackFrames (Maybe ClosurePtr))
  (Maybe ClosurePtr)
-> [Maybe ClosurePtr]
forall c a.
DebugClosure (GenPapPayload c) a (GenStackFrames c) c -> [c]
allClosures (HeapGraphEntry a
-> DebugClosure
     (GenPapPayload (Maybe ClosurePtr))
     ConstrDesc
     (GenStackFrames (Maybe ClosurePtr))
     (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     (GenPapPayload (Maybe ClosurePtr))
     ConstrDesc
     (GenStackFrames (Maybe ClosurePtr))
     (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
h))))) IntMap IntSet
newMap

computeDominators :: HeapGraph a -> [Tree.Tree (HeapGraphEntry a)]
computeDominators :: forall a. HeapGraph a -> [Tree (HeapGraphEntry a)]
computeDominators HeapGraph a
hg = (Tree Int -> Tree (HeapGraphEntry a))
-> [Tree Int] -> [Tree (HeapGraphEntry a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> HeapGraphEntry a) -> Tree Int -> Tree (HeapGraphEntry a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (HeapGraphEntry a) -> HeapGraphEntry a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (HeapGraphEntry a) -> HeapGraphEntry a)
-> (Int -> Maybe (HeapGraphEntry a)) -> Int -> HeapGraphEntry a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a))
-> HeapGraph a -> ClosurePtr -> Maybe (HeapGraphEntry a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
forall a. ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph HeapGraph a
hg (ClosurePtr -> Maybe (HeapGraphEntry a))
-> (Int -> ClosurePtr) -> Int -> Maybe (HeapGraphEntry a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ClosurePtr
intToClosurePtr)) [Tree Int]
gentries
  where
    gentries :: [Tree Int]
gentries = case Rooted -> Tree Int
DO.domTree (HeapGraph a -> Rooted
forall a. HeapGraph a -> Rooted
convertToDom HeapGraph a
hg) of
                Tree.Node Int
0 [Tree Int]
es -> [Tree Int]
es
                Tree Int
_ -> [Char] -> [Tree Int]
forall a. HasCallStack => [Char] -> a
error [Char]
"Dominator tree must contain 0"

retainerSize :: HeapGraph Size -> [Tree.Tree (HeapGraphEntry (Size, RetainerSize))]
retainerSize :: HeapGraph Size -> [Tree (HeapGraphEntry (Size, RetainerSize))]
retainerSize HeapGraph Size
hg = (Tree (HeapGraphEntry Size)
 -> Tree (HeapGraphEntry (Size, RetainerSize)))
-> [Tree (HeapGraphEntry Size)]
-> [Tree (HeapGraphEntry (Size, RetainerSize))]
forall a b. (a -> b) -> [a] -> [b]
map Tree (HeapGraphEntry Size)
-> Tree (HeapGraphEntry (Size, RetainerSize))
bottomUpSize [Tree (HeapGraphEntry Size)]
doms
  where
    doms :: [Tree (HeapGraphEntry Size)]
doms = HeapGraph Size -> [Tree (HeapGraphEntry Size)]
forall a. HeapGraph a -> [Tree (HeapGraphEntry a)]
computeDominators HeapGraph Size
hg

annotateWithRetainerSize :: HeapGraph Size -> HeapGraph (Size, RetainerSize)
annotateWithRetainerSize :: HeapGraph Size -> HeapGraph (Size, RetainerSize)
annotateWithRetainerSize h :: HeapGraph Size
h@(HeapGraph NonEmpty ClosurePtr
rs IntMap (HeapGraphEntry Size)
_) =
  NonEmpty ClosurePtr
-> IntMap (HeapGraphEntry (Size, RetainerSize))
-> HeapGraph (Size, RetainerSize)
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
rs ((Tree (HeapGraphEntry (Size, RetainerSize))
 -> IntMap (HeapGraphEntry (Size, RetainerSize)))
-> [Tree (HeapGraphEntry (Size, RetainerSize))]
-> IntMap (HeapGraphEntry (Size, RetainerSize))
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Tree (HeapGraphEntry (Size, RetainerSize))
-> IntMap (HeapGraphEntry (Size, RetainerSize))
forall a. Tree (HeapGraphEntry a) -> IntMap (HeapGraphEntry a)
convertToHeapGraph (HeapGraph Size -> [Tree (HeapGraphEntry (Size, RetainerSize))]
retainerSize HeapGraph Size
h))

bottomUpSize :: Tree.Tree (HeapGraphEntry Size) -> Tree.Tree (HeapGraphEntry (Size, RetainerSize))
bottomUpSize :: Tree (HeapGraphEntry Size)
-> Tree (HeapGraphEntry (Size, RetainerSize))
bottomUpSize (Tree.Node HeapGraphEntry Size
rl [Tree (HeapGraphEntry Size)]
sf) =
  let ts :: [Tree (HeapGraphEntry (Size, RetainerSize))]
ts = (Tree (HeapGraphEntry Size)
 -> Tree (HeapGraphEntry (Size, RetainerSize)))
-> [Tree (HeapGraphEntry Size)]
-> [Tree (HeapGraphEntry (Size, RetainerSize))]
forall a b. (a -> b) -> [a] -> [b]
map Tree (HeapGraphEntry Size)
-> Tree (HeapGraphEntry (Size, RetainerSize))
bottomUpSize [Tree (HeapGraphEntry Size)]
sf
      s' :: Size
s'@(Size Int
s) =  HeapGraphEntry Size -> Size
forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry Size
rl
      RetainerSize Int
children_size = (Tree (HeapGraphEntry (Size, RetainerSize)) -> RetainerSize)
-> [Tree (HeapGraphEntry (Size, RetainerSize))] -> RetainerSize
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Size, RetainerSize) -> RetainerSize
forall a b. (a, b) -> b
snd ((Size, RetainerSize) -> RetainerSize)
-> (Tree (HeapGraphEntry (Size, RetainerSize))
    -> (Size, RetainerSize))
-> Tree (HeapGraphEntry (Size, RetainerSize))
-> RetainerSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry (Size, RetainerSize) -> (Size, RetainerSize)
forall a. HeapGraphEntry a -> a
hgeData (HeapGraphEntry (Size, RetainerSize) -> (Size, RetainerSize))
-> (Tree (HeapGraphEntry (Size, RetainerSize))
    -> HeapGraphEntry (Size, RetainerSize))
-> Tree (HeapGraphEntry (Size, RetainerSize))
-> (Size, RetainerSize)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (HeapGraphEntry (Size, RetainerSize))
-> HeapGraphEntry (Size, RetainerSize)
forall a. Tree a -> a
Tree.rootLabel) [Tree (HeapGraphEntry (Size, RetainerSize))]
ts
      inclusive_size :: RetainerSize
      !inclusive_size :: RetainerSize
inclusive_size = Int -> RetainerSize
RetainerSize  (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
children_size)
      rl' :: HeapGraphEntry (Size, RetainerSize)
rl' = HeapGraphEntry Size
rl { hgeData :: (Size, RetainerSize)
hgeData = (Size
s', RetainerSize
inclusive_size) }
  in HeapGraphEntry (Size, RetainerSize)
-> [Tree (HeapGraphEntry (Size, RetainerSize))]
-> Tree (HeapGraphEntry (Size, RetainerSize))
forall a. a -> [Tree a] -> Tree a
Tree.Node HeapGraphEntry (Size, RetainerSize)
rl' [Tree (HeapGraphEntry (Size, RetainerSize))]
ts

convertToHeapGraph ::  Tree.Tree (HeapGraphEntry a) -> IM.IntMap (HeapGraphEntry a)
convertToHeapGraph :: forall a. Tree (HeapGraphEntry a) -> IntMap (HeapGraphEntry a)
convertToHeapGraph Tree (HeapGraphEntry a)
t = [(Int, HeapGraphEntry a)] -> IntMap (HeapGraphEntry a)
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cp, HeapGraphEntry a
c) | HeapGraphEntry a
c <- Tree (HeapGraphEntry a) -> [HeapGraphEntry a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Tree (HeapGraphEntry a)
t, let ClosurePtr Word64
cp = HeapGraphEntry a -> ClosurePtr
forall a. HeapGraphEntry a -> ClosurePtr
hgeClosurePtr HeapGraphEntry a
c ])