{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE NamedFieldPuns #-}
module GHC.Debug.Types.Graph(
HeapGraph(..)
, HeapGraphEntry(..)
, HeapGraphIndex
, PapHI
, StackHI
, SrtHI
, DerefFunction
, buildHeapGraph
, multiBuildHeapGraph
, generalBuildHeapGraph
, ppHeapGraph
, ppClosure
, lookupHeapGraph
, traverseHeapGraph
, updateHeapGraph
, heapGraphSize
, annotateHeapGraph
, ReverseGraph
, mkReverseGraph
, reverseEdges
)
where
import Data.Char
import Data.List (intercalate, foldl', sort, group, sortBy, groupBy)
import Data.Maybe ( catMaybes )
import Data.Function
import qualified Data.HashMap.Strict as M
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import GHC.Debug.Types.Ptr
import GHC.Debug.Types.Closures
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
import Data.Bitraversable
data HeapGraphEntry a = HeapGraphEntry {
forall a. HeapGraphEntry a -> ClosurePtr
hgeClosurePtr :: ClosurePtr,
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure :: DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe HeapGraphIndex),
forall a. HeapGraphEntry a -> a
hgeData :: a}
deriving (Int -> HeapGraphEntry a -> ShowS
[HeapGraphEntry a] -> ShowS
HeapGraphEntry a -> String
(Int -> HeapGraphEntry a -> ShowS)
-> (HeapGraphEntry a -> String)
-> ([HeapGraphEntry a] -> ShowS)
-> Show (HeapGraphEntry a)
forall a. Show a => Int -> HeapGraphEntry a -> ShowS
forall a. Show a => [HeapGraphEntry a] -> ShowS
forall a. Show a => HeapGraphEntry a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> HeapGraphEntry a -> ShowS
showsPrec :: Int -> HeapGraphEntry a -> ShowS
$cshow :: forall a. Show a => HeapGraphEntry a -> String
show :: HeapGraphEntry a -> String
$cshowList :: forall a. Show a => [HeapGraphEntry a] -> ShowS
showList :: [HeapGraphEntry a] -> ShowS
Show, (forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b)
-> (forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a)
-> Functor HeapGraphEntry
forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
fmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
$c<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
Functor, (forall m. Monoid m => HeapGraphEntry m -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m)
-> (forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b)
-> (forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b)
-> (forall a. (a -> a -> a) -> HeapGraphEntry a -> a)
-> (forall a. (a -> a -> a) -> HeapGraphEntry a -> a)
-> (forall a. HeapGraphEntry a -> [a])
-> (forall a. HeapGraphEntry a -> Bool)
-> (forall a. HeapGraphEntry a -> Int)
-> (forall a. Eq a => a -> HeapGraphEntry a -> Bool)
-> (forall a. Ord a => HeapGraphEntry a -> a)
-> (forall a. Ord a => HeapGraphEntry a -> a)
-> (forall a. Num a => HeapGraphEntry a -> a)
-> (forall a. Num a => HeapGraphEntry a -> a)
-> Foldable HeapGraphEntry
forall a. Eq a => a -> HeapGraphEntry a -> Bool
forall a. Num a => HeapGraphEntry a -> a
forall a. Ord a => HeapGraphEntry a -> a
forall m. Monoid m => HeapGraphEntry m -> m
forall a. HeapGraphEntry a -> Bool
forall a. HeapGraphEntry a -> Int
forall a. HeapGraphEntry a -> [a]
forall a. (a -> a -> a) -> HeapGraphEntry a -> a
forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => HeapGraphEntry m -> m
fold :: forall m. Monoid m => HeapGraphEntry m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
foldr :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
foldl :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> HeapGraphEntry a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
foldr1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
foldl1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
$ctoList :: forall a. HeapGraphEntry a -> [a]
toList :: forall a. HeapGraphEntry a -> [a]
$cnull :: forall a. HeapGraphEntry a -> Bool
null :: forall a. HeapGraphEntry a -> Bool
$clength :: forall a. HeapGraphEntry a -> Int
length :: forall a. HeapGraphEntry a -> Int
$celem :: forall a. Eq a => a -> HeapGraphEntry a -> Bool
elem :: forall a. Eq a => a -> HeapGraphEntry a -> Bool
$cmaximum :: forall a. Ord a => HeapGraphEntry a -> a
maximum :: forall a. Ord a => HeapGraphEntry a -> a
$cminimum :: forall a. Ord a => HeapGraphEntry a -> a
minimum :: forall a. Ord a => HeapGraphEntry a -> a
$csum :: forall a. Num a => HeapGraphEntry a -> a
sum :: forall a. Num a => HeapGraphEntry a -> a
$cproduct :: forall a. Num a => HeapGraphEntry a -> a
product :: forall a. Num a => HeapGraphEntry a -> a
Foldable, Functor HeapGraphEntry
Foldable HeapGraphEntry
(Functor HeapGraphEntry, Foldable HeapGraphEntry) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b))
-> (forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b))
-> (forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a))
-> Traversable HeapGraphEntry
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraphEntry a -> f (HeapGraphEntry b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
sequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
Traversable)
type HeapGraphIndex = ClosurePtr
type StackHI = GenStackFrames (GenSrtPayload (Maybe HeapGraphIndex)) (Maybe HeapGraphIndex)
type PapHI = GenPapPayload (Maybe HeapGraphIndex)
type SrtHI = GenSrtPayload (Maybe HeapGraphIndex)
data HeapGraph a = HeapGraph
{ forall a. HeapGraph a -> NonEmpty ClosurePtr
roots :: !(NE.NonEmpty ClosurePtr)
, forall a. HeapGraph a -> IntMap (HeapGraphEntry a)
graph :: !(IM.IntMap (HeapGraphEntry a)) }
deriving (Int -> HeapGraph a -> ShowS
[HeapGraph a] -> ShowS
HeapGraph a -> String
(Int -> HeapGraph a -> ShowS)
-> (HeapGraph a -> String)
-> ([HeapGraph a] -> ShowS)
-> Show (HeapGraph a)
forall a. Show a => Int -> HeapGraph a -> ShowS
forall a. Show a => [HeapGraph a] -> ShowS
forall a. Show a => HeapGraph a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> HeapGraph a -> ShowS
showsPrec :: Int -> HeapGraph a -> ShowS
$cshow :: forall a. Show a => HeapGraph a -> String
show :: HeapGraph a -> String
$cshowList :: forall a. Show a => [HeapGraph a] -> ShowS
showList :: [HeapGraph a] -> ShowS
Show, (forall m. Monoid m => HeapGraph m -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraph a -> m)
-> (forall m a. Monoid m => (a -> m) -> HeapGraph a -> m)
-> (forall a b. (a -> b -> b) -> b -> HeapGraph a -> b)
-> (forall a b. (a -> b -> b) -> b -> HeapGraph a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraph a -> b)
-> (forall b a. (b -> a -> b) -> b -> HeapGraph a -> b)
-> (forall a. (a -> a -> a) -> HeapGraph a -> a)
-> (forall a. (a -> a -> a) -> HeapGraph a -> a)
-> (forall a. HeapGraph a -> [a])
-> (forall a. HeapGraph a -> Bool)
-> (forall a. HeapGraph a -> Int)
-> (forall a. Eq a => a -> HeapGraph a -> Bool)
-> (forall a. Ord a => HeapGraph a -> a)
-> (forall a. Ord a => HeapGraph a -> a)
-> (forall a. Num a => HeapGraph a -> a)
-> (forall a. Num a => HeapGraph a -> a)
-> Foldable HeapGraph
forall a. Eq a => a -> HeapGraph a -> Bool
forall a. Num a => HeapGraph a -> a
forall a. Ord a => HeapGraph a -> a
forall m. Monoid m => HeapGraph m -> m
forall a. HeapGraph a -> Bool
forall a. HeapGraph a -> Int
forall a. HeapGraph a -> [a]
forall a. (a -> a -> a) -> HeapGraph a -> a
forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => HeapGraph m -> m
fold :: forall m. Monoid m => HeapGraph m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
foldr :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
foldl :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> HeapGraph a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
foldr1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
foldl1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
$ctoList :: forall a. HeapGraph a -> [a]
toList :: forall a. HeapGraph a -> [a]
$cnull :: forall a. HeapGraph a -> Bool
null :: forall a. HeapGraph a -> Bool
$clength :: forall a. HeapGraph a -> Int
length :: forall a. HeapGraph a -> Int
$celem :: forall a. Eq a => a -> HeapGraph a -> Bool
elem :: forall a. Eq a => a -> HeapGraph a -> Bool
$cmaximum :: forall a. Ord a => HeapGraph a -> a
maximum :: forall a. Ord a => HeapGraph a -> a
$cminimum :: forall a. Ord a => HeapGraph a -> a
minimum :: forall a. Ord a => HeapGraph a -> a
$csum :: forall a. Num a => HeapGraph a -> a
sum :: forall a. Num a => HeapGraph a -> a
$cproduct :: forall a. Num a => HeapGraph a -> a
product :: forall a. Num a => HeapGraph a -> a
Foldable, Functor HeapGraph
Foldable HeapGraph
(Functor HeapGraph, Foldable HeapGraph) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraph a -> f (HeapGraph b))
-> (forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b))
-> (forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a))
-> Traversable HeapGraph
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraph a -> f (HeapGraph b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraph a -> f (HeapGraph b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> HeapGraph a -> f (HeapGraph b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
sequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
Traversable, (forall a b. (a -> b) -> HeapGraph a -> HeapGraph b)
-> (forall a b. a -> HeapGraph b -> HeapGraph a)
-> Functor HeapGraph
forall a b. a -> HeapGraph b -> HeapGraph a
forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
fmap :: forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
$c<$ :: forall a b. a -> HeapGraph b -> HeapGraph a
<$ :: forall a b. a -> HeapGraph b -> HeapGraph a
Functor)
traverseHeapGraph :: Applicative m =>
(HeapGraphEntry a -> m (HeapGraphEntry b))
-> HeapGraph a
-> m (HeapGraph b)
traverseHeapGraph :: forall (m :: * -> *) a b.
Applicative m =>
(HeapGraphEntry a -> m (HeapGraphEntry b))
-> HeapGraph a -> m (HeapGraph b)
traverseHeapGraph HeapGraphEntry a -> m (HeapGraphEntry b)
f (HeapGraph NonEmpty ClosurePtr
r IntMap (HeapGraphEntry a)
im) = NonEmpty ClosurePtr -> IntMap (HeapGraphEntry b) -> HeapGraph b
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r (IntMap (HeapGraphEntry b) -> HeapGraph b)
-> m (IntMap (HeapGraphEntry b)) -> m (HeapGraph b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HeapGraphEntry a -> m (HeapGraphEntry b))
-> IntMap (HeapGraphEntry a) -> m (IntMap (HeapGraphEntry b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntMap a -> f (IntMap b)
traverse HeapGraphEntry a -> m (HeapGraphEntry b)
f IntMap (HeapGraphEntry a)
im
lookupHeapGraph :: HeapGraphIndex -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph :: forall a. ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph (ClosurePtr Word64
i) (HeapGraph NonEmpty ClosurePtr
_r IntMap (HeapGraphEntry a)
m) = Int -> IntMap (HeapGraphEntry a) -> Maybe (HeapGraphEntry a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) IntMap (HeapGraphEntry a)
m
insertHeapGraph :: HeapGraphIndex -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
insertHeapGraph :: forall a.
ClosurePtr -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
insertHeapGraph (ClosurePtr Word64
i) HeapGraphEntry a
a (HeapGraph NonEmpty ClosurePtr
r IntMap (HeapGraphEntry a)
m) = NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r (Int
-> HeapGraphEntry a
-> IntMap (HeapGraphEntry a)
-> IntMap (HeapGraphEntry a)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) HeapGraphEntry a
a IntMap (HeapGraphEntry a)
m)
updateHeapGraph :: (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> HeapGraphIndex
-> HeapGraph a
-> HeapGraph a
updateHeapGraph :: forall a.
(HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> ClosurePtr -> HeapGraph a -> HeapGraph a
updateHeapGraph HeapGraphEntry a -> Maybe (HeapGraphEntry a)
f (ClosurePtr Word64
i) (HeapGraph NonEmpty ClosurePtr
r IntMap (HeapGraphEntry a)
m) = NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r ((HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> Int -> IntMap (HeapGraphEntry a) -> IntMap (HeapGraphEntry a)
forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.update HeapGraphEntry a -> Maybe (HeapGraphEntry a)
f (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) IntMap (HeapGraphEntry a)
m)
heapGraphSize :: HeapGraph a -> Int
heapGraphSize :: forall a. HeapGraph a -> Int
heapGraphSize (HeapGraph NonEmpty ClosurePtr
_ IntMap (HeapGraphEntry a)
g) = IntMap (HeapGraphEntry a) -> Int
forall a. IntMap a -> Int
IM.size IntMap (HeapGraphEntry a)
g
buildHeapGraph
:: (MonadFix m)
=> DerefFunction m a
-> Maybe Int
-> ClosurePtr
-> m (HeapGraph a)
buildHeapGraph :: forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a -> Maybe Int -> ClosurePtr -> m (HeapGraph a)
buildHeapGraph DerefFunction m a
deref Maybe Int
limit ClosurePtr
initialBox =
DerefFunction m a
-> Maybe Int -> NonEmpty ClosurePtr -> m (HeapGraph a)
forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int -> NonEmpty ClosurePtr -> m (HeapGraph a)
multiBuildHeapGraph DerefFunction m a
deref Maybe Int
limit (ClosurePtr -> NonEmpty ClosurePtr
forall a. a -> NonEmpty a
NE.singleton ClosurePtr
initialBox)
type DerefFunction m a = ClosurePtr -> m (DebugClosureWithExtra a SrtPayload PapPayload ConstrDesc (GenStackFrames SrtPayload ClosurePtr) ClosurePtr)
multiBuildHeapGraph
:: (MonadFix m)
=> DerefFunction m a
-> Maybe Int
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
multiBuildHeapGraph :: forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int -> NonEmpty ClosurePtr -> m (HeapGraph a)
multiBuildHeapGraph DerefFunction m a
deref Maybe Int
limit NonEmpty ClosurePtr
rs =
DerefFunction m a
-> Maybe Int
-> HeapGraph a
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int
-> HeapGraph a
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
generalBuildHeapGraph DerefFunction m a
deref Maybe Int
limit (NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
rs IntMap (HeapGraphEntry a)
forall a. IntMap a
IM.empty) NonEmpty ClosurePtr
rs
{-# INLINE multiBuildHeapGraph #-}
annotateHeapGraph :: (a -> a) -> HeapGraphIndex -> HeapGraph a -> HeapGraph a
annotateHeapGraph :: forall a. (a -> a) -> ClosurePtr -> HeapGraph a -> HeapGraph a
annotateHeapGraph a -> a
f ClosurePtr
i HeapGraph a
hg = (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> ClosurePtr -> HeapGraph a -> HeapGraph a
forall a.
(HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> ClosurePtr -> HeapGraph a -> HeapGraph a
updateHeapGraph HeapGraphEntry a -> Maybe (HeapGraphEntry a)
go ClosurePtr
i HeapGraph a
hg
where
go :: HeapGraphEntry a -> Maybe (HeapGraphEntry a)
go HeapGraphEntry a
hge = HeapGraphEntry a -> Maybe (HeapGraphEntry a)
forall a. a -> Maybe a
Just (HeapGraphEntry a -> Maybe (HeapGraphEntry a))
-> HeapGraphEntry a -> Maybe (HeapGraphEntry a)
forall a b. (a -> b) -> a -> b
$ HeapGraphEntry a
hge { hgeData = f (hgeData hge) }
{-# INLINE generalBuildHeapGraph #-}
generalBuildHeapGraph
:: forall m a . (MonadFix m)
=> DerefFunction m a
-> Maybe Int
-> HeapGraph a
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
generalBuildHeapGraph :: forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int
-> HeapGraph a
-> NonEmpty ClosurePtr
-> m (HeapGraph a)
generalBuildHeapGraph DerefFunction m a
deref Maybe Int
limit HeapGraph a
hg NonEmpty ClosurePtr
addBoxes = do
(NonEmpty (Maybe ClosurePtr)
_is, HeapGraph a
hg') <- StateT (HeapGraph a) m (NonEmpty (Maybe ClosurePtr))
-> HeapGraph a -> m (NonEmpty (Maybe ClosurePtr), HeapGraph a)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> NonEmpty ClosurePtr
-> StateT (HeapGraph a) m (NonEmpty (Maybe ClosurePtr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Maybe Int
-> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add Maybe Int
limit) NonEmpty ClosurePtr
addBoxes) HeapGraph a
hg
HeapGraph a -> m (HeapGraph a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return HeapGraph a
hg'
where
add :: Maybe Int -> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add :: Maybe Int
-> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add (Just Int
0) ClosurePtr
_ = Maybe ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
forall a. a -> StateT (HeapGraph a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ClosurePtr
forall a. Maybe a
Nothing
add Maybe Int
n ClosurePtr
cp = do
HeapGraph a
hm <- StateT (HeapGraph a) m (HeapGraph a)
forall (m :: * -> *) s. Monad m => StateT s m s
get
case ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
forall a. ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph ClosurePtr
cp HeapGraph a
hm of
Just {} -> Maybe ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
forall a. a -> StateT (HeapGraph a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosurePtr -> Maybe ClosurePtr
forall a. a -> Maybe a
Just ClosurePtr
cp)
Maybe (HeapGraphEntry a)
Nothing -> mdo
DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr
c <- m (DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr)
-> StateT
(HeapGraph a)
m
(DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr)
forall (m :: * -> *) a. Monad m => m a -> StateT (HeapGraph a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr)
-> StateT
(HeapGraph a)
m
(DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr))
-> m (DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr)
-> StateT
(HeapGraph a)
m
(DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr)
forall a b. (a -> b) -> a -> b
$ DerefFunction m a
deref ClosurePtr
cp
let new_add :: ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add = Maybe Int
-> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
n)
rec (HeapGraph a -> HeapGraph a) -> StateT (HeapGraph a) m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (ClosurePtr -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
forall a.
ClosurePtr -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
insertHeapGraph ClosurePtr
cp (ClosurePtr
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> a
-> HeapGraphEntry a
forall a.
ClosurePtr
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> a
-> HeapGraphEntry a
HeapGraphEntry ClosurePtr
cp DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' a
e))
DCS a
e DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' <- (SrtPayload -> StateT (HeapGraph a) m SrtHI)
-> (PapPayload -> StateT (HeapGraph a) m PapHI)
-> (ConstrDesc -> StateT (HeapGraph a) m ConstrDesc)
-> (GenStackFrames SrtPayload ClosurePtr
-> StateT (HeapGraph a) m StackHI)
-> (ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr
-> StateT
(HeapGraph a)
m
(DebugClosureWithExtra
a SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra a a c e h j
-> f (DebugClosureWithExtra a b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> SrtPayload -> StateT (HeapGraph a) m SrtHI
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenSrtPayload a -> f (GenSrtPayload b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> PapPayload -> StateT (HeapGraph a) m PapHI
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenPapPayload a -> f (GenPapPayload b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ConstrDesc -> StateT (HeapGraph a) m ConstrDesc
forall a. a -> StateT (HeapGraph a) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SrtPayload -> StateT (HeapGraph a) m SrtHI)
-> (ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> GenStackFrames SrtPayload ClosurePtr
-> StateT (HeapGraph a) m StackHI
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d) -> GenStackFrames a b -> f (GenStackFrames c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ((ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr))
-> SrtPayload -> StateT (HeapGraph a) m SrtHI
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenSrtPayload a -> f (GenSrtPayload b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr
c
Maybe ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
forall a. a -> StateT (HeapGraph a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosurePtr -> Maybe ClosurePtr
forall a. a -> Maybe a
Just ClosurePtr
cp)
ppHeapGraph :: (a -> String) -> HeapGraph a -> String
ppHeapGraph :: forall a. (a -> String) -> HeapGraph a -> String
ppHeapGraph a -> String
printData (HeapGraph (ClosurePtr
heapGraphRoot :| [ClosurePtr]
rs) IntMap (HeapGraphEntry a)
m) = String
letWrapper String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
printData (HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
heapGraphRoot)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
roots
where
bindings :: [ClosurePtr]
bindings = HeapGraph a -> [ClosurePtr] -> [ClosurePtr]
forall a. HeapGraph a -> [ClosurePtr] -> [ClosurePtr]
boundMultipleTimes (NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph (ClosurePtr
heapGraphRoot ClosurePtr -> [ClosurePtr] -> NonEmpty ClosurePtr
forall a. a -> [a] -> NonEmpty a
:| [ClosurePtr]
rs) IntMap (HeapGraphEntry a)
m) [ClosurePtr
heapGraphRoot]
roots :: String
roots = [String] -> String
unlines [
String
"r" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
printData (HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
r)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Maybe ClosurePtr -> String
ppRef Int
0 (ClosurePtr -> Maybe ClosurePtr
forall a. a -> Maybe a
Just ClosurePtr
r) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
| (Int
n, ClosurePtr
r) <- [Int] -> [ClosurePtr] -> [(Int, ClosurePtr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (ClosurePtr
heapGraphRoot ClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
: [ClosurePtr]
rs) ]
letWrapper :: String
letWrapper =
if [ClosurePtr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClosurePtr]
bindings
then String
""
else String
"let " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n " ((ClosurePtr -> String) -> [ClosurePtr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ClosurePtr -> String
ppBinding [ClosurePtr]
bindings) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nin "
bindingLetter :: ClosurePtr -> Char
bindingLetter ClosurePtr
i = case HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i) of
ThunkClosure {} -> Char
't'
SelectorClosure {} -> Char
't'
APClosure {} -> Char
't'
PAPClosure {} -> Char
'f'
BCOClosure {} -> Char
't'
FunClosure {} -> Char
'f'
DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
_ -> Char
'x'
ppBindingMap :: HashMap ClosurePtr String
ppBindingMap = [(ClosurePtr, String)] -> HashMap ClosurePtr String
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(ClosurePtr, String)] -> HashMap ClosurePtr String)
-> [(ClosurePtr, String)] -> HashMap ClosurePtr String
forall a b. (a -> b) -> a -> b
$
([(ClosurePtr, Char)] -> [(ClosurePtr, String)])
-> [[(ClosurePtr, Char)]] -> [(ClosurePtr, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Int -> (ClosurePtr, Char) -> (ClosurePtr, String))
-> [Int] -> [(ClosurePtr, Char)] -> [(ClosurePtr, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
j (ClosurePtr
i,Char
c) -> (ClosurePtr
i, Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
j)) [(Int
1::Int)..]) ([[(ClosurePtr, Char)]] -> [(ClosurePtr, String)])
-> [[(ClosurePtr, Char)]] -> [(ClosurePtr, String)]
forall a b. (a -> b) -> a -> b
$
((ClosurePtr, Char) -> (ClosurePtr, Char) -> Bool)
-> [(ClosurePtr, Char)] -> [[(ClosurePtr, Char)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Char -> Char -> Bool)
-> ((ClosurePtr, Char) -> Char)
-> (ClosurePtr, Char)
-> (ClosurePtr, Char)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ClosurePtr, Char) -> Char
forall a b. (a, b) -> b
snd) ([(ClosurePtr, Char)] -> [[(ClosurePtr, Char)]])
-> [(ClosurePtr, Char)] -> [[(ClosurePtr, Char)]]
forall a b. (a -> b) -> a -> b
$
((ClosurePtr, Char) -> (ClosurePtr, Char) -> Ordering)
-> [(ClosurePtr, Char)] -> [(ClosurePtr, Char)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Char -> Char -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Char -> Char -> Ordering)
-> ((ClosurePtr, Char) -> Char)
-> (ClosurePtr, Char)
-> (ClosurePtr, Char)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ClosurePtr, Char) -> Char
forall a b. (a, b) -> b
snd)
[ (ClosurePtr
i, ClosurePtr -> Char
bindingLetter ClosurePtr
i) | ClosurePtr
i <- [ClosurePtr]
bindings ]
ppVar :: ClosurePtr -> String
ppVar ClosurePtr
i = HashMap ClosurePtr String
ppBindingMap HashMap ClosurePtr String -> ClosurePtr -> String
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
M.! ClosurePtr
i
ppBinding :: ClosurePtr -> String
ppBinding ClosurePtr
i = ClosurePtr -> String
ppVar ClosurePtr
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
printData (HeapGraphEntry a -> a
forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> HeapGraphEntry a -> String
ppEntry Int
0 (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i)
ppEntry :: Int -> HeapGraphEntry a -> String
ppEntry Int
prec HeapGraphEntry a
hge
| Just String
s <- DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe String
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr) -> Maybe String
isString (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge) = ShowS
forall a. Show a => a -> String
show String
s
| Just [Maybe ClosurePtr]
l <- DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge) = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((Maybe ClosurePtr -> String) -> [Maybe ClosurePtr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe ClosurePtr -> String
ppRef Int
0) [Maybe ClosurePtr]
l) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
| Bool
otherwise = (Int -> Maybe ClosurePtr -> String)
-> Int
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> String
forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure Int -> Maybe ClosurePtr -> String
ppRef Int
prec (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge)
where
_app :: [String] -> String
_app [String
a] = String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"()"
_app [String]
xs = Bool -> ShowS
addBraces (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([String] -> String
unwords [String]
xs)
ppRef :: Int -> Maybe ClosurePtr -> String
ppRef Int
_ Maybe ClosurePtr
Nothing = String
"..."
ppRef Int
prec (Just ClosurePtr
i) | ClosurePtr
i ClosurePtr -> [ClosurePtr] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ClosurePtr]
bindings = ClosurePtr -> String
ppVar ClosurePtr
i
| Bool
otherwise = Int -> HeapGraphEntry a -> String
ppEntry Int
prec (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i)
iToE :: ClosurePtr -> HeapGraphEntry a
iToE (ClosurePtr Word64
i) = IntMap (HeapGraphEntry a)
m IntMap (HeapGraphEntry a) -> Int -> HeapGraphEntry a
forall a. IntMap a -> Int -> a
IM.! (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
iToUnboundE :: ClosurePtr -> Maybe (HeapGraphEntry a)
iToUnboundE cp :: ClosurePtr
cp@(ClosurePtr Word64
i)
| ClosurePtr
cp ClosurePtr -> [ClosurePtr] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ClosurePtr]
bindings = Maybe (HeapGraphEntry a)
forall a. Maybe a
Nothing
| Bool
otherwise = Int -> IntMap (HeapGraphEntry a) -> Maybe (HeapGraphEntry a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i) IntMap (HeapGraphEntry a)
m
isList :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex]
isList :: forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
c
| DebugClosure srt p ConstrDesc s (Maybe ClosurePtr) -> Bool
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Bool
isNil DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
c =
[Maybe ClosurePtr] -> Maybe [Maybe ClosurePtr]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = do
(Maybe ClosurePtr
h,Maybe ClosurePtr
t) <- DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe (Maybe ClosurePtr, Maybe ClosurePtr)
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
c
ClosurePtr
ti <- Maybe ClosurePtr
t
HeapGraphEntry a
e <- ClosurePtr -> Maybe (HeapGraphEntry a)
iToUnboundE ClosurePtr
ti
[Maybe ClosurePtr]
t' <- DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
e)
return $ (:) Maybe ClosurePtr
h [Maybe ClosurePtr]
t'
isString :: DebugClosure srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe String
isString :: forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr) -> Maybe String
isString DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
e = do
[Maybe ClosurePtr]
list <- DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
e
if [Maybe ClosurePtr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe ClosurePtr]
list
then Maybe String
forall a. Maybe a
Nothing
else (Maybe ClosurePtr -> Maybe Char)
-> [Maybe ClosurePtr] -> Maybe String
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe Char
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar (DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe Char)
-> (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
-> HeapGraphEntry a
-> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure (HeapGraphEntry a -> Maybe Char)
-> (Maybe ClosurePtr -> Maybe (HeapGraphEntry a))
-> Maybe ClosurePtr
-> Maybe Char
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ClosurePtr -> Maybe (HeapGraphEntry a)
iToUnboundE (ClosurePtr -> Maybe (HeapGraphEntry a))
-> (Maybe ClosurePtr -> Maybe ClosurePtr)
-> Maybe ClosurePtr
-> Maybe (HeapGraphEntry a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe ClosurePtr -> Maybe ClosurePtr
forall a. a -> a
id) [Maybe ClosurePtr]
list
boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex]
boundMultipleTimes :: forall a. HeapGraph a -> [ClosurePtr] -> [ClosurePtr]
boundMultipleTimes (HeapGraph NonEmpty ClosurePtr
_rs IntMap (HeapGraphEntry a)
m) [ClosurePtr]
roots = ([ClosurePtr] -> ClosurePtr) -> [[ClosurePtr]] -> [ClosurePtr]
forall a b. (a -> b) -> [a] -> [b]
map [ClosurePtr] -> ClosurePtr
forall a. HasCallStack => [a] -> a
head ([[ClosurePtr]] -> [ClosurePtr]) -> [[ClosurePtr]] -> [ClosurePtr]
forall a b. (a -> b) -> a -> b
$ ([ClosurePtr] -> Bool) -> [[ClosurePtr]] -> [[ClosurePtr]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> ([ClosurePtr] -> Bool) -> [ClosurePtr] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[ClosurePtr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[ClosurePtr]] -> [[ClosurePtr]])
-> [[ClosurePtr]] -> [[ClosurePtr]]
forall a b. (a -> b) -> a -> b
$ [ClosurePtr] -> [[ClosurePtr]]
forall a. Eq a => [a] -> [[a]]
group ([ClosurePtr] -> [[ClosurePtr]]) -> [ClosurePtr] -> [[ClosurePtr]]
forall a b. (a -> b) -> a -> b
$ [ClosurePtr] -> [ClosurePtr]
forall a. Ord a => [a] -> [a]
sort ([ClosurePtr] -> [ClosurePtr]) -> [ClosurePtr] -> [ClosurePtr]
forall a b. (a -> b) -> a -> b
$
[ClosurePtr]
roots [ClosurePtr] -> [ClosurePtr] -> [ClosurePtr]
forall a. [a] -> [a] -> [a]
++ (HeapGraphEntry a -> [ClosurePtr])
-> [HeapGraphEntry a] -> [ClosurePtr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Maybe ClosurePtr] -> [ClosurePtr]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ClosurePtr] -> [ClosurePtr])
-> (HeapGraphEntry a -> [Maybe ClosurePtr])
-> HeapGraphEntry a
-> [ClosurePtr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> [Maybe ClosurePtr]
forall c a.
DebugClosure
(GenSrtPayload c)
(GenPapPayload c)
a
(GenStackFrames (GenSrtPayload c) c)
c
-> [c]
allClosures (DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> [Maybe ClosurePtr])
-> (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
-> HeapGraphEntry a
-> [Maybe ClosurePtr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure) (IntMap (HeapGraphEntry a) -> [HeapGraphEntry a]
forall a. IntMap a -> [a]
IM.elems IntMap (HeapGraphEntry a)
m)
addBraces :: Bool -> String -> String
addBraces :: Bool -> ShowS
addBraces Bool
True String
t = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
addBraces Bool
False String
t = String
t
braceize :: [String] -> String
braceize :: [String] -> String
braceize [] = String
""
braceize [String]
xs = String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
isChar :: DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar ConstrClosure{ constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc {pkg :: ConstrDesc -> String
pkg = String
"ghc-prim", modl :: ConstrDesc -> String
modl = String
"GHC.Types", name :: ConstrDesc -> String
name = String
"C#"}, dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [Word
ch], ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
ptrArgs = []} = Char -> Maybe Char
forall a. a -> Maybe a
Just (Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
ch))
isChar DebugClosure srt p ConstrDesc s c
_ = Maybe Char
forall a. Maybe a
Nothing
isNil :: DebugClosure srt p ConstrDesc s c -> Bool
isNil :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Bool
isNil ConstrClosure{ constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc {pkg :: ConstrDesc -> String
pkg = String
"ghc-prim", modl :: ConstrDesc -> String
modl = String
"GHC.Types", name :: ConstrDesc -> String
name = String
"[]"}, dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [Word]
_, ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
ptrArgs = []} = Bool
True
isNil DebugClosure srt p ConstrDesc s c
_ = Bool
False
isCons :: DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons ConstrClosure{ constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc {pkg :: ConstrDesc -> String
pkg = String
"ghc-prim", modl :: ConstrDesc -> String
modl = String
"GHC.Types", name :: ConstrDesc -> String
name = String
":"}, dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [], ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
ptrArgs = [c
h,c
t]} = (c, c) -> Maybe (c, c)
forall a. a -> Maybe a
Just (c
h,c
t)
isCons DebugClosure srt p ConstrDesc s c
_ = Maybe (c, c)
forall a. Maybe a
Nothing
isTup :: DebugClosure srt p ConstrDesc s c -> Maybe [c]
isTup :: forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe [c]
isTup ConstrClosure{ dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
dataArgs = [], [c]
ConstrDesc
StgInfoTableWithPtr
constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: StgInfoTableWithPtr
ptrArgs :: [c]
constrDesc :: ConstrDesc
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} =
if String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstrDesc -> String
name ConstrDesc
constrDesc) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&&
String -> Char
forall a. HasCallStack => [a] -> a
head (ConstrDesc -> String
name ConstrDesc
constrDesc) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& String -> Char
forall a. HasCallStack => [a] -> a
last (ConstrDesc -> String
name ConstrDesc
constrDesc) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&&
(Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (ShowS
forall a. HasCallStack => [a] -> [a]
tail (ShowS
forall a. HasCallStack => [a] -> [a]
init (ConstrDesc -> String
name ConstrDesc
constrDesc)))
then [c] -> Maybe [c]
forall a. a -> Maybe a
Just [c]
ptrArgs else Maybe [c]
forall a. Maybe a
Nothing
isTup DebugClosure srt p ConstrDesc s c
_ = Maybe [c]
forall a. Maybe a
Nothing
ppClosure :: (Int -> c -> String) -> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure :: forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure Int -> c -> String
showBox Int
prec DebugClosure (GenSrtPayload c) p ConstrDesc s c
c = case DebugClosure (GenSrtPayload c) p ConstrDesc s c
c of
DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just Char
ch <- DebugClosure (GenSrtPayload c) p ConstrDesc s c -> Maybe Char
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar DebugClosure (GenSrtPayload c) p ConstrDesc s c
c -> [String] -> String
app
[String
"C#", Char -> String
forall a. Show a => a -> String
show Char
ch]
DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just (c
h,c
t) <- DebugClosure (GenSrtPayload c) p ConstrDesc s c -> Maybe (c, c)
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure (GenSrtPayload c) p ConstrDesc s c
c -> Bool -> ShowS
addBraces (Int
5 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
Int -> c -> String
showBox Int
5 c
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> c -> String
showBox Int
4 c
t
DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just [c]
vs <- DebugClosure (GenSrtPayload c) p ConstrDesc s c -> Maybe [c]
forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe [c]
isTup DebugClosure (GenSrtPayload c) p ConstrDesc s c
c ->
String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
0) [c]
vs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
ConstrClosure {[c]
[Word]
ConstrDesc
StgInfoTableWithPtr
constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
ptrArgs :: [c]
dataArgs :: [Word]
constrDesc :: ConstrDesc
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
ConstrDesc -> String
name ConstrDesc
constrDesc String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
ptrArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Word -> String) -> [Word] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word -> String
forall a. Show a => a -> String
show [Word]
dataArgs
ThunkClosure {[c]
[Word]
GenSrtPayload c
StgInfoTableWithPtr
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
srt :: GenSrtPayload c
ptrArgs :: [c]
dataArgs :: [Word]
srt :: forall srt pap string s b. DebugClosure srt pap string s b -> srt
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
let srt_string :: [String]
srt_string = case GenSrtPayload c -> Maybe c
forall b. GenSrtPayload b -> Maybe b
getSrt GenSrtPayload c
srt of
Maybe c
Nothing -> []
Just c
s -> [String
"{", Int -> c -> String
showBox Int
10 c
s, String
"}"]
in [String
"_thunk" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
srt_string] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
ptrArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Word -> String) -> [Word] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word -> String
forall a. Show a => a -> String
show [Word]
dataArgs
SelectorClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
selectee :: c
selectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
[String
"_sel", Int -> c -> String
showBox Int
10 c
selectee]
IndClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
indirectee :: c
indirectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
[String
"_ind", Int -> c -> String
showBox Int
10 c
indirectee]
BlackholeClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
indirectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
info :: StgInfoTableWithPtr
indirectee :: c
..} -> [String] -> String
app
[String
"_bh", Int -> c -> String
showBox Int
10 c
indirectee]
APClosure {c
p
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
arity :: Word32
n_args :: Word32
fun :: c
ap_payload :: p
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
n_args :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
ap_payload :: forall srt pap string s b. DebugClosure srt pap string s b -> pap
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) ([c] -> [String]) -> [c] -> [String]
forall a b. (a -> b) -> a -> b
$
[c
fun]
PAPClosure {c
p
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
n_args :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
info :: StgInfoTableWithPtr
arity :: Word32
n_args :: Word32
fun :: c
pap_payload :: p
pap_payload :: forall srt pap string s b. DebugClosure srt pap string s b -> pap
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) ([c] -> [String]) -> [c] -> [String]
forall a b. (a -> b) -> a -> b
$
[c
fun]
APStackClosure {c
s
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
info :: StgInfoTableWithPtr
ap_st_size :: Word
fun :: c
payload :: s
ap_st_size :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
payload :: forall srt pap string s b. DebugClosure srt pap string s b -> s
..} -> [String] -> String
app ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) ([c] -> [String]) -> [c] -> [String]
forall a b. (a -> b) -> a -> b
$
[c
fun]
TRecChunkClosure {} -> String
"_trecChunk"
BCOClosure {c
[Word]
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
info :: StgInfoTableWithPtr
instrs :: c
literals :: c
bcoptrs :: c
arity :: Word32
size :: Word32
bitmap :: [Word]
instrs :: forall srt pap string s b. DebugClosure srt pap string s b -> b
literals :: forall srt pap string s b. DebugClosure srt pap string s b -> b
bcoptrs :: forall srt pap string s b. DebugClosure srt pap string s b -> b
size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
bitmap :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
..} -> [String] -> String
app
[String
"_bco", Int -> c -> String
showBox Int
10 c
bcoptrs]
ArrWordsClosure {[Word]
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
bytes :: Word
arrWords :: [Word]
bytes :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
arrWords :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
..} -> [String] -> String
app
[String
"ARR_WORDS", String
"("String -> ShowS
forall a. [a] -> [a] -> [a]
++Word -> String
forall a. Show a => a -> String
show Word
bytes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes)", ((ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [Word] -> ByteString
arrWordsBS [Word]
arrWords)) ]
MutArrClosure {[c]
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
mccPtrs :: Word
mccSize :: Word
mccPayload :: [c]
mccPtrs :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccSize :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccPayload :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
..} -> [String] -> String
app
[String
"[", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
shorten ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
mccPayload)),String
"]"]
SmallMutArrClosure {[c]
Word
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
mccPtrs :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccPayload :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: StgInfoTableWithPtr
mccPtrs :: Word
mccPayload :: [c]
..} -> [String] -> String
app
[String
"[", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
shorten ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
mccPayload)),String
"]"]
MutVarClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
var :: c
var :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
[String
"_mutVar", Int -> c -> String
showBox Int
10 c
var]
MVarClosure {c
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
queueHead :: c
queueTail :: c
value :: c
queueHead :: forall srt pap string s b. DebugClosure srt pap string s b -> b
queueTail :: forall srt pap string s b. DebugClosure srt pap string s b -> b
value :: forall srt pap string s b. DebugClosure srt pap string s b -> b
..} -> [String] -> String
app
[String
"MVar", Int -> c -> String
showBox Int
10 c
value]
FunClosure {[c]
[Word]
GenSrtPayload c
StgInfoTableWithPtr
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
srt :: forall srt pap string s b. DebugClosure srt pap string s b -> srt
info :: StgInfoTableWithPtr
srt :: GenSrtPayload c
ptrArgs :: [c]
dataArgs :: [Word]
..} ->
let srt_string :: [String]
srt_string = case GenSrtPayload c -> Maybe c
forall b. GenSrtPayload b -> Maybe b
getSrt GenSrtPayload c
srt of
Maybe c
Nothing -> []
Just c
s -> [String
"{", Int -> c -> String
showBox Int
10 c
s, String
"}"]
in String
"_fun" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([String] -> String
unwords [String]
srt_string) String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
braceize ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
0) [c]
ptrArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Word -> String) -> [Word] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word -> String
forall a. Show a => a -> String
show [Word]
dataArgs)
BlockingQueueClosure {} ->
String
"_blockingQueue"
OtherClosure {} ->
String
"_other"
TSOClosure {c
Int64
[TsoFlags]
Maybe c
Maybe StgTSOProfInfo
Word32
Word64
WhyBlocked
WhatNext
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
_link :: c
global_link :: c
tsoStack :: c
trec :: c
blocked_exceptions :: c
bq :: c
threadLabel :: Maybe c
what_next :: WhatNext
why_blocked :: WhyBlocked
flags :: [TsoFlags]
threadId :: Word64
saved_errno :: Word32
dirty :: Word32
alloc_limit :: Int64
tot_stack_size :: Word32
prof :: Maybe StgTSOProfInfo
_link :: forall srt pap string s b. DebugClosure srt pap string s b -> b
global_link :: forall srt pap string s b. DebugClosure srt pap string s b -> b
tsoStack :: forall srt pap string s b. DebugClosure srt pap string s b -> b
trec :: forall srt pap string s b. DebugClosure srt pap string s b -> b
blocked_exceptions :: forall srt pap string s b. DebugClosure srt pap string s b -> b
bq :: forall srt pap string s b. DebugClosure srt pap string s b -> b
threadLabel :: forall srt pap string s b.
DebugClosure srt pap string s b -> Maybe b
what_next :: forall srt pap string s b.
DebugClosure srt pap string s b -> WhatNext
why_blocked :: forall srt pap string s b.
DebugClosure srt pap string s b -> WhyBlocked
flags :: forall srt pap string s b.
DebugClosure srt pap string s b -> [TsoFlags]
threadId :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word64
saved_errno :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
dirty :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
alloc_limit :: forall srt pap string s b. DebugClosure srt pap string s b -> Int64
tot_stack_size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
prof :: forall srt pap string s b.
DebugClosure srt pap string s b -> Maybe StgTSOProfInfo
..} -> String
"TSO: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ WhyBlocked -> String
forall a. Show a => a -> String
show WhyBlocked
why_blocked
StackClosure {s
Word8
Word32
StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
stack_size :: Word32
stack_dirty :: Word8
stack_marking :: Word8
frames :: s
stack_size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
stack_dirty :: forall srt pap string s b. DebugClosure srt pap string s b -> Word8
stack_marking :: forall srt pap string s b. DebugClosure srt pap string s b -> Word8
frames :: forall srt pap string s b. DebugClosure srt pap string s b -> s
..} -> [String] -> String
app [String
"Stack(", Word32 -> String
forall a. Show a => a -> String
show Word32
stack_size, String
")"]
WeakClosure {} -> String
"_wk"
TVarClosure {} -> String
"_tvar"
MutPrimClosure {} -> String
"_mutPrim"
UnsupportedClosure {StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info :: StgInfoTableWithPtr
info} -> (StgInfoTableWithPtr -> String
forall a. Show a => a -> String
show StgInfoTableWithPtr
info)
where
app :: [String] -> String
app [String
a] = String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"()"
app [String]
xs = Bool -> ShowS
addBraces (Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
prec) ([String] -> String
unwords [String]
xs)
shorten :: [String] -> [String]
shorten [String]
xs = if [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20 then Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
20 [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"(and more)"] else [String]
xs
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)
newtype ReverseGraph = ReverseGraph (IM.IntMap IS.IntSet)
reverseEdges :: ClosurePtr -> ReverseGraph -> Maybe [ClosurePtr]
reverseEdges :: ClosurePtr -> ReverseGraph -> Maybe [ClosurePtr]
reverseEdges ClosurePtr
cp (ReverseGraph IntMap IntSet
rg) =
(Int -> ClosurePtr) -> [Int] -> [ClosurePtr]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ClosurePtr
intToClosurePtr ([Int] -> [ClosurePtr])
-> (IntSet -> [Int]) -> IntSet -> [ClosurePtr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList (IntSet -> [ClosurePtr]) -> Maybe IntSet -> Maybe [ClosurePtr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap IntSet -> Maybe IntSet
forall a. Int -> IntMap a -> Maybe a
IM.lookup (ClosurePtr -> Int
closurePtrToInt ClosurePtr
cp) IntMap IntSet
rg
mkReverseGraph :: HeapGraph a -> ReverseGraph
mkReverseGraph :: forall a. HeapGraph a -> ReverseGraph
mkReverseGraph (HeapGraph NonEmpty ClosurePtr
_ IntMap (HeapGraphEntry a)
hg) = IntMap IntSet -> ReverseGraph
ReverseGraph IntMap IntSet
graph
where
graph :: IntMap IntSet
graph = (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)
hg
collectNodes :: IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
collectNodes IntMap IntSet
newMap Int
k HeapGraphEntry a
h =
let bs :: [Maybe ClosurePtr]
bs = DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> [Maybe ClosurePtr]
forall c a.
DebugClosure
(GenSrtPayload c)
(GenPapPayload c)
a
(GenStackFrames (GenSrtPayload c) c)
c
-> [c]
allClosures (HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
h)
in (IntMap IntSet -> Maybe ClosurePtr -> IntMap IntSet)
-> IntMap IntSet -> [Maybe ClosurePtr] -> IntMap IntSet
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntMap IntSet
m Maybe ClosurePtr
ma ->
case Maybe ClosurePtr
ma of
Maybe ClosurePtr
Nothing -> IntMap IntSet
m
Just ClosurePtr
a -> (IntSet -> IntSet -> IntSet)
-> Int -> IntSet -> IntMap IntSet -> IntMap IntSet
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith IntSet -> IntSet -> IntSet
IS.union (ClosurePtr -> Int
closurePtrToInt ClosurePtr
a) (Int -> IntSet
IS.singleton Int
k) IntMap IntSet
m) IntMap IntSet
newMap [Maybe ClosurePtr]
bs