-- | Utilities to debug "GHC.HeapView".
module GHC.HeapView.Debug where

import GHC.HeapView
import Text.Printf
import System.IO
import Control.Monad
import System.Mem
import Data.Maybe
import Data.Char
import Data.IORef

-- | This function walks the heap referenced by the argument, printing the
-- \"path\", i.e. the pointer indices from the initial to the current closure
-- and the closure itself. When the runtime crashes, the problem is likely
-- related to one of the earlier steps.
walkHeap
    :: Bool -- ^ Whether to check for cycles
    -> Bool -- ^ Whether to GC in every step
    -> Box -- ^ The closure to investigate
    -> IO ()
walkHeap :: Bool -> Bool -> Box -> IO ()
walkHeap Bool
slow Bool
check Box
x = do
    IORef [(Box, [Int])]
seenRef <- forall a. a -> IO (IORef a)
newIORef []
    IORef [(Box, [Int])] -> [Int] -> Box -> IO ()
go IORef [(Box, [Int])]
seenRef [] Box
x
 where
    go :: IORef [(Box, [Int])] -> [Int] -> Box -> IO ()
go IORef [(Box, [Int])]
seenRef [Int]
prefix Box
b = do
        ()
_ <- forall r. PrintfType r => String -> r
printf String
"At %s:\n" (forall a. Show a => a -> String
show [Int]
prefix)
        [(Box, [Int])]
seen <- forall a. IORef a -> IO a
readIORef IORef [(Box, [Int])]
seenRef
        Maybe (Box, [Int])
previous <- if Bool
check then forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM (Box -> Box -> IO Bool
areBoxesEqual Box
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Box, [Int])]
seen else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        case Maybe (Box, [Int])
previous of
            Just (Box
_,[Int]
p') -> forall r. PrintfType r => String -> r
printf String
"Seen at %s.\n" (forall a. Show a => a -> String
show [Int]
p')
            Maybe (Box, [Int])
Nothing -> do
                Handle -> IO ()
hFlush Handle
stdout
                Closure
c <- Box -> IO Closure
getBoxedClosureData Box
b
                String -> IO ()
putStrLn (forall b. (Int -> b -> String) -> Int -> GenClosure b -> String
ppClosure (\Int
_ Box
box -> forall a. Show a => a -> String
show Box
box) Int
0 Closure
c)
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
slow IO ()
performGC
                Bool
isCC <- Closure -> IO Bool
isCharCons Closure
c
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isCC forall a b. (a -> b) -> a -> b
$ do
                    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(Box, [Int])]
seenRef ((Box
b,[Int]
prefix)forall a. a -> [a] -> [a]
:)
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0::Int)..] (forall b. GenClosure b -> [b]
allClosures Closure
c)) forall a b. (a -> b) -> a -> b
$ \(Int
n,Box
box) ->
                        IORef [(Box, [Int])] -> [Int] -> Box -> IO ()
go IORef [(Box, [Int])]
seenRef ([Int]
prefix forall a. [a] -> [a] -> [a]
++ [Int
n]) Box
box

walkPrefix :: [Int] -> a -> IO Box
walkPrefix :: forall a. [Int] -> a -> IO Box
walkPrefix [Int]
is a
v = [Int] -> Box -> IO Box
go [Int]
is (forall a. a -> Box
asBox a
v)
  where
    go :: [Int] -> Box -> IO Box
go [] Box
a = forall (m :: * -> *) a. Monad m => a -> m a
return Box
a
    go (Int
x:[Int]
xs) Box
a = do
        Closure
c <- Box -> IO Closure
getBoxedClosureData Box
a
        forall a. [Int] -> a -> IO Box
walkPrefix [Int]
xs (forall b. GenClosure b -> [b]
allClosures Closure
c forall a. [a] -> Int -> a
!! Int
x)


findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
findM :: forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM a -> IO Bool
_p [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
findM a -> IO Bool
p (a
x:[a]
xs) = do
    Bool
b <- a -> IO Bool
p a
x
    if Bool
b then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x) else forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM a -> IO Bool
p [a]
xs

isCharCons :: GenClosure Box -> IO Bool
isCharCons :: Closure -> IO Bool
isCharCons Closure
c | Just (Box
h,Box
_) <- forall b. GenClosure b -> Maybe (b, b)
isCons Closure
c = (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. GenClosure b -> Maybe Char
isChar) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box -> IO Closure
getBoxedClosureData Box
h
isCharCons Closure
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isCons :: GenClosure b -> Maybe (b, b)
isCons :: forall b. GenClosure b -> Maybe (b, b)
isCons (ConstrClosure { name :: forall b. GenClosure b -> String
name = String
":", dataArgs :: forall b. GenClosure b -> [Word]
dataArgs = [], ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs = [b
h,b
t]}) = forall a. a -> Maybe a
Just (b
h,b
t)
isCons GenClosure b
_ = forall a. Maybe a
Nothing

isChar :: GenClosure b -> Maybe Char
isChar :: forall b. GenClosure b -> Maybe Char
isChar (ConstrClosure { name :: forall b. GenClosure b -> String
name = String
"C#", dataArgs :: forall b. GenClosure b -> [Word]
dataArgs = [Word
ch], ptrArgs :: forall b. GenClosure 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 GenClosure b
_ = forall a. Maybe a
Nothing