-- | 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 <- [(Box, [Int])] -> IO (IORef [(Box, [Int])])
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
        ()
_ <- String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"At %s:\n" ([Int] -> String
forall a. Show a => a -> String
show [Int]
prefix)
        [(Box, [Int])]
seen <- IORef [(Box, [Int])] -> IO [(Box, [Int])]
forall a. IORef a -> IO a
readIORef IORef [(Box, [Int])]
seenRef
        Maybe (Box, [Int])
previous <- if Bool
check then ((Box, [Int]) -> IO Bool)
-> [(Box, [Int])] -> IO (Maybe (Box, [Int]))
forall a. (a -> IO Bool) -> [a] -> IO (Maybe a)
findM (Box -> Box -> IO Bool
areBoxesEqual Box
b (Box -> IO Bool)
-> ((Box, [Int]) -> Box) -> (Box, [Int]) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Box, [Int]) -> Box
forall a b. (a, b) -> a
fst) [(Box, [Int])]
seen else Maybe (Box, [Int]) -> IO (Maybe (Box, [Int]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Box, [Int])
forall a. Maybe a
Nothing
        case Maybe (Box, [Int])
previous of
            Just (Box
_,[Int]
p') -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"Seen at %s.\n" ([Int] -> String
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 ((Int -> Box -> String) -> Int -> Closure -> String
forall b. (Int -> b -> String) -> Int -> GenClosure b -> String
ppClosure (\Int
_ Box
box -> Box -> String
forall a. Show a => a -> String
show Box
box) Int
0 Closure
c)
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
slow IO ()
performGC
                Bool
isCC <- Closure -> IO Bool
isCharCons Closure
c
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isCC (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    IORef [(Box, [Int])] -> ([(Box, [Int])] -> [(Box, [Int])]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(Box, [Int])]
seenRef ((Box
b,[Int]
prefix)(Box, [Int]) -> [(Box, [Int])] -> [(Box, [Int])]
forall a. a -> [a] -> [a]
:)
                    [(Int, Box)] -> ((Int, Box) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [Box] -> [(Int, Box)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0::Int)..] (Closure -> [Box]
forall b. GenClosure b -> [b]
allClosures Closure
c)) (((Int, Box) -> IO ()) -> IO ()) -> ((Int, Box) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
n,Box
box) ->
                        IORef [(Box, [Int])] -> [Int] -> Box -> IO ()
go IORef [(Box, [Int])]
seenRef ([Int]
prefix [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
n]) Box
box

walkPrefix :: [Int] -> a -> IO Box
walkPrefix :: [Int] -> a -> IO Box
walkPrefix [Int]
is a
v = [Int] -> Box -> IO Box
go [Int]
is (a -> Box
forall a. a -> Box
asBox a
v)
  where
    go :: [Int] -> Box -> IO Box
go [] Box
a = Box -> IO Box
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
        [Int] -> Box -> IO Box
forall a. [Int] -> a -> IO Box
walkPrefix [Int]
xs (Closure -> [Box]
forall b. GenClosure b -> [b]
allClosures Closure
c [Box] -> Int -> Box
forall a. [a] -> Int -> a
!! Int
x)


findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
findM a -> IO Bool
_p [] = Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
x) else (a -> IO Bool) -> [a] -> IO (Maybe a)
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
_) <- Closure -> Maybe (Box, Box)
forall b. GenClosure b -> Maybe (b, b)
isCons Closure
c = (Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Char -> Bool) -> (Closure -> Maybe Char) -> Closure -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure -> Maybe Char
forall b. GenClosure b -> Maybe Char
isChar) (Closure -> Bool) -> IO Closure -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box -> IO Closure
getBoxedClosureData Box
h
isCharCons Closure
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

isCons :: GenClosure b -> Maybe (b, b)
isCons :: 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]}) = (b, b) -> Maybe (b, b)
forall a. a -> Maybe a
Just (b
h,b
t)
isCons GenClosure b
_ = Maybe (b, b)
forall a. Maybe a
Nothing

isChar :: GenClosure b -> Maybe Char
isChar :: 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 = []}) = Char -> Maybe Char
forall a. a -> Maybe a
Just (Int -> Char
chr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
ch))
isChar GenClosure b
_ = Maybe Char
forall a. Maybe a
Nothing