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

intToClosurePtr :: Int -> ClosurePtr
intToClosurePtr :: Int -> ClosurePtr
intToClosurePtr Int
i = Word64 -> ClosurePtr
mkClosurePtr (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 (forall a b. (a -> b) -> [a] -> [b]
map ClosurePtr -> Int
closurePtrToInt (forall a. NonEmpty a -> [a]
NE.toList NonEmpty ClosurePtr
groots))
    new_graph :: IntMap IntSet
new_graph = forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
0 IntSet
rootNodes (forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' forall {a}.
IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
collectNodes 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 =  forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k ([Int] -> IntSet
IS.fromList (forall a b. (a -> b) -> [a] -> [b]
map ClosurePtr -> Int
closurePtrToInt (forall a. [Maybe a] -> [a]
catMaybes (forall c a.
DebugClosure
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph HeapGraph a
hg 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 (forall a. HeapGraph a -> Rooted
convertToDom HeapGraph a
hg) of
                Tree.Node Int
0 [Tree Int]
es -> [Tree Int]
es
                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 = 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 = 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)
_) =
  forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
rs (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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 = 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) =  forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry Size
rl
      RetainerSize Int
children_size = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HeapGraphEntry a -> a
hgeData forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 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 = forall a. [(Int, a)] -> IntMap a
IM.fromList ([(forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
cp, HeapGraphEntry a
c) | HeapGraphEntry a
c <- forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Tree (HeapGraphEntry a)
t, let ClosurePtr Word64
cp = forall a. HeapGraphEntry a -> ClosurePtr
hgeClosurePtr HeapGraphEntry a
c ])