Add debugging module

diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal
index e57034a..aa2883a 100644 (file)
--- a/ghc-heap-view.cabal
+++ b/ghc-heap-view.cabal
@@ -59,6 +59,7 @@ Library
     GHC.HeapView 
     GHC.AssertNF 
     GHC.Disassembler
+    GHC.HeapView.Debug
   Build-depends:
     base >= 4.5 && < 4.7,
     containers,

diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs
index f99af1f..ed589f7 100644 (file)
--- a/src/GHC/HeapView.hs
+++ b/src/GHC/HeapView.hs
@@ -657,9 +657,9 @@ ppClosure showBox prec c = case c of
     BCOClosure {..} -> app
         ["_bco"]
     ArrWordsClosure {..} -> app
-        ["toArray", intercalate "," (map show arrWords) ]
-    MutArrClosure {..} -> app
-        ["toMutArray", intercalate "," (map (showBox 10) mccPayload)]
+        ["toArray", intercalate "," (shorten (map show arrWords)) ]
+    MutArrClosure {..} -> app 
+        ["toMutArray", intercalate "," (shorten (map (showBox 10) mccPayload))]
     MutVarClosure {..} -> app $
         ["_mutVar", (showBox 10) var]
     MVarClosure {..} -> app $
@@ -675,6 +675,8 @@ ppClosure showBox prec c = case c of
   where
     app [a] = a  ++ "()"
     app xs = addBraces (10 <= prec) (intercalate " " xs)
+
+    shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs
     
 {- $heapmap
 

diff --git a/src/GHC/HeapView/Debug.hs b/src/GHC/HeapView/Debug.hs
new file mode 100644 (file)
index 0000000..c180a3f
--- /dev/null
+++ b/src/GHC/HeapView/Debug.hs
@@ -0,0 +1,69 @@
+-- | 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.Functor
+import Data.Char
+import Data.IORef
+
+-- | This functions 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 -- ^ Whethter to GC in every step
+    -> Box -- ^ The closure to investigate
+    -> IO ()
+walkHeap slow check x = do
+    seenRef <- newIORef []
+    go seenRef [] x
+ where
+    go seenRef prefix b = do
+        _ <- printf "At %s:\n" (show prefix)
+        seen <- readIORef seenRef
+        previous <- if check then findM (areBoxesEqual b . fst) seen else return Nothing
+        case previous of
+            Just (_,p') -> printf "Seen at %s.\n" (show p')
+            Nothing -> do
+                hFlush stdout
+                c <- getBoxedClosureData b
+                putStrLn (ppClosure (\_ box -> show box) 0 c)
+                when slow performGC
+                isCC <- isCharCons c
+                unless isCC $ do
+                    modifyIORef seenRef ((b,prefix):)
+                    forM_ (zip [(0::Int)..] (allPtrs c)) $ \(n,box) ->
+                        go seenRef (prefix ++ [n]) box
+
+walkPrefix :: [Int] -> a -> IO Box
+walkPrefix is v = go is (asBox v)
+  where
+    go [] a = return a
+    go (x:xs) a = do
+        c <- getBoxedClosureData a
+        walkPrefix xs (allPtrs c !! x)
+
+
+findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)
+findM _p [] = return Nothing
+findM p (x:xs) = do
+    b <- p x
+    if b then return (Just x) else findM p xs
+
+isCharCons :: GenClosure Box -> IO Bool
+isCharCons c | Just (h,_) <- isCons c = (isJust . isChar) <$> getBoxedClosureData h
+isCharCons _ = return False 
+
+isCons :: GenClosure b -> Maybe (b, b)
+isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
+isCons _ = Nothing
+
+isChar :: GenClosure b -> Maybe Char
+isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
+isChar _ = Nothing