{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE NamedFieldPuns #-}
module GHC.Debug.Types.Graph( -- * Types
                              HeapGraph(..)
                            , HeapGraphEntry(..)
                            , HeapGraphIndex
                            , PapHI
                            , StackHI
                            , SrtHI
                            -- * Building a heap graph
                            , DerefFunction
                            , buildHeapGraph
                            , multiBuildHeapGraph
                            , generalBuildHeapGraph

                            -- * Printing a heap graph
                            , ppHeapGraph
                            , ppClosure

                            -- * Utility
                            , lookupHeapGraph
                            , traverseHeapGraph
                            , updateHeapGraph
                            , heapGraphSize
                            , annotateHeapGraph

                            -- * Reverse Graph
                            , 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
import qualified Data.ByteString.Lazy as BS

-- | For heap graphs, i.e. data structures that also represent sharing and
-- cyclic structures, these are the entries. If the referenced value is
-- @Nothing@, then we do not have that value in the map, most likely due to
-- exceeding the recursion bound passed to 'buildHeapGraph'.
--
-- Besides a pointer to the stored value and the closure representation we
-- have a slot for arbitrary data, for the user's convenience.
data HeapGraphEntry a = HeapGraphEntry {
        forall a. HeapGraphEntry a -> ClosurePtr
hgeClosurePtr :: ClosurePtr,
        forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure :: DebugClosure CCSPtr 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)

-- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
-- as the internal representation may change. Nevertheless, we export it here:
-- Sometimes the user knows better what he needs than we do.
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

-- | Creates a 'HeapGraph' for the value in the box, but not recursing further
-- than the given limit.
buildHeapGraph
   :: (MonadFix m)
   => DerefFunction m a
   -> Maybe Int
   -> ClosurePtr -- ^ The value to start with
   -> 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)

-- TODO: It is a bit undesirable that the ConstrDesc field is already
-- dereferenced, but also, not such a big deal. It could lead to additional
-- requests to the debuggee which are not necessary and causes a mismatch
-- with the step-by-step decoding functions in `Client.hs`
type DerefFunction m a = ClosurePtr -> m (DebugClosureWithExtra a CCSPtr SrtPayload PapPayload ConstrDesc (GenStackFrames SrtPayload ClosurePtr) ClosurePtr)

-- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
--   further than the given limit.
multiBuildHeapGraph
    :: (MonadFix m)
    => DerefFunction m a
    -> Maybe Int
    -> NonEmpty ClosurePtr -- ^ Starting values with associated data entry
    -> 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 #-}

-- | Adds the given annotation to the entry at the given index, using the
-- 'mappend' operation of its 'Monoid' instance.
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 :: a
hgeData = a -> a
f (HeapGraphEntry a -> a
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
    -- First collect all boxes from the existing heap graph
    (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
        -- If the box is in the map, return the index
        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)
            -- FIXME GHC BUG: change `mdo` to `do` below:
            --       "GHC internal error: ‘c’ is not in scope during type checking, but it passed the renamer"
            Maybe (HeapGraphEntry a)
Nothing -> mdo
                -- Look up the closure
                DebugClosureWithExtra
  a
  CCSPtr
  SrtPayload
  PapPayload
  ConstrDesc
  (GenStackFrames SrtPayload ClosurePtr)
  ClosurePtr
c <- m (DebugClosureWithExtra
     a
     CCSPtr
     SrtPayload
     PapPayload
     ConstrDesc
     (GenStackFrames SrtPayload ClosurePtr)
     ClosurePtr)
-> StateT
     (HeapGraph a)
     m
     (DebugClosureWithExtra
        a
        CCSPtr
        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
      CCSPtr
      SrtPayload
      PapPayload
      ConstrDesc
      (GenStackFrames SrtPayload ClosurePtr)
      ClosurePtr)
 -> StateT
      (HeapGraph a)
      m
      (DebugClosureWithExtra
         a
         CCSPtr
         SrtPayload
         PapPayload
         ConstrDesc
         (GenStackFrames SrtPayload ClosurePtr)
         ClosurePtr))
-> m (DebugClosureWithExtra
        a
        CCSPtr
        SrtPayload
        PapPayload
        ConstrDesc
        (GenStackFrames SrtPayload ClosurePtr)
        ClosurePtr)
-> StateT
     (HeapGraph a)
     m
     (DebugClosureWithExtra
        a
        CCSPtr
        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)
                -- NOTE: We tie-the-knot here with RecursiveDo so that we don't
                -- get into an infinite loop with cycles in the heap.
                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
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> a
-> HeapGraphEntry a
forall a.
ClosurePtr
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> a
-> HeapGraphEntry a
HeapGraphEntry ClosurePtr
cp DebugClosure
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' a
e))
                    -- Add the resulting closure below to the map (above):
                    DCS a
