module GHC.Vacuum (
HNodeId
,HNode(..)
,emptyHNode
,vacuum,dump
,vacuumTo,dumpTo
,toAdjList
,nameGraph
,ShowHNode(..)
,showHNodes
,ppHs,ppDot
,Draw(..),G(..)
,draw,printDraw,split
,Closure(..)
,InfoTab(..)
,getClosure
,nodePkg,nodeMod
,nodeName,itabName
,getInfoPtr
) where
import GHC.Vacuum.Dot as Dot
import GHC.Vacuum.ClosureType
import GHC.Vacuum.GHC as GHC hiding (Closure)
import Data.Char
import Data.Word
import Data.List
import Data.Map(Map)
import Data.IntMap(IntMap)
import qualified Data.IntMap as IM
import qualified Data.Map as M
import Data.Monoid(Monoid(..))
import Data.Array.IArray
import System.IO.Unsafe
import Control.Monad
import Data.Bits
import Language.Haskell.Meta.Utils(pretty)
import Foreign
import GHC.Arr(Array(..))
import GHC.Exts
vacuum :: a -> IntMap HNode
vacuum a = unsafePerformIO (dump a)
vacuumTo :: Int -> a -> IntMap HNode
vacuumTo n a = unsafePerformIO (dumpTo n a)
dump :: a -> IO (IntMap HNode)
dump a = execH (dumpH a)
dumpTo :: Int -> a -> IO (IntMap HNode)
dumpTo n a = execH (dumpToH n a)
toAdjList :: IntMap HNode -> [(Int, [Int])]
toAdjList = fmap (mapsnd nodePtrs) . IM.toList
nameGraph :: IntMap HNode -> [(String, [String])]
nameGraph m = let g = toAdjList m
pp i = maybe "..."
(\n -> nodeName n ++ "|" ++ show i)
(IM.lookup i m)
in fmap (\(x,xs) -> (pp x, fmap pp xs)) g
data ShowHNode = ShowHNode
{showHNode :: Int -> HNode -> String
,externHNode :: Int -> String}
showHNodes :: ShowHNode -> IntMap HNode -> [(String, [String])]
showHNodes (ShowHNode showN externN) m
= let g = toAdjList m
pp i = maybe (externN i) (showN i) (IM.lookup i m)
in fmap (\(x,xs) -> (pp x, fmap pp xs)) g
ppHs :: (Show a) => a -> Doc
ppHs = text . pretty
ppDot :: [(String, [String])] -> Doc
ppDot = Dot.graphToDot id
type HNodeId = Int
data HNode = HNode
{nodePtrs :: [HNodeId]
,nodeLits :: [Word]
,nodeInfo :: InfoTab}
deriving(Eq,Ord,Read,Show)
data InfoTab
= ConInfo {itabPkg :: String
,itabMod :: String
,itabCon :: String
,itabPtrs :: Word
,itabLits :: Word
,itabType :: ClosureType
,itabSrtLen :: Word
,itabCode :: [Word]}
| OtherInfo {itabPtrs :: Word
,itabLits :: Word
,itabType :: ClosureType
,itabSrtLen :: Word
,itabCode :: [Word]}
deriving(Eq,Ord,Read,Show)
data Closure = Closure
{closPtrs :: [HValue]
,closLits :: [Word]
,closITab :: InfoTab}
deriving(Show)
instance Show HValue where show _ = "(HValue)"
data Draw e v m a = Draw
{mkV :: Int -> a -> m v
,mkE :: v -> v -> m e
,succs :: a -> [Int]}
newtype G e v = G {unG :: IntMap (v, IntMap e)}
deriving(Eq,Ord,Read,Show)
draw :: (Monad m) => Draw e v m a -> IntMap a -> m (G e v)
draw (Draw mkV mkE succs) g = do
vs <- IM.fromList `liftM` forM (IM.toList g)
(\(i,a) -> do v <- mkV i a
return (i,(v,succs a)))
(G . IM.fromList) `liftM` forM (IM.toList vs)
(\(i,(v,ps)) -> do let us = fmap (vs IM.!) ps
es <- IM.fromList `liftM` forM ps
(\p -> do e <- mkE v (fst (vs IM.! p))
return (p,e))
return (i,(v,es)))
printDraw :: Draw (Int,Int) Int IO HNode
printDraw = Draw
{mkV = \i _ -> print i >> return i
,mkE = \u v -> print (u,v) >> return (u,v)
,succs = nodePtrs}
split :: (a -> [Int]) -> IntMap a -> IntMap ([Int],[Int])
split f = flip IM.foldWithKey mempty (\i a m ->
let ps = f a
in foldl' (\m p -> IM.insertWith mappend p ([i],[]) m)
(IM.insertWith mappend i ([],ps) m)
ps)
emptyHNode :: ClosureType -> HNode
emptyHNode ct = HNode
{nodePtrs = []
,nodeLits = []
,nodeInfo = if isCon ct
then ConInfo [] [] [] 0 0 ct 0 []
else OtherInfo 0 0 ct 0 []}
nodePkg :: HNode -> String
nodeMod :: HNode -> String
nodeName :: HNode -> String
nodePkg = fst3 . itabName . nodeInfo
nodeMod = snd3 . itabName . nodeInfo
nodeName = trd3 . itabName . nodeInfo
fst3 (x,_,_) = x
snd3 (_,x,_) = x
trd3 (_,_,x) = x
itabName :: InfoTab -> (String, String, String)
itabName i@(ConInfo{}) = (itabPkg i, itabMod i, itabCon i)
itabName _ = ([], [], [])
getInfoPtr :: a -> Ptr StgInfoTable
getInfoPtr a = let b = a `seq` Box a
in b `seq` case unpackClosure# a of
(# iptr,_,_ #)
| ghciTablesNextToCode -> Ptr iptr
| otherwise -> Ptr iptr `plusPtr`
negate wORD_SIZE
getClosure :: a -> IO Closure
getClosure a = a `seq`
case unpackClosure# a of
(# iptr
,ptrs
,nptrs #) -> do
let iptr' | ghciTablesNextToCode = Ptr iptr
| otherwise = Ptr iptr `plusPtr` negate wORD_SIZE
itab <- peekInfoTab iptr'
let elems = fromIntegral (itabPtrs itab)
ptrsList = if elems < 1
then []
else dumpArray (Array 0 (elems 1) elems ptrs)
lits = [W# (indexWordArray# nptrs i)
| I# i <- [0.. fromIntegral (itabLits itab)] ]
return (Closure ptrsList lits itab)
peekInfoTab :: Ptr StgInfoTable -> IO InfoTab
peekInfoTab p = do
stg <- peek p
let ct = (toEnum . fromIntegral . GHC.tipe) stg
case ct of
_ | isCon ct -> do (a,b,c) <- dataConInfoPtrToNames (castPtr p)
return $ ConInfo
{itabPkg = a
,itabMod = b
,itabCon = c
,itabPtrs = (fromIntegral . GHC.stgItblPtrs) stg
,itabLits = (fromIntegral . GHC.nptrs) stg
,itabType = ct
,itabSrtLen = fromIntegral (GHC.srtlen stg)
,itabCode = fmap fromIntegral (GHC.code stg)}
_ -> return $ OtherInfo
{itabPtrs = (fromIntegral . GHC.stgItblPtrs) stg
,itabLits = (fromIntegral . GHC.nptrs) stg
,itabType = ct
,itabSrtLen = fromIntegral (GHC.srtlen stg)
,itabCode = fmap fromIntegral (GHC.code stg)}
type H a = S Env a
execH :: H a -> IO (IntMap HNode)
execH m = snd `fmap` runH m
runH :: H a -> IO (a, IntMap HNode)
runH m = do
(a, s) <- runS m emptyEnv
return (a, graph s)
data Env = Env
{uniq :: HNodeId
,seen :: [(HValue, HNodeId)]
,hvals :: IntMap HValue
,graph :: IntMap HNode}
emptyEnv :: Env
emptyEnv = Env
{uniq = 0
,seen = []
,hvals = mempty
,graph = mempty}
dumpH :: a -> H ()
dumpH a = go =<< rootH a
where go :: HValue -> H ()
go a = a `seq` do
ids <- nodeH a
case ids of
[] -> return ()
_ -> mapM_ go =<< mapM getHVal ids
dumpToH :: Int -> a -> H ()
dumpToH n _ | n < 1 = return ()
dumpToH n a = go (n1) =<< rootH a
where go :: Int -> HValue -> H ()
go 0 _ = return ()
go n a = a `seq` do
ids <- nodeH a
case ids of
[] -> return ()
_ -> mapM_ (go (n1)) =<< mapM getHVal ids
data Box a = Box a
rootH :: a -> H HValue
rootH a = let b = a `seq` Box a
in b `seq` do
c <- io (getClosureData b)
case dumpArray (GHC.ptrs c) of
[hval] -> return hval
_ -> error "zomg"
nodeH :: HValue -> H [HNodeId]
nodeH a = a `seq` do
clos <- io (getClosure a)
(i, _) <- getId a
let itab = closITab clos
ptrs = closPtrs clos
ptrs' <- case itabType itab of
t | isCon t ->
case itabCon itab of
"J#" -> return []
"MVar" -> return []
"STRef" -> return []
"Array" -> return (take 2 ptrs)
"MallocPtr" -> return (drop 1 ptrs)
"PlainPtr" -> return []
_ -> return ptrs
| otherwise -> return ptrs
xs <- mapM getId ptrs'
let news = (fmap fst . fst . partition snd) xs
n = HNode (fmap fst xs)
(closLits clos)
(closITab clos)
insertG i n
return news
getHVal :: HNodeId -> H HValue
getHVal i = (IM.! i) `fmap` gets hvals
insertG :: HNodeId -> HNode -> H ()
insertG i n = do
g <- gets graph
modify (\e->e{graph = IM.insert i n g})
newId :: H HNodeId
newId = do
n <- gets uniq
modify (\e->e{uniq=n+1})
return n
getId :: HValue -> H (HNodeId, Bool)
getId hval = hval `seq` do
s <- gets seen
case look hval s of
Just i -> return (i, False)
Nothing -> do
i <- newId
vs <- gets hvals
modify (\e->e{seen=(hval,i):s
,hvals= IM.insert i hval vs})
return (i, True)
look :: HValue -> [(HValue, a)] -> Maybe a
look _ [] = Nothing
look hval ((x,i):xs)
| hval .==. x = Just i
| otherwise = look hval xs
(.==.) :: HValue -> HValue -> Bool
a .==. b = a `seq` b `seq`
(0 /= I# (reallyUnsafePtrEquality# a b))
dumpArray :: Array Int a -> [a]
dumpArray a = let (m,n) = bounds a
in fmap (a!) [m..n]
mapfst f = \(a,b) -> (f a,b)
mapsnd f = \(a,b) -> (a,f b)
f *** g = \(a, b) -> (f a, g b)
p2i :: Ptr a -> Int
i2p :: Int -> Ptr a
p2i (Ptr a#) = I# (addr2Int# a#)
i2p (I# n#) = Ptr (int2Addr# n#)
newtype S s a = S {unS :: forall o. s -> (s -> a -> IO o) -> IO o}
instance Functor (S s) where
fmap f (S g) = S (\s k -> g s (\s a -> k s (f a)))
instance Monad (S s) where
return a = S (\s k -> k s a)
S g >>= f = S (\s k -> g s (\s a -> unS (f a) s k))
get :: S s s
get = S (\s k -> k s s)
gets :: (s -> a) -> S s a
gets f = S (\s k -> k s (f s))
set :: s -> S s ()
set s = S (\_ k -> k s ())
io :: IO a -> S s a
io m = S (\s k -> k s =<< m)
modify :: (s -> s) -> S s ()
modify f = S (\s k -> k (f s) ())
runS :: S s a -> s -> IO (a, s)
runS (S g) s = g s (\s a -> return (a, s))