heapview2dot

Main.hs

{-# language RecordWildCards #-}

module Main where

import Data.List
import GHC.HeapView
import System.Mem
import qualified Data.IntMap as IntMap

main = do
    let fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
    print (fibs !! 4)
    g <- buildHeapGraph 1000 () (asBox fibs)
    putStrLn $ memg2dot g
    performMajorGC
    putStrLn "!!!!!GC!!!!!"
    g <- buildHeapGraph 1000 () (asBox fibs)
    putStrLn $ memg2dot g


memg2dot g = unlines d where
    ps = g2dot g
    Just (HeapGraphEntry{..}) = lookupHeapGraph heapGraphRoot g
    d = digraph (root hgeBox : rootlink heapGraphRoot : ps)

digraph xs = [
    "digraph structs {",
    "node [shape=record];",
    "rankdir=LR;"]
    ++ xs 
    ++ ["}"]

lastN n xs | length xs < n + 1 = xs
           | otherwise = ("~" ++) . reverse . take n . reverse $ xs

root :: Box -> String
root box = "root [label=\"" ++ lastN 12 (show box) ++ "\"]"

header con ty = "<info> " ++ con ++ " " ++ show ty

struct i n ty pld = 
    ["struct" ++ show i ++ " [label=\"",
     header n ty] ++ pld ++ ["\"];"]

fld :: Int -> Maybe Box -> String
fld i Nothing  = "| <f" ++ show i ++ "> ???"
fld i (Just b) = "| <f" ++ show i ++ "> " ++ lastN 12 (show b)

wpair u v = "| { " ++ show u ++ " | " ++ show v ++ " }"

refs = zipWith fld [0..] 

wrd w = "| " ++ show w

wrds = map wrd

rootlink r = "root -> struct" ++ show r ++ ":info"

lnk i f Nothing = "struct" ++ show i ++ ":f" ++ show f ++ 
          "-> unknown"
lnk i f (Just j) = "struct" ++ show i ++ ":f" ++ show f ++ 
          "-> struct" ++ show j ++ ":info;"

links i = zipWith (lnk i) [0..] 

he2dot g i HeapGraphEntry{..} = cl2dot g i hgeClosure

g2dot g@(HeapGraph m) = concatMap (uncurry (he2dot g)) $ IntMap.toList m  

ty = tipe . info

boxes g = map (getbox g)
 
getbox g mi = do 
    i <- mi
    r <- lookupHeapGraph i g 
    return $ hgeBox r

obj g i n c = obj' g i n c (ptrArgs c) (dataArgs c)

obj' g i n c ps ws = struct i n (ty c) pld 
         ++ links i ps where
    pld = refs (boxes g ps) ++ wrds ws

ind g i n c r = struct i n (ty c) (refs (boxes g [r])) 
         ++ links i [r]

-- TODO label fun
pap g i n c = struct i n (ty c) pld 
         ++ links i rs where
    rs = fun c : payload c
    pld = [wpair (arity c) (n_args c)] ++ refs (boxes g rs) 

pap2 g i n c = struct i n (ty c) pld 
         ++ links i rs where
    rs = fun c : payload c
    pld = refs (boxes g rs)

-- TODO card table, labels

arr g i n c@MutArrClosure{..} = struct i n (ty c) pld 
         ++ links i mccPayload where
    pld = wrds [mccPtrs, mccSize] ++ refs (boxes g mccPayload)

--   | MutArrClosure
--         { info       :: !StgInfoTable
--         , mccPtrs    :: !Word           -- ^ Number of pointers
--         , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h
--         , mccPayload :: ![b]            -- ^ Array payload
--         -- Card table ignored
--         }

cl2dot g i c@ConstrClosure{..} = 
    obj g i (lastN 12 (modl ++ "." ++ name) ++ "&#92;n") c

--     -- | A data constructor
--     ConstrClosure
--         { info       :: !StgInfoTable
--         , ptrArgs    :: ![b]            -- ^ Pointer arguments
--         , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
--         , pkg        :: !String         -- ^ Package name
--         , modl       :: !String         -- ^ Module name
--         , name       :: !String         -- ^ Constructor name
--         }

cl2dot g i c@FunClosure{} = obj g i "" c

--     -- | A function
--   | FunClosure
--         { info       :: !StgInfoTable
--         , ptrArgs    :: ![b]            -- ^ Pointer arguments
--         , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
--         }

cl2dot g i c@ThunkClosure{} = obj g i "" c

--     -- | A thunk, an expression not obviously in head normal form
--   | ThunkClosure
--         { info       :: !StgInfoTable
--         , ptrArgs    :: ![b]            -- ^ Pointer arguments
--         , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
--         }

cl2dot g i c@SelectorClosure{..} = ind g i "Selector" c selectee

--     -- | A thunk which performs a simple selection operation
--   | SelectorClosure
--         { info       :: !StgInfoTable
--         , selectee   :: !b              -- ^ Pointer to the object being
--                                         --   selected from
--         }

cl2dot g i c@PAPClosure{} = pap g i "PAP" c

--     -- | An unsaturated function application
--   | PAPClosure
--         { info       :: !StgInfoTable
--         , arity      :: !HalfWord       -- ^ Arity of the partial application
--         , n_args     :: !HalfWord       -- ^ Size of the payload in words
--         , fun        :: !b              -- ^ Pointer to a 'FunClosure'
--         , payload    :: ![b]            -- ^ Sequence of already applied
--                                         --   arguments
--         }

cl2dot g i c@APClosure{} = pap g i "APC" c

--     -- | A function application
--   | APClosure
--         { info       :: !StgInfoTable
--         , arity      :: !HalfWord       -- ^ Always 0
--         , n_args     :: !HalfWord       -- ^ Size of payload in words
--         , fun        :: !b              -- ^ Pointer to a 'FunClosure'
--         , payload    :: ![b]            -- ^ Sequence of already applied
--                                         --   arguments
--         }

cl2dot g i c@APStackClosure{} = pap2 g i "APStack" c

--     -- | A suspended thunk evaluation
--   | APStackClosure
--         { info       :: !StgInfoTable
--         , fun        :: !b              -- ^ Function closure
--         , payload    :: ![b]            -- ^ Stack right before suspension
--         }

cl2dot g i c@IndClosure{..} = ind g i "" c indirectee

--     -- | A pointer to another closure, introduced when a thunk is updated
--     -- to point at its value
--   | IndClosure
--         { info       :: !StgInfoTable
--         , indirectee :: !b              -- ^ Target closure
--         }

-- TODO
cl2dot g i c@BCOClosure{..} = struct i "BCO" (ty c) (replicate 5 "|")

--    -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code
--    -- interpreter (e.g. as used by GHCi)
--   | BCOClosure
--         { info       :: !StgInfoTable
--         , instrs     :: !b              -- ^ A pointer to an ArrWords
--                                         --   of instructions
--         , literals   :: !b              -- ^ A pointer to an ArrWords
--                                         --   of literals
--         , bcoptrs    :: !b              -- ^ A pointer to an ArrWords
--                                         --   of byte code objects
--         , arity      :: !HalfWord       -- ^ The arity of this BCO
--         , size       :: !HalfWord       -- ^ The size of this BCO in words
--         , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the
--                                         --   pointerhood of its args/free vars
--         }

cl2dot g i c@BlackholeClosure{..} = ind g i "" c indirectee

--     -- | A thunk under evaluation by another thread
--   | BlackholeClosure
--         { info       :: !StgInfoTable
--         , indirectee :: !b              -- ^ The target closure
--         }

-- TODO bytes
cl2dot g i c@ArrWordsClosure{..} = 
    obj' g i "ArrWords" c [] (bytes:arrWords)

--     -- | A @ByteArray#@
--   | ArrWordsClosure
--         { info       :: !StgInfoTable
--         , bytes      :: !Word           -- ^ Size of array in bytes
--         , arrWords   :: ![Word]         -- ^ Array payload
--         }

-- TODO Card table
cl2dot g i c@MutArrClosure{} = obj g i "Arr" c

--     -- | A @MutableByteArray#@
--   | MutArrClosure
--         { info       :: !StgInfoTable
--         , mccPtrs    :: !Word           -- ^ Number of pointers
--         , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h
--         , mccPayload :: ![b]            -- ^ Array payload
--         -- Card table ignored
--         }

-- TODO labels
cl2dot g i c@MVarClosure{..} = 
    obj' g i "MVar" c [queueHead,queueTail,value] []

--     -- | An @MVar#@, with a queue of thread state objects blocking on them
--   | MVarClosure
--         { info       :: !StgInfoTable
--         , queueHead  :: !b              -- ^ Pointer to head of queue
--         , queueTail  :: !b              -- ^ Pointer to tail of queue
--         , value      :: !b              -- ^ Pointer to closure
--         }

cl2dot g i c@MutVarClosure{..} = ind g i "MutVar" c var

--     -- | A @MutVar#@
--   | MutVarClosure
--         { info       :: !StgInfoTable
--         , var        :: !b              -- ^ Pointer to closure
--         }

-- TODO labels
cl2dot g i c@BlockingQueueClosure{..} = 
    obj' g i "BlockingQueue" c [link,blackHole,owner,queue] []

--     -- | An STM blocking queue.
--   | BlockingQueueClosure
--         { info       :: !StgInfoTable
--         , link       :: !b              -- ^ ?? Here so it looks like an IND
--         , blackHole  :: !b              -- ^ The blackhole closure
--         , owner      :: !b              -- ^ The owning thread state object
--         , queue      :: !b              -- ^ ??
--         }

cl2dot g i c@OtherClosure{..} = obj' g i "Other" c hvalues rawWords

--     -- | Another kind of closure
--   | OtherClosure
--         { info       :: !StgInfoTable
--         , hvalues    :: ![b]
--         , rawWords   :: ![Word]
--         }

cl2dot g i c@UnsupportedClosure{info=StgInfoTable{..}} = 
    struct i "Unsupported" tipe
        (replicate (fromIntegral ptrs + fromIntegral nptrs) " | ") 

--   | UnsupportedClosure
--         { info       :: !StgInfoTable
--         }