e DebugClosure
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' <- (CCSPtr -> StateT (HeapGraph a) m CCSPtr)
-> (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
     CCSPtr
     SrtPayload
     PapPayload
     ConstrDesc
     (GenStackFrames SrtPayload ClosurePtr)
     ClosurePtr
-> StateT
     (HeapGraph a)
     m
     (DebugClosureWithExtra
        a CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosureWithExtra a a c e h j l
-> f (DebugClosureWithExtra a b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
       e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> StateT (HeapGraph a) m CCSPtr
forall a. a -> StateT (HeapGraph a) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((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
  CCSPtr
  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)

-- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
-- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
--
-- >let x1 = "Ki"
-- >    x6 = C# 'H' : C# 'o' : x6
-- >in (x1,x1,x6)
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
    -- All variables occuring more than once
    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
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr 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
  CCSPtr 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
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe String
forall ccs srt p s.
DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe String
isString (HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr 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
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall ccs srt p s.
DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr 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
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> String
forall c ccs p s.
(Int -> c -> String)
-> Int
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
-> String
ppClosure Int -> Maybe ClosurePtr -> String
ppRef Int
prec (HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr 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 ccs srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex]
    isList :: forall ccs srt p s.
DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
c
        | DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr) -> Bool
forall ccs srt p s c. DebugClosure ccs srt p ConstrDesc s c -> Bool
isNil DebugClosure ccs 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 ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe (Maybe ClosurePtr, Maybe ClosurePtr)
forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure ccs 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
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall ccs srt p s.
DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
e)
            return $ (:) Maybe ClosurePtr
h [Maybe ClosurePtr]
t'

    isString :: DebugClosure ccs srt p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe String
    isString :: forall ccs srt p s.
DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe String
isString DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
e = do
        [Maybe ClosurePtr]
list <- DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
forall ccs srt p s.
DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure ccs srt p ConstrDesc s (Maybe ClosurePtr)
e
        -- We do not want to print empty lists as "" as we do not know that they
        -- are really strings.
        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
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> Maybe Char
forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe Char
isChar (DebugClosure
   CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
 -> Maybe Char)
-> (HeapGraphEntry a
    -> DebugClosure
         CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
-> HeapGraphEntry a
-> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr 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


-- | In the given HeapMap, list all indices that are used more than once. The
-- second parameter adds external references, commonly @[heapGraphRoot]@.
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
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> [Maybe ClosurePtr]
forall ccs c a.
DebugClosure
  ccs
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (DebugClosure
   CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
 -> [Maybe ClosurePtr])
-> (HeapGraphEntry a
    -> DebugClosure
         CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr))
-> HeapGraphEntry a
-> [Maybe ClosurePtr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure) (IntMap (HeapGraphEntry a) -> [HeapGraphEntry a]
forall a. IntMap a -> [a]
IM.elems IntMap (HeapGraphEntry a)
m)

-- Utilities

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 ccs srt p ConstrDesc s c -> Maybe Char
isChar :: forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe Char
isChar ConstrClosure{ constrDesc :: forall ccs srt pap string s b.
DebugClosure ccs 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 ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
dataArgs = [Word
ch], ptrArgs :: forall ccs srt pap string s b.
DebugClosure ccs 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 ccs srt p ConstrDesc s c
_ = Maybe Char
forall a. Maybe a
Nothing

isNil :: DebugClosure ccs srt p ConstrDesc s c -> Bool
isNil :: forall ccs srt p s c. DebugClosure ccs srt p ConstrDesc s c -> Bool
isNil ConstrClosure{ constrDesc :: forall ccs srt pap string s b.
DebugClosure ccs 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 ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
dataArgs = [Word]
_, ptrArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [b]
ptrArgs = []} = Bool
True
isNil DebugClosure ccs srt p ConstrDesc s c
_ = Bool
False

isCons :: DebugClosure ccs srt p ConstrDesc s c -> Maybe (c, c)
isCons :: forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe (c, c)
isCons ConstrClosure{ constrDesc :: forall ccs srt pap string s b.
DebugClosure ccs 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 ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
dataArgs = [], ptrArgs :: forall ccs srt pap string s b.
DebugClosure ccs 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 ccs srt p ConstrDesc s c
_ = Maybe (c, c)
forall a. Maybe a
Nothing

isTup :: DebugClosure ccs srt p ConstrDesc s c -> Maybe [c]
isTup :: forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe [c]
isTup ConstrClosure{ dataArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
dataArgs = [], [c]
Maybe (ProfHeader ccs)
ConstrDesc
StgInfoTableWithPtr
constrDesc :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> string
ptrArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [b]
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
ptrArgs :: [c]
constrDesc :: ConstrDesc
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
..} =
    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 ccs srt p ConstrDesc s c
_ = Maybe [c]
forall a. Maybe a
Nothing



-- | A pretty-printer that tries to generate valid Haskell for evalutated data.
-- It assumes that for the included boxes, you already replaced them by Strings
-- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
--
-- The parameter gives the precedendence, to avoid avoidable parenthesises.
ppClosure :: (Int -> c -> String) -> Int -> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure :: forall c ccs p s.
(Int -> c -> String)
-> Int
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
-> String
ppClosure Int -> c -> String
showBox Int
prec DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
c = case DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
c of
    DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
_ | Just Char
ch <- DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c -> Maybe Char
forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe Char
isChar DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
c -> [String] -> String
app
        [String
"C#", Char -> String
forall a. Show a => a -> String
show Char
ch]
    DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
_ | Just (c
h,c
t) <- DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c -> Maybe (c, c)
forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure ccs (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 ccs (GenSrtPayload c) p ConstrDesc s c
_ | Just [c]
vs <- DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c -> Maybe [c]
forall ccs srt p s c.
DebugClosure ccs srt p ConstrDesc s c -> Maybe [c]
isTup DebugClosure ccs (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]
Maybe (ProfHeader ccs)
ConstrDesc
StgInfoTableWithPtr
constrDesc :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> string
dataArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
ptrArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [b]
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
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]
Maybe (ProfHeader ccs)
GenSrtPayload c
StgInfoTableWithPtr
dataArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
ptrArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [b]
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
srt :: GenSrtPayload c
ptrArgs :: [c]
dataArgs :: [Word]
srt :: forall ccs srt pap string s b.
DebugClosure ccs 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
Maybe (ProfHeader ccs)
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
selectee :: c
selectee :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
..} -> [String] -> String
app
        [String
"_sel", Int -> c -> String
showBox Int
10 c
selectee]
    IndClosure {c
Maybe (ProfHeader ccs)
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
indirectee :: c
indirectee :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
..} -> [String] -> String
app
        [String
"_ind", Int -> c -> String
showBox Int
10 c
indirectee]
    BlackholeClosure {c
Maybe (ProfHeader ccs)
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
indirectee :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
indirectee :: c
..} -> [String] -> String
app
        [String
"_bh",  Int -> c -> String
showBox Int
10 c
indirectee]
    APClosure {c
p
Maybe (ProfHeader ccs)
Word32
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
arity :: Word32
n_args :: Word32
fun :: c
ap_payload :: p
arity :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
n_args :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
fun :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
ap_payload :: forall ccs srt pap string s b.
DebugClosure ccs 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]
        -- TODO: Payload
    PAPClosure {c
p
Maybe (ProfHeader ccs)
Word32
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
arity :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
n_args :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
fun :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
arity :: Word32
n_args :: Word32
fun :: c
pap_payload :: p
pap_payload :: forall ccs srt pap string s b.
DebugClosure ccs 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] -- TODO payload
    APStackClosure {c
s
Maybe (ProfHeader ccs)
Word
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
fun :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
ap_st_size :: Word
fun :: c
payload :: s
ap_st_size :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word
payload :: forall ccs srt pap string s b.
DebugClosure ccs 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] -- TODO: stack
    TRecChunkClosure {} -> String
"_trecChunk" --TODO
    BCOClosure {c
[Word]
Maybe (ProfHeader ccs)
Word32
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
arity :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
instrs :: c
literals :: c
bcoptrs :: c
arity :: Word32
size :: Word32
bitmap :: [Word]
instrs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
literals :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
bcoptrs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
size :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
bitmap :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
..} -> [String] -> String
app
        [String
"_bco", Int -> c -> String
showBox Int
10 c
bcoptrs]
    ArrWordsClosure {[Word]
Maybe (ProfHeader ccs)
Word
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
bytes :: Word
arrWords :: [Word]
bytes :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word
arrWords :: forall ccs srt pap string s b.
DebugClosure ccs 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] -> ByteString) -> [Word] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Word] -> [Word]
forall a. Int -> [a] -> [a]
take (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
100 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
bytes) [Word]
arrWords)) ]
    MutArrClosure {[c]
Maybe (ProfHeader ccs)
Word
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
mccPtrs :: Word
mccSize :: Word
mccPayload :: [c]
mccPtrs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word
mccSize :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word
mccPayload :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [b]
..} -> [String] -> String
app
        --["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
        [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]
Maybe (ProfHeader ccs)
Word
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
mccPtrs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word
mccPayload :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [b]
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
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
Maybe (ProfHeader ccs)
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
var :: c
var :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
..} -> [String] -> String
app
        [String
"_mutVar", Int -> c -> String
showBox Int
10 c
var]
    MVarClosure {c
Maybe (ProfHeader ccs)
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
queueHead :: c
queueTail :: c
value :: c
queueHead :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
queueTail :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
value :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
..} -> [String] -> String
app
        [String
"MVar", Int -> c -> String
showBox Int
10 c
value]
    FunClosure {[c]
[Word]
Maybe (ProfHeader ccs)
GenSrtPayload c
StgInfoTableWithPtr
dataArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [Word]
ptrArgs :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [b]
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
srt :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> srt
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
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 (ProfHeader ccs)
Maybe StgTSOProfInfo
Word32
Word64
StgInfoTableWithPtr
WhyBlocked
WhatNext
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
_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 ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
global_link :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
tsoStack :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
trec :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
blocked_exceptions :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
bq :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> b
threadLabel :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe b
what_next :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> WhatNext
why_blocked :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> WhyBlocked
flags :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> [TsoFlags]
threadId :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word64
saved_errno :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
dirty :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
alloc_limit :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Int64
tot_stack_size :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
prof :: forall ccs srt pap string s b.
DebugClosure ccs 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
Maybe (ProfHeader ccs)
Word8
Word32
StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
profHeader :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
info :: StgInfoTableWithPtr
profHeader :: Maybe (ProfHeader ccs)
stack_size :: Word32
stack_dirty :: Word8
stack_marking :: Word8
frames :: s
stack_size :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word32
stack_dirty :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word8
stack_marking :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Word8
frames :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> s
..} -> [String] -> String
app [String
"Stack(", Word32 -> String
forall a. Show a => a -> String
show Word32
stack_size, String
")"] -- TODO
    WeakClosure {} -> String
"_wk" -- TODO
    TVarClosure {} -> String
"_tvar" -- TODO
    MutPrimClosure {} -> String
"_mutPrim" -- TODO
    PrimClosure {} -> String
"_prim" -- TODO
    UnsupportedClosure {StgInfoTableWithPtr
info :: forall ccs srt pap string s b.
DebugClosure ccs 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


-- Reverse Edges
--
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
  CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> [Maybe ClosurePtr]
forall ccs c a.
DebugClosure
  ccs
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (HeapGraphEntry a
-> DebugClosure
     CCSPtr SrtHI PapHI ConstrDesc StackHI (Maybe ClosurePtr)
forall a.
HeapGraphEntry a
-> DebugClosure
     CCSPtr 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