{-# 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

-- | 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 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)

-- | 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
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

-- | 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 =
  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)

-- 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 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 =
  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 #-}

-- | 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 = 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
    -- First collect all boxes from the existing heap graph
    (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
        -- If the box is in the map, return the index
        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)
            -- 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
  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)
                -- NOTE: We tie-the-knot here with RecursiveDo so that we don't
                -- get into an infinite loop with cycles in the heap.
                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))
                    -- Add the resulting closure below to the map (above):
                    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)

-- | 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 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
    -- All variables occuring more than once
    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
        -- We do not want to print empty lists as "" as we do not know that they
        -- are really strings.
        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


-- | 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 = 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)

-- Utilities

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



-- | 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 (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]
        -- TODO: Payload
    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] -- TODO payload
    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] -- TODO: stack
    TRecChunkClosure {} -> String
"_trecChunk" --TODO
    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
        --["toMutArray", "("++show (length mccPayload) ++ " ptrs)",  intercalate "," (shorten (map (showBox 10) mccPayload))]
        [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 {} -> String
"TSO"
    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
")"] -- TODO
    WeakClosure {} -> String
"_wk" -- TODO
    TVarClosure {} -> String
"_tvar" -- TODO
    MutPrimClosure {} -> String
"_mutPrim" -- TODO
    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


-- Reverse Edges
--
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