{-# 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
                            -- * 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(..))

-- | 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 PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure :: DebugClosure 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 (Maybe HeapGraphIndex)
type PapHI =  GenPapPayload (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 PapPayload ConstrDesc StackFrames 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 PapPayload ConstrDesc StackFrames 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 PapHI ConstrDesc StackHI (Maybe ClosurePtr)
-> a
-> HeapGraphEntry a
HeapGraphEntry ClosurePtr
cp DebugClosure PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' a
e))
                    -- Add the resulting closure below to the map (above):
                    DCS a
e DebugClosure PapHI ConstrDesc StackHI (Maybe ClosurePtr)
c' <- forall (m :: * -> * -> * -> * -> *) (f :: * -> *) a b c d e g h i.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse (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 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 DebugClosureWithExtra
  a PapPayload ConstrDesc StackFrames 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 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 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 p s.
DebugClosure p ConstrDesc s (Maybe ClosurePtr) -> Maybe String
isString (forall a.
HeapGraphEntry a
-> DebugClosure PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
hge) = forall a. Show a => a -> String
show String
s
        | Just [Maybe ClosurePtr]
l <- forall p s.
DebugClosure p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (forall a.
HeapGraphEntry a
-> DebugClosure 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.
String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
ppClosure (a -> String
printData (forall a. HeapGraphEntry a -> a
hgeData HeapGraphEntry a
hge)) Int -> Maybe ClosurePtr -> String
ppRef Int
prec (forall a.
HeapGraphEntry a
-> DebugClosure 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 p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe [Maybe HeapGraphIndex]
    isList :: forall p s.
DebugClosure p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure p ConstrDesc s (Maybe ClosurePtr)
c
        | forall p s c. DebugClosure p ConstrDesc s c -> Bool
isNil DebugClosure 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 p s c. DebugClosure p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure 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 p s.
DebugClosure p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList (forall a.
HeapGraphEntry a
-> DebugClosure PapHI ConstrDesc StackHI (Maybe ClosurePtr)
hgeClosure HeapGraphEntry a
e)
            return $ (:) Maybe ClosurePtr
h [Maybe ClosurePtr]
t'

    isString :: DebugClosure p ConstrDesc s (Maybe HeapGraphIndex) -> Maybe String
    isString :: forall p s.
DebugClosure p ConstrDesc s (Maybe ClosurePtr) -> Maybe String
isString DebugClosure p ConstrDesc s (Maybe ClosurePtr)
e = do
        [Maybe ClosurePtr]
list <- forall p s.
DebugClosure p ConstrDesc s (Maybe ClosurePtr)
-> Maybe [Maybe ClosurePtr]
isList DebugClosure 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 p s c. DebugClosure p ConstrDesc s c -> Maybe Char
isChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HeapGraphEntry a
-> DebugClosure 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 (GenPapPayload c) a (GenStackFrames c) c -> [c]
allClosures forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HeapGraphEntry a
-> DebugClosure 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 p ConstrDesc s c -> Maybe Char
isChar :: forall p s c. DebugClosure p ConstrDesc s c -> Maybe Char
isChar ConstrClosure{ constrDesc :: forall pap string s b. DebugClosure 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 pap string s b. DebugClosure pap string s b -> [Word]
dataArgs = [Word
ch], ptrArgs :: forall pap string s b. DebugClosure 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 p ConstrDesc s c
_ = forall a. Maybe a
Nothing

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

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

isTup :: DebugClosure p ConstrDesc s c -> Maybe [c]
isTup :: forall p s c. DebugClosure p ConstrDesc s c -> Maybe [c]
isTup ConstrClosure{ dataArgs :: forall pap string s b. DebugClosure pap string s b -> [Word]
dataArgs = [], [c]
ConstrDesc
StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
constrDesc :: ConstrDesc
ptrArgs :: [c]
info :: StgInfoTableWithPtr
ptrArgs :: forall pap string s b. DebugClosure pap string s b -> [b]
constrDesc :: forall pap string s b. DebugClosure 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 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 :: String -> (Int -> c -> String) -> Int -> DebugClosure p ConstrDesc s c -> String
ppClosure :: forall c p s.
String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
ppClosure String
herald Int -> c -> String
showBox Int
prec DebugClosure p ConstrDesc s c
c = case DebugClosure p ConstrDesc s c
c of
    DebugClosure p ConstrDesc s c
_ | Just Char
ch <- forall p s c. DebugClosure p ConstrDesc s c -> Maybe Char
isChar DebugClosure p ConstrDesc s c
c -> [String] -> String
app
        [String
"C#", forall a. Show a => a -> String
show Char
ch]
    DebugClosure p ConstrDesc s c
_ | Just (c
h,c
t) <- forall p s c. DebugClosure p ConstrDesc s c -> Maybe (c, c)
isCons DebugClosure 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 p ConstrDesc s c
_ | Just [c]
vs <- forall p s c. DebugClosure p ConstrDesc s c -> Maybe [c]
isTup DebugClosure 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 pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
ptrArgs :: forall pap string s b. DebugClosure pap string s b -> [b]
dataArgs :: forall pap string s b. DebugClosure pap string s b -> [Word]
constrDesc :: forall pap string s b. DebugClosure 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]
StgInfoTableWithPtr
dataArgs :: [Word]
ptrArgs :: [c]
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
ptrArgs :: forall pap string s b. DebugClosure pap string s b -> [b]
dataArgs :: forall pap string s b. DebugClosure pap string s b -> [Word]
..} -> [String] -> String
app forall a b. (a -> b) -> a -> b
$
        String
"_thunk(" forall a. a -> [a] -> [a]
: String
herald forall a. a -> [a] -> [a]
: 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 pap string s b. DebugClosure pap string s b -> b
selectee :: c
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
        [String
"_sel", Int -> c -> String
showBox Int
10 c
selectee]
    IndClosure {c
StgInfoTableWithPtr
indirectee :: forall pap string s b. DebugClosure pap string s b -> b
indirectee :: c
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> b
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> pap
fun :: forall pap string s b. DebugClosure pap string s b -> b
n_args :: forall pap string s b. DebugClosure pap string s b -> Word32
arity :: forall pap string s b. DebugClosure pap string s b -> Word32
ap_payload :: p
fun :: c
n_args :: Word32
arity :: Word32
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> pap
pap_payload :: p
fun :: c
n_args :: Word32
arity :: Word32
info :: StgInfoTableWithPtr
fun :: forall pap string s b. DebugClosure pap string s b -> b
n_args :: forall pap string s b. DebugClosure pap string s b -> Word32
arity :: forall pap string s b. DebugClosure pap string s b -> Word32
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> s
ap_st_size :: forall pap string s b. DebugClosure pap string s b -> Word
payload :: s
fun :: c
ap_st_size :: Word
info :: StgInfoTableWithPtr
fun :: forall pap string s b. DebugClosure pap string s b -> b
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> [Word]
size :: forall pap string s b. DebugClosure pap string s b -> Word32
bcoptrs :: forall pap string s b. DebugClosure pap string s b -> b
literals :: forall pap string s b. DebugClosure pap string s b -> b
instrs :: forall pap string s b. DebugClosure pap string s b -> b
bitmap :: [Word]
size :: Word32
arity :: Word32
bcoptrs :: c
literals :: c
instrs :: c
info :: StgInfoTableWithPtr
arity :: forall pap string s b. DebugClosure pap string s b -> Word32
info :: forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
        [String
"_bco", Int -> c -> String
showBox Int
10 c
bcoptrs]
    ArrWordsClosure {[Word]
Word
StgInfoTableWithPtr
arrWords :: forall pap string s b. DebugClosure pap string s b -> [Word]
bytes :: forall pap string s b. DebugClosure pap string s b -> Word
arrWords :: [Word]
bytes :: Word
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> [b]
mccSize :: forall pap string s b. DebugClosure pap string s b -> Word
mccPtrs :: forall pap string s b. DebugClosure pap string s b -> Word
mccPayload :: [c]
mccSize :: Word
mccPtrs :: Word
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> [b]
mccPtrs :: forall pap string s b. DebugClosure pap string s b -> Word
info :: forall pap string s b.
DebugClosure 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 pap string s b. DebugClosure pap string s b -> b
var :: c
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
        [String
"_mutVar", Int -> c -> String
showBox Int
10 c
var]
    MVarClosure {c
StgInfoTableWithPtr
value :: forall pap string s b. DebugClosure pap string s b -> b
queueTail :: forall pap string s b. DebugClosure pap string s b -> b
queueHead :: forall pap string s b. DebugClosure pap string s b -> b
value :: c
queueTail :: c
queueHead :: c
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
..} -> [String] -> String
app
        [String
"MVar", Int -> c -> String
showBox Int
10 c
value]
    FunClosure {[c]
[Word]
StgInfoTableWithPtr
dataArgs :: [Word]
ptrArgs :: [c]
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
ptrArgs :: forall pap string s b. DebugClosure pap string s b -> [b]
dataArgs :: forall pap string s b. DebugClosure pap string s b -> [Word]
..} ->
        String
"_fun" 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 pap string s b. DebugClosure pap string s b -> s
stack_marking :: forall pap string s b. DebugClosure pap string s b -> Word8
stack_dirty :: forall pap string s b. DebugClosure pap string s b -> Word8
stack_size :: forall pap string s b. DebugClosure pap string s b -> Word32
frames :: s
stack_marking :: Word8
stack_dirty :: Word8
stack_size :: Word32
info :: StgInfoTableWithPtr
info :: forall pap string s b.
DebugClosure 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 pap string s b.
DebugClosure 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 (GenPapPayload c) a (GenStackFrames c) c -> [c]
allClosures (forall a.
HeapGraphEntry a
-> DebugClosure 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