{-# 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
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
showList :: [HeapGraphEntry a] -> ShowS
$cshowList :: forall a. Show a => [HeapGraphEntry a] -> ShowS
show :: HeapGraphEntry a -> String
$cshow :: forall a. Show a => HeapGraphEntry a -> String
showsPrec :: Int -> HeapGraphEntry a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> HeapGraphEntry a -> ShowS
Show, 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
<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
$c<$ :: forall a b. a -> HeapGraphEntry b -> HeapGraphEntry a
fmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
$cfmap :: forall a b. (a -> b) -> HeapGraphEntry a -> HeapGraphEntry b
Functor, 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
product :: forall a. Num a => HeapGraphEntry a -> a
$cproduct :: forall a. Num a => HeapGraphEntry a -> a
sum :: forall a. Num a => HeapGraphEntry a -> a
$csum :: forall a. Num a => HeapGraphEntry a -> a
minimum :: forall a. Ord a => HeapGraphEntry a -> a
$cminimum :: forall a. Ord a => HeapGraphEntry a -> a
maximum :: forall a. Ord a => HeapGraphEntry a -> a
$cmaximum :: forall a. Ord a => HeapGraphEntry a -> a
elem :: forall a. Eq a => a -> HeapGraphEntry a -> Bool
$celem :: forall a. Eq a => a -> HeapGraphEntry a -> Bool
length :: forall a. HeapGraphEntry a -> Int
$clength :: forall a. HeapGraphEntry a -> Int
null :: forall a. HeapGraphEntry a -> Bool
$cnull :: forall a. HeapGraphEntry a -> Bool
toList :: forall a. HeapGraphEntry a -> [a]
$ctoList :: forall a. HeapGraphEntry a -> [a]
foldl1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
foldr1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> HeapGraphEntry a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> HeapGraphEntry a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HeapGraphEntry a -> m
fold :: forall m. Monoid m => HeapGraphEntry m -> m
$cfold :: forall m. Monoid m => HeapGraphEntry m -> m
Foldable, Functor HeapGraphEntry
Foldable 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)
sequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraphEntry (m a) -> m (HeapGraphEntry a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraphEntry a -> m (HeapGraphEntry b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraphEntry (f a) -> f (HeapGraphEntry a)
traverse :: 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)
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
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
showList :: [HeapGraph a] -> ShowS
$cshowList :: forall a. Show a => [HeapGraph a] -> ShowS
show :: HeapGraph a -> String
$cshow :: forall a. Show a => HeapGraph a -> String
showsPrec :: Int -> HeapGraph a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> HeapGraph a -> ShowS
Show, 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
product :: forall a. Num a => HeapGraph a -> a
$cproduct :: forall a. Num a => HeapGraph a -> a
sum :: forall a. Num a => HeapGraph a -> a
$csum :: forall a. Num a => HeapGraph a -> a
minimum :: forall a. Ord a => HeapGraph a -> a
$cminimum :: forall a. Ord a => HeapGraph a -> a
maximum :: forall a. Ord a => HeapGraph a -> a
$cmaximum :: forall a. Ord a => HeapGraph a -> a
elem :: forall a. Eq a => a -> HeapGraph a -> Bool
$celem :: forall a. Eq a => a -> HeapGraph a -> Bool
length :: forall a. HeapGraph a -> Int
$clength :: forall a. HeapGraph a -> Int
null :: forall a. HeapGraph a -> Bool
$cnull :: forall a. HeapGraph a -> Bool
toList :: forall a. HeapGraph a -> [a]
$ctoList :: forall a. HeapGraph a -> [a]
foldl1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
foldr1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> HeapGraph a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> HeapGraph a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> HeapGraph a -> m
fold :: forall m. Monoid m => HeapGraph m -> m
$cfold :: forall m. Monoid m => HeapGraph m -> m
Foldable, Functor HeapGraph
Foldable 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)
sequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
HeapGraph (m a) -> m (HeapGraph a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> HeapGraph a -> m (HeapGraph b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
HeapGraph (f a) -> f (HeapGraph a)
traverse :: 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)
Traversable, 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
<$ :: forall a b. a -> HeapGraph b -> HeapGraph a
$c<$ :: forall a b. a -> HeapGraph b -> HeapGraph a
fmap :: forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
$cfmap :: forall a b. (a -> b) -> HeapGraph a -> HeapGraph b
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) = forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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) = forall a. Int -> IntMap a -> Maybe a
IM.lookup (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) = forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (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) = forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
r (forall a. (a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.update HeapGraphEntry a -> Maybe (HeapGraphEntry a)
f (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) = 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 =
forall (m :: * -> *) a.
MonadFix m =>
DerefFunction m a
-> Maybe Int -> NonEmpty ClosurePtr -> m (HeapGraph a)
multiBuildHeapGraph DerefFunction m a
deref Maybe Int
limit (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 =
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 (forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph NonEmpty ClosurePtr
rs 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 = 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HeapGraphEntry a
hge { hgeData :: a
hgeData = a -> a
f (forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry a
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') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Int
-> ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
add Maybe Int
limit) NonEmpty ClosurePtr
addBoxes) HeapGraph a
hg
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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
add Maybe Int
n ClosurePtr
cp = do
HeapGraph a
hm <- forall (m :: * -> *) s. Monad m => StateT s m s
get
case forall a. ClosurePtr -> HeapGraph a -> Maybe (HeapGraphEntry a)
lookupHeapGraph ClosurePtr
cp HeapGraph a
hm of
Just {} -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ClosurePtr
cp)
Maybe (HeapGraphEntry a)
Nothing -> mdo
DebugClosureWithExtra
a
SrtPayload
PapPayload
ConstrDesc
(GenStackFrames SrtPayload ClosurePtr)
ClosurePtr
c <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 (forall a. Num a => a -> a -> a
subtract Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
n)
rec forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (forall a.
ClosurePtr -> HeapGraphEntry a -> HeapGraph a -> HeapGraph a
insertHeapGraph ClosurePtr
cp (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' <- 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 (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ClosurePtr -> StateT (HeapGraph a) m (Maybe ClosurePtr)
new_add) forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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
forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ a -> String
printData (forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
heapGraphRoot)) forall a. [a] -> [a] -> [a]
++ String
") " forall a. [a] -> [a] -> [a]
++ String
roots
where
bindings :: [ClosurePtr]
bindings = forall a. HeapGraph a -> [ClosurePtr] -> [ClosurePtr]
boundMultipleTimes (forall a.
NonEmpty ClosurePtr -> IntMap (HeapGraphEntry a) -> HeapGraph a
HeapGraph (ClosurePtr
heapGraphRoot forall a. a -> [a] -> NonEmpty a
:| [ClosurePtr]
rs) IntMap (HeapGraphEntry a)
m) [ClosurePtr
heapGraphRoot]
roots :: String
roots = [String] -> String
unlines [
String
"r" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
":(" forall a. [a] -> [a] -> [a]
++ a -> String
printData (forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
r)) forall a. [a] -> [a] -> [a]
++ String
") " forall a. [a] -> [a] -> [a]
++ Int -> Maybe ClosurePtr -> String
ppRef Int
0 (forall a. a -> Maybe a
Just ClosurePtr
r) forall a. [a] -> [a] -> [a]
++ String
"\n"
| (Int
n, ClosurePtr
r) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (ClosurePtr
heapGraphRoot forall a. a -> [a] -> [a]
: [ClosurePtr]
rs) ]
letWrapper :: String
letWrapper =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClosurePtr]
bindings
then String
""
else String
"let " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n " (forall a b. (a -> b) -> [a] -> [b]
map ClosurePtr -> String
ppBinding [ClosurePtr]
bindings) forall a. [a] -> [a] -> [a]
++ String
"\nin "
bindingLetter :: ClosurePtr -> Char
bindingLetter ClosurePtr
i = case 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 = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
j (ClosurePtr
i,Char
c) -> (ClosurePtr
i, Char
c forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
j)) [(Int
1::Int)..]) forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` 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 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 forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ a -> String
printData (forall a. HeapGraphEntry a -> a
hgeData (ClosurePtr -> HeapGraphEntry a
iToE ClosurePtr
i)) forall a. [a] -> [a] -> [a]
++ String
") = " 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 <- forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr) -> Maybe String
isString (forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge) = forall a. Show a => a -> String
show String
s
| Just [Maybe ClosurePtr]
l <- forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge) = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe ClosurePtr -> String
ppRef Int
0) [Maybe ClosurePtr]
l) forall a. [a] -> [a] -> [a]
++ String
"]"
| Bool
otherwise = forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure Int -> Maybe ClosurePtr -> String
ppRef Int
prec (forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge)
where
_app :: [String] -> String
_app [String
a] = String
a forall a. [a] -> [a] -> [a]
++ String
"()"
_app [String]
xs = Bool -> ShowS
addBraces (Int
10 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 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 forall a. IntMap a -> Int -> a
IM.! (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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ClosurePtr]
bindings = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. Int -> IntMap a -> Maybe a
IM.lookup (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
| forall srt p s c. DebugClosure srt p ConstrDesc s c -> Bool
isNil DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
c =
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = do
(Maybe ClosurePtr
h,Maybe ClosurePtr
t) <- 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' <- forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (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 <- forall srt p s.
DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure srt p ConstrDesc s (Maybe ClosurePtr)
e
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe ClosurePtr]
list
then forall a. Maybe a
Nothing
else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe Char
isChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ClosurePtr -> Maybe (HeapGraphEntry a)
iToUnboundE forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [[a]]
group forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$
[ClosurePtr]
roots forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a.
DebugClosure
(GenSrtPayload c)
(GenPapPayload c)
a
(GenStackFrames (GenSrtPayload c) c)
c
-> [c]
allClosures forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HeapGraphEntry a
-> DebugClosure SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure) (forall a. IntMap a -> [a]
IM.elems IntMap (HeapGraphEntry a)
m)
addBraces :: Bool -> String -> String
addBraces :: Bool -> ShowS
addBraces Bool
True String
t = String
"(" forall a. [a] -> [a] -> [a]
++ String
t 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
"{" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs 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 = []} = forall a. a -> Maybe a
Just (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
ch))
isChar DebugClosure srt p ConstrDesc s c
_ = 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]} = forall a. a -> Maybe a
Just (c
h,c
t)
isCons DebugClosure srt p ConstrDesc s 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
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
constrDesc :: ConstrDesc
ptrArgs :: [c]
info :: StgInfoTableWithPtr
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
..} =
if forall (t :: * -> *) a. Foldable t => t a -> Int
length (ConstrDesc -> String
name ConstrDesc
constrDesc) forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&&
forall a. [a] -> a
head (ConstrDesc -> String
name ConstrDesc
constrDesc) forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& forall a. [a] -> a
last (ConstrDesc -> String
name ConstrDesc
constrDesc) forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Char
',') (forall a. [a] -> [a]
tail (forall a. [a] -> [a]
init (ConstrDesc -> String
name ConstrDesc
constrDesc)))
then forall a. a -> Maybe a
Just [c]
ptrArgs else forall a. Maybe a
Nothing
isTup DebugClosure srt p ConstrDesc s 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 <- 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#", forall a. Show a => a -> String
show Char
ch]
DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just (c
h,c
t) <- 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 forall a. Ord a => a -> a -> Bool
<= Int
prec) forall a b. (a -> b) -> a -> b
$
Int -> c -> String
showBox Int
5 c
h forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ Int -> c -> String
showBox Int
4 c
t
DebugClosure (GenSrtPayload c) p ConstrDesc s c
_ | Just [c]
vs <- forall srt p s c. DebugClosure srt p ConstrDesc s c -> Maybe [c]
isTup DebugClosure (GenSrtPayload c) p ConstrDesc s c
c ->
String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
0) [c]
vs) forall a. [a] -> [a] -> [a]
++ String
")"
ConstrClosure {[c]
[Word]
ConstrDesc
StgInfoTableWithPtr
constrDesc :: ConstrDesc
dataArgs :: [Word]
ptrArgs :: [c]
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
..} -> [String] -> String
app forall a b. (a -> b) -> a -> b
$
ConstrDesc -> String
name ConstrDesc
constrDesc forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
ptrArgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Word]
dataArgs
ThunkClosure {[c]
[Word]
GenSrtPayload c
StgInfoTableWithPtr
srt :: forall srt pap string s b. DebugClosure srt pap string s b -> srt
dataArgs :: [Word]
ptrArgs :: [c]
srt :: GenSrtPayload c
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
..} -> [String] -> String
app forall a b. (a -> b) -> a -> b
$
let srt_string :: [String]
srt_string = case 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" forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
srt_string] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
ptrArgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Word]
dataArgs
SelectorClosure {c
StgInfoTableWithPtr
selectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
selectee :: c
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"_sel", Int -> c -> String
showBox Int
10 c
selectee]
IndClosure {c
StgInfoTableWithPtr
indirectee :: forall srt pap string s b. DebugClosure srt pap string s b -> b
indirectee :: c
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"_ind", Int -> c -> String
showBox Int
10 c
indirectee]
BlackholeClosure {c
StgInfoTableWithPtr
indirectee :: c
info :: StgInfoTableWithPtr
indirectee :: 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
..} -> [String] -> String
app
[String
"_bh", Int -> c -> String
showBox Int
10 c
indirectee]
APClosure {c
p
Word32
StgInfoTableWithPtr
ap_payload :: forall srt pap string s b. DebugClosure srt pap string s b -> pap
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
n_args :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
ap_payload :: p
fun :: c
n_args :: Word32
arity :: Word32
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) forall a b. (a -> b) -> a -> b
$
[c
fun]
PAPClosure {c
p
Word32
StgInfoTableWithPtr
pap_payload :: forall srt pap string s b. DebugClosure srt pap string s b -> pap
pap_payload :: p
fun :: c
n_args :: Word32
arity :: Word32
info :: StgInfoTableWithPtr
fun :: forall srt pap string s b. DebugClosure srt pap string s b -> b
n_args :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) forall a b. (a -> b) -> a -> b
$
[c
fun]
APStackClosure {c
s
Word
StgInfoTableWithPtr
payload :: forall srt pap string s b. DebugClosure srt pap string s b -> s
ap_st_size :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
payload :: s
fun :: c
ap_st_size :: Word
info :: StgInfoTableWithPtr
fun :: 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
..} -> [String] -> String
app forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) forall a b. (a -> b) -> a -> b
$
[c
fun]
TRecChunkClosure {} -> String
"_trecChunk"
BCOClosure {c
[Word]
Word32
StgInfoTableWithPtr
bitmap :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
bcoptrs :: 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
instrs :: forall srt pap string s b. DebugClosure srt pap string s b -> b
bitmap :: [Word]
size :: Word32
arity :: Word32
bcoptrs :: c
literals :: c
instrs :: c
info :: StgInfoTableWithPtr
arity :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"_bco", Int -> c -> String
showBox Int
10 c
bcoptrs]
ArrWordsClosure {[Word]
Word
StgInfoTableWithPtr
arrWords :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
bytes :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
arrWords :: [Word]
bytes :: Word
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"ARR_WORDS", String
"("forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Word
bytes forall a. [a] -> [a] -> [a]
++ String
" bytes)", ((forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ [Word] -> ByteString
arrWordsBS [Word]
arrWords)) ]
MutArrClosure {[c]
Word
StgInfoTableWithPtr
mccPayload :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
mccSize :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccPtrs :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
mccPayload :: [c]
mccSize :: Word
mccPtrs :: Word
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"[", forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
shorten (forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
mccPayload)),String
"]"]
SmallMutArrClosure {[c]
Word
StgInfoTableWithPtr
mccPayload :: [c]
mccPtrs :: Word
info :: StgInfoTableWithPtr
mccPayload :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
mccPtrs :: forall srt pap string s b. DebugClosure srt pap string s b -> Word
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"[", forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> [String]
shorten (forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
10) [c]
mccPayload)),String
"]"]
MutVarClosure {c
StgInfoTableWithPtr
var :: forall srt pap string s b. DebugClosure srt pap string s b -> b
var :: c
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"_mutVar", Int -> c -> String
showBox Int
10 c
var]
MVarClosure {c
StgInfoTableWithPtr
value :: 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
queueHead :: forall srt pap string s b. DebugClosure srt pap string s b -> b
value :: c
queueTail :: c
queueHead :: c
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
[String
"MVar", Int -> c -> String
showBox Int
10 c
value]
FunClosure {[c]
[Word]
GenSrtPayload c
StgInfoTableWithPtr
dataArgs :: [Word]
ptrArgs :: [c]
srt :: GenSrtPayload c
info :: StgInfoTableWithPtr
srt :: forall srt pap string s b. DebugClosure srt pap string s b -> srt
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
ptrArgs :: forall srt pap string s b. DebugClosure srt pap string s b -> [b]
dataArgs :: forall srt pap string s b.
DebugClosure srt pap string s b -> [Word]
..} ->
let srt_string :: [String]
srt_string = case 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" forall a. [a] -> [a] -> [a]
++ ([String] -> String
unwords [String]
srt_string) forall a. [a] -> [a] -> [a]
++ [String] -> String
braceize (forall a b. (a -> b) -> [a] -> [b]
map (Int -> c -> String
showBox Int
0) [c]
ptrArgs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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
prof :: forall srt pap string s b.
DebugClosure srt pap string s b -> Maybe StgTSOProfInfo
tot_stack_size :: 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
dirty :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
saved_errno :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
threadId :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word64
flags :: forall srt pap string s b.
DebugClosure srt pap string s b -> [TsoFlags]
why_blocked :: forall srt pap string s b.
DebugClosure srt pap string s b -> WhyBlocked
what_next :: forall srt pap string s b.
DebugClosure srt pap string s b -> WhatNext
threadLabel :: forall srt pap string s b.
DebugClosure srt pap string s b -> Maybe b
bq :: 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
trec :: 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
global_link :: forall srt pap string s b. DebugClosure srt pap string s b -> b
_link :: forall srt pap string s b. DebugClosure srt pap string s b -> b
prof :: Maybe StgTSOProfInfo
tot_stack_size :: Word32
alloc_limit :: Int64
dirty :: Word32
saved_errno :: Word32
threadId :: Word64
flags :: [TsoFlags]
why_blocked :: WhyBlocked
what_next :: WhatNext
threadLabel :: Maybe c
bq :: c
blocked_exceptions :: c
trec :: c
tsoStack :: c
global_link :: c
_link :: c
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> String
"TSO: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show WhyBlocked
why_blocked
StackClosure {s
Word8
Word32
StgInfoTableWithPtr
frames :: forall srt pap string s b. DebugClosure srt pap string s b -> s
stack_marking :: forall srt pap string s b. DebugClosure srt pap string s b -> Word8
stack_dirty :: forall srt pap string s b. DebugClosure srt pap string s b -> Word8
stack_size :: forall srt pap string s b.
DebugClosure srt pap string s b -> Word32
frames :: s
stack_marking :: Word8
stack_dirty :: Word8
stack_size :: Word32
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app [String
"Stack(", forall a. Show a => a -> String
show Word32
stack_size, String
")"]
WeakClosure {} -> String
"_wk"
TVarClosure {} -> String
"_tvar"
MutPrimClosure {} -> String
"_mutPrim"
UnsupportedClosure {StgInfoTableWithPtr
info :: StgInfoTableWithPtr
info :: forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info} -> (forall a. Show a => a -> String
show StgInfoTableWithPtr
info)
where
app :: [String] -> String
app [String
a] = String
a forall a. [a] -> [a] -> [a]
++ String
"()"
app [String]
xs = Bool -> ShowS
addBraces (Int
10 forall a. Ord a => a -> a -> Bool
<= Int
prec) ([String] -> String
unwords [String]
xs)
shorten :: [String] -> [String]
shorten [String]
xs = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs forall a. Ord a => a -> a -> Bool
> Int
20 then forall a. Int -> [a] -> [a]
take Int
20 [String]
xs forall a. [a] -> [a] -> [a]
++ [String
"(and more)"] else [String]
xs
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)
newtype ReverseGraph = ReverseGraph (IM.IntMap IS.IntSet)
reverseEdges :: ClosurePtr -> ReverseGraph -> Maybe [ClosurePtr]
reverseEdges :: ClosurePtr -> ReverseGraph -> Maybe [ClosurePtr]
reverseEdges ClosurePtr
cp (ReverseGraph IntMap IntSet
rg) =
forall a b. (a -> b) -> [a] -> [b]
map Int -> ClosurePtr
intToClosurePtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IS.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = 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)
hg
collectNodes :: IntMap IntSet -> Int -> HeapGraphEntry a -> IntMap IntSet
collectNodes IntMap IntSet
newMap Int
k HeapGraphEntry a
h =
let bs :: [Maybe ClosurePtr]
bs = 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)
in 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 -> 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