module GHC.Vacuum (
HNodeId
,HNode(..)
,emptyHNode
,summary
,vacuum,vacuumTo,vacuumLazy,vacuumStream,vacuumDebug
,dump,dumpTo,dumpLazy
,toAdjList,toAdjPair
,nameGraph
,ShowHNode(..)
,showHNodes
--,ppHs
,ppDot
,Draw(..),G(..)
,draw,printDraw,split
,Closure(..)
,InfoTab(..)
,getClosure
,closureType
,getInfoTab
,getInfoPtr
,peekInfoTab
,nodePkg,nodeMod
,nodeName,itabName
,HValue
) where
import GHC.Vacuum.Q
import GHC.Vacuum.Util
import GHC.Vacuum.Types
import GHC.Vacuum.Pretty
import GHC.Vacuum.ClosureType
import GHC.Vacuum.Internal as GHC
import Data.List
import Data.Char
import Data.Word
import Data.Bits
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 System.IO.Unsafe
import Control.Monad
import Control.Applicative
import Control.Exception
import Prelude hiding(catch)
import Control.Concurrent
import Foreign hiding (unsafePerformIO)
import GHC.Arr(Array(..))
import GHC.Exts
import System.Mem.StableName
vacuum :: a -> IntMap HNode
vacuum a = unsafePerformIO (dump a)
vacuumStream :: a -> [(HNodeId, HNode)]
vacuumStream a = unsafePerformIO (dumpStream a)
vacuumDebug :: a -> IntMap [(StableName HValue, HNodeId)]
vacuumDebug a = unsafePerformIO (dumpDebug a)
vacuumTo :: Int -> a -> IntMap HNode
vacuumTo n a = unsafePerformIO (dumpTo n a)
vacuumLazy :: a -> IntMap HNode
vacuumLazy a = unsafePerformIO (dumpLazy a)
dump :: a -> IO (IntMap HNode)
dump a = execH (dumpH a)
dumpStream :: a -> IO [(HNodeId, HNode)]
dumpStream a = streamH (flip dumpStreamH a)
dumpDebug :: a -> IO (IntMap [(StableName HValue, HNodeId)])
dumpDebug a = debugH (dumpH a)
dumpTo :: Int -> a -> IO (IntMap HNode)
dumpTo n a = execH (dumpToH n a)
dumpLazy :: a -> IO (IntMap HNode)
dumpLazy a = execH (dumpLazyH a)
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
defined :: HValue -> IO HValue
defined a = grab (return $! a) (return . unsafeCoerce#)
grab :: IO a -> (SomeException -> IO a) -> IO a
grab = catch
getClosure :: a -> IO Closure
getClosure a = grab (getClosure_ a) getClosure
getClosure_ :: a -> IO Closure
getClosure_ a =
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)
ptrs0 = dumpArray# ptrs 0 elems
lits = [W# (indexWordArray# nptrs i)
| I# i <- [0.. fromIntegral (itabLits itab1)] ]
case itab of
OtherInfo { itabType = tipe }
| tipe == IND || tipe == IND_OLDGEN || tipe == IND_PERM ||
tipe == IND_OLDGEN_PERM || tipe == IND_STATIC ->
case ptrs0 of
(dest : _) -> getClosure_ dest
_ -> return (Closure ptrs0 lits itab)
dumpArray# :: Array# HValue -> Int -> Int -> [HValue]
dumpArray# arr# i@(I# i#) l
| i >= l = []
| otherwise = case indexArray# arr# i# of
(# h #) -> h : dumpArray# arr# (i+1) l
closureType :: a -> IO ClosureType
closureType a = itabType <$> getInfoTab a
getInfoTab :: a -> IO InfoTab
getInfoTab a =
case unpackClosure# a of
(# iptr
,_
,_ #) -> do
let iptr' | ghciTablesNextToCode = Ptr iptr
| otherwise = Ptr iptr `plusPtr` negate wORD_SIZE
peekInfoTab iptr'
peekInfoTab :: Ptr StgInfoTable -> IO InfoTab
peekInfoTab p = do
stg <- peek p
let ct = (toEnum . fromIntegral . GHC.tipe) stg
case ct of
_ | hasName stg -> do (a,b,c) <- dataConInfoPtrToNames (castPtr p)
return $ ConInfo
{itabPkg = a
,itabMod = b
,itabCon = c
,itabPtrs = (fromIntegral . GHC.ptrs) stg
,itabLits = (fromIntegral . GHC.nptrs) stg
,itabType = ct
,itabSrtLen = fromIntegral (GHC.srtlen stg)
,itabCode = fmap fromIntegral (GHC.code stg)}
_ -> return $ OtherInfo
{itabPtrs = (fromIntegral . GHC.ptrs) stg
,itabLits = (fromIntegral . GHC.nptrs) stg
,itabType = ct
,itabSrtLen = fromIntegral (GHC.srtlen stg)
,itabCode = fmap fromIntegral (GHC.code stg)}
hasName :: StgInfoTable -> Bool
hasName stg = let ct = (toEnum . fromIntegral . GHC.tipe) stg :: ClosureType
lits = (fromIntegral . GHC.nptrs) stg :: Int
ptrs = (fromIntegral . GHC.ptrs) stg :: Int
in isCon ct
&& lits < 1024
&& ptrs < 1024
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)
runH_ :: H a -> IO ()
runH_ m = do
_ <- runS m emptyEnv
return ()
debugH :: H a -> IO (IntMap [(StableName HValue,HNodeId)])
debugH m = (seen . snd) <$> runS m emptyEnv
streamH :: (Q (Maybe a) -> H b) -> IO [a]
streamH m = do
q <- newQ
tid <- forkIO (runH_ (m q) `finally` putQ q Nothing)
fmap fromJust <$> takeWhileQ isJust q
fromJust :: Maybe a -> a
fromJust (Just a) = a
isJust :: Maybe a -> Bool
isJust (Just{}) = True
isJust _ = False
vacuumH :: (HValue -> H [HNodeId]) -> a -> H ()
vacuumH scan a = go =<< rootH a
where go :: HValue -> H ()
go a = do
ids <- scan a
case ids of
[] -> return ()
_ -> mapM_ go =<< mapM getHVal ids
dumpH :: a -> H ()
dumpH = vacuumH nodeH
dumpLazyH :: a -> H ()
dumpLazyH = vacuumH nodeLazyH
dumpStreamH :: Q (Maybe (HNodeId,HNode)) -> a -> H ()
dumpStreamH q = vacuumH (nodeStreamH q)
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 = do
ids <- nodeH a
case ids of
[] -> return ()
_ -> mapM_ (go (n1)) =<< mapM getHVal ids
rootH :: a -> H HValue
rootH a = return (unsafeCoerce# a)
scanNodeH :: (HValue -> H (HNodeId,Closure,[HValue]))
-> (HValue -> H (HNodeId, Bool))
-> (HNodeId -> HNode -> H ())
-> HValue -> H [HNodeId]
scanNodeH getNode getId withNode a = do
(i,clos,ptrs) <- getNode a
xs <- mapM getId ptrs
let news = (fmap fst . fst . partition snd) xs
n = HNode (fmap fst xs)
(closLits clos)
(closITab clos)
withNode i n
return news
nodeH :: HValue -> H [HNodeId]
nodeH = scanNodeH getNodeH' getId' insertG
nodeLazyH :: HValue -> H [HNodeId]
nodeLazyH = scanNodeH getNodeH getId insertG
nodeStreamH :: Q (Maybe (HNodeId, HNode)) -> HValue -> H [HNodeId]
nodeStreamH q = scanNodeH getNodeH' getId'
(\i n -> io (putQ q (Just (i,n))))
getNodeH :: HValue -> H (HNodeId, Closure, [HValue])
getNodeH a = do
clos <- io (getClosure a)
(i, _) <- getId a
let itab = closITab clos
ptrs = closPtrs clos
case itabType itab of
t
| isThunk t -> return (i,clos,[])
| otherwise -> return (i,clos,ptrs)
getNodeH' :: HValue -> H (HNodeId, Closure, [HValue])
getNodeH' a = do
clos <- io (getClosure a)
let itab = closITab clos
ptrs = closPtrs clos
case itabType itab of
t | isThunk t -> getNodeH' =<< io (defined a)
| otherwise -> do
(i, _) <- getId a
return (i,clos,ptrs)
getHVal :: HNodeId -> H HValue
getHVal i = do
Box x <- (IM.! i) `fmap` gets hvals
return x
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 = do
sn <- io (makeStableName hval)
let h = hashStableName sn
s <- gets seen
case lookup sn =<< IM.lookup h s of
Just i -> return (i, False)
Nothing -> do
i <- newId
vs <- gets hvals
modify (\e->e{seen= IM.insertWith (++) h [(sn,i)] s
,hvals= IM.insert i (Box hval) vs})
return (i, True)
getId' :: HValue -> H (HNodeId, Bool)
getId' hval = do
clos <- io (getClosure hval)
let itab = closITab clos
case itabType itab of
t | isThunk t -> getId' =<< io (defined hval)
| otherwise -> getId hval