diff --git a/src/GHC/Vacuum.hs b/src/GHC/Vacuum.hs --- a/src/GHC/Vacuum.hs +++ b/src/GHC/Vacuum.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {- | > ghci> toAdjList $ vacuum (fix (0:)) @@ -36,8 +37,8 @@ HNodeId ,HNode(..) ,emptyHNode - ,vacuum,dump - ,vacuumTo,dumpTo + ,vacuum,vacuumTo,vacuumLazy + ,dump,dumpTo,dumpLazy ,toAdjList ,nameGraph ,ShowHNode(..) @@ -48,13 +49,19 @@ ,Closure(..) ,InfoTab(..) ,getClosure + ,closureType + ,getInfoTab + ,getInfoPtr + ,peekInfoTab ,nodePkg,nodeMod ,nodeName,itabName + ,HValue ) where + import Prelude hiding(catch) import GHC.Vacuum.Dot as Dot import GHC.Vacuum.ClosureType -import GHC.Vacuum.GHC as GHC hiding(Closure) +import GHC.Vacuum.Internal as GHC import Data.Char import Data.Word import Data.List @@ -67,7 +74,9 @@ import System.IO.Unsafe import Control.Monad import Data.Bits +import Text.PrettyPrint(Doc,text) import Language.Haskell.Meta.Utils(pretty) +import Control.Applicative import Control.Exception import Foreign @@ -84,12 +93,23 @@ vacuumTo :: Int -> a -> IntMap HNode vacuumTo n a = unsafePerformIO (dumpTo n a) +-- | Doesn't really work like you'd want it to. +-- Working on this, but there's a slight chance that getting +-- it to work as one would expect isn't possible given the +-- ever-so small hook that GHC gives us (@unpackClosure#@). +-- (Just so that the possibility of impossibility is stated). +vacuumLazy :: a -> IntMap HNode +vacuumLazy a = unsafePerformIO (dumpLazy a) + dump :: a -> IO (IntMap HNode) dump a = execH (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) + ----------------------------------------------------------------------------- toAdjList :: IntMap HNode -> [(Int, [Int])] @@ -241,7 +261,7 @@ getClosure a = grab (getClosure_ a) getClosure getClosure_ :: a -> IO Closure -getClosure_ a = a `seq` +getClosure_ a = case unpackClosure# a of (# iptr ,ptrs @@ -259,32 +279,66 @@ then [] else dumpArray (Array 0 (elems - 1) elems ptrs) lits = [W# (indexWordArray# nptrs i) - | I# i <- [0.. fromIntegral (itabLits itab)] ] - ptrs <- mapM defined ptrs0 - return (Closure ptrs lits itab) + | I# i <- [0.. fromIntegral (itabLits itab-1)] ] + -- ptrs <- mapM defined ptrs0 + return (Closure ptrs0 lits itab) +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 + -- the info pointer we get back from unpackClosure# + -- is to the beginning of the standard info table, + -- but the Storable instance for info tables takes + -- into account the extra entry pointer when + -- !ghciTablesNextToCode, so we must adjust here. + peekInfoTab iptr' + + 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)} + _ | 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.stgItblPtrs) stg + {itabPtrs = (fromIntegral . GHC.ptrs) stg ,itabLits = (fromIntegral . GHC.nptrs) stg ,itabType = ct ,itabSrtLen = fromIntegral (GHC.srtlen stg) ,itabCode = fmap fromIntegral (GHC.code stg)} + +-- Check whether this closure is a datacon and sanity check +-- to make sure we didn't read garbage from memory into this +-- StgInfoTable (because if we did, we'll probably segfault +-- during dataConInfoPtrToNames). +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 -- It seems the ptrs info the ItblEnv + && ptrs < 1024 -- gotten from ByteCodeItbls are borked + -- in some way, *OR* (and more likely) + -- there's some caveat i'm not aware of. + ------------------------------------------------ type H a = S Env a @@ -317,24 +371,32 @@ dumpH :: a -> H () dumpH a = go =<< rootH a where go :: HValue -> H () - go a = a `seq` do + go a = 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 (n-1) =<< rootH a where go :: Int -> HValue -> H () go 0 _ = return () - go n a = a `seq` do + go n a = do ids <- nodeH a case ids of [] -> return () _ -> mapM_ (go (n-1)) =<< mapM getHVal ids +dumpLazyH :: a -> H () +dumpLazyH !a = go =<< rootH a + where go :: HValue -> H () + go a = do + ids <- nodeLazyH a + case ids of + [] -> return () + _ -> mapM_ go =<< mapM getHVal ids + -- | Needed since i don't know of a way -- to go @a -> HValue@ directly (unsafeCoercing -- directly doesn't work (i tried)). @@ -342,12 +404,12 @@ -- | Turn the root into an @HValue@ to start off. rootH :: a -> H HValue -rootH a = let b = Box a - in b `seq` do - c <- io (getClosureData b) - case dumpArray (GHC.ptrs c) of - [hval] -> io (defined hval) - _ -> error "zomg" +rootH a = do + let b = Box a + c <- io (getClosure $! b) + case closPtrs c of + [hval] -> io (defined hval) + _ -> error "zomg" -- | Add this @HValue@ to the graph, then -- add it's successor's not already seen, and @@ -358,27 +420,36 @@ -- unpointed closures cannot be entered, which HValues -- can. nodeH :: HValue -> H [HNodeId] -nodeH a = a `seq` do +nodeH a = do + clos <- io (getClosure $! a) + (i, _) <- getId a + let itab = closITab clos + ptrs = closPtrs clos + ptrs' <- case itabType itab of + t | isCon t -> return (avoid (itabCon itab) ptrs) + | otherwise -> return ptrs + ptrs'' <- io (mapM defined 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 + +nodeLazyH :: HValue -> H [HNodeId] +nodeLazyH a = do clos <- io (getClosure a) (i, _) <- getId a let itab = closITab clos ptrs = closPtrs clos ptrs' <- case itabType itab of - t | isCon t -> -- XXX: hackish casing on conname until unpackClosure# is fixed. - -- Try to cover a few common cases. - case itabCon itab of - "J#" -> return [] -- avoid the ByteArray# - "MVar" -> return [] -- avoid the MVar# - "STRef" -> return [] -- avoid the MutVar# - "Array" -> return (take 2 ptrs) -- avoid the Array# - "MallocPtr" -> return [] -- ForeignPtr - "PlainPtr" -> return [] -- ForeignPtr - "STRef" -> return [] -- avoid the MutVar# - "PS" -> return (drop 1 ptrs) - "Chunk" -> return (drop 1 ptrs) - _ -> return ptrs + t | isCon t -> return (avoid (itabCon itab) ptrs) + -- IMPORTANT: Following either (or both) of + -- the pointer inside a @THUNK@ results in a segfault. + | isThunk t -> return [] | otherwise -> return ptrs - xs <- mapM getId ptrs' + xs <- mapM getIdLazy ptrs' let news = (fmap fst . fst . partition snd) xs n = HNode (fmap fst xs) (closLits clos) @@ -388,6 +459,61 @@ ------------------------------------------------ +-- XXXXXX: USE A TRIE FOR THIS INSTEAD + +-- XXX: hackish casing on conname until unpackClosure# is fixed. +-- Try to cover a few common cases. +avoid :: String -> [HValue] -> [HValue] +avoid con = maybe id id (IM.lookup (hash con) criminals) + +criminals :: IntMap ([HValue] -> [HValue]) +criminals = IM.fromList . fmap (mapfst hash) $ + [("J#", const []) + ,("MVar", const []) + ,("STRef", const []) + ,("Array", take 2) + ,("MallocPtr", const []) + ,("PlainPtr", const []) + ,("PS", drop 1) + ,("Chunk", drop 1) + ,("FileHandle", take 1) + ,("DuplexHandle", take 1) + --,("", id) + ] + +hash :: String -> Int +hash [] = 0 +hash s = go 0 (fmap ord s) + where go !h [] = h + go !h (n:ns) = + let a = (h `shiftL` 4) + b = a + n + c = b .&. 0xf0000000 + !d = case c==0 of + False -> let !e = c `shiftR` 24 + in b `xor` e + True -> b + !e = complement c + !f = d `xor` e + in go f ns + +{- +unsigned long +elfhash(const char *s) +{ + unsigned long h=0, g; + while (*s){ + h = (h << 4) + *s++; + if((g = h & 0xf0000000)) + h ^= g >> 24; + h &= ~g; + } + return h; +} +-} + +------------------------------------------------ + getHVal :: HNodeId -> H HValue getHVal i = (IM.! i) `fmap` gets hvals @@ -414,6 +540,18 @@ ,hvals= IM.insert i hval vs}) return (i, True) +getIdLazy :: HValue -> H (HNodeId, Bool) +getIdLazy hval = do + s <- gets seen + case lookLazy 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 @@ -426,6 +564,15 @@ a .==. b = a `seq` b `seq` (0 /= I# (reallyUnsafePtrEquality# a b)) +lookLazy :: HValue -> [(HValue, a)] -> Maybe a +lookLazy _ [] = Nothing +lookLazy hval ((x,i):xs) + | hval =.= x = Just i + | otherwise = lookLazy hval xs + +(=.=) :: HValue -> HValue -> Bool +a =.= b = (0 /= I# (reallyUnsafePtrEquality# a b)) + dumpArray :: Array Int a -> [a] dumpArray a = let (m,n) = bounds a in fmap (a!) [m..n] @@ -441,6 +588,7 @@ ------------------------------------------------ +{- 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))) @@ -459,10 +607,11 @@ 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)) +-} ------------------------------------------------ -{- RE: the array entering problem: +{- rts/StgMiscClosures.cmm diff --git a/src/GHC/Vacuum/ClosureType.hs b/src/GHC/Vacuum/ClosureType.hs --- a/src/GHC/Vacuum/ClosureType.hs +++ b/src/GHC/Vacuum/ClosureType.hs @@ -1,25 +1,11 @@ module GHC.Vacuum.ClosureType ( - closureType + isFun,isThunk,isCon ,ClosureType(..) - ,isFun,isThunk,isCon ) where -import GHC.Vacuum.GHC as GHC - ------------------------------------------------ --- | Get the @ClosureType@. -closureType :: a -> IO ClosureType -closureType a = a `seq` do - c <- GHC.getClosureData a - let itab = GHC.infoTable c - tag = (fromIntegral . GHC.tipe) itab - ctype = (toEnum . fromIntegral) tag - return ctype - ------------------------------------------------- - isFun :: ClosureType -> Bool isFun FUN = True isFun FUN_1_0 = True @@ -98,6 +84,8 @@ | STOP_FRAME | CAF_BLACKHOLE | BLACKHOLE + | SE_BLACKHOLE + | SE_CAF_BLACKHOLE | MVAR_CLEAN | MVAR_DIRTY | ARR_WORDS @@ -125,83 +113,81 @@ | CATCH_RETRY_FRAME | CATCH_STM_FRAME | WHITEHOLE - | N_CLOSURE_TYPES - deriving (Eq,Ord,Read,Show) - ------------------------------------------------- + deriving(Eq,Ord,Read,Show) instance Enum ClosureType where - fromEnum INVALID_OBJECT = 0 - fromEnum CONSTR = 1 - fromEnum CONSTR_1_0 = 2 - fromEnum CONSTR_0_1 = 3 - fromEnum CONSTR_2_0 = 4 - fromEnum CONSTR_1_1 = 5 - fromEnum CONSTR_0_2 = 6 - fromEnum CONSTR_STATIC = 7 - fromEnum CONSTR_NOCAF_STATIC = 8 - fromEnum FUN = 9 - fromEnum FUN_1_0 = 10 - fromEnum FUN_0_1 = 11 - fromEnum FUN_2_0 = 12 - fromEnum FUN_1_1 = 13 - fromEnum FUN_0_2 = 14 - fromEnum FUN_STATIC = 15 - fromEnum THUNK = 16 - fromEnum THUNK_1_0 = 17 - fromEnum THUNK_0_1 = 18 - fromEnum THUNK_2_0 = 19 - fromEnum THUNK_1_1 = 20 - fromEnum THUNK_0_2 = 21 - fromEnum THUNK_STATIC = 22 - fromEnum THUNK_SELECTOR = 23 - fromEnum BCO = 24 - fromEnum AP = 25 - fromEnum PAP = 26 - fromEnum AP_STACK = 27 - fromEnum IND = 28 - fromEnum IND_OLDGEN = 29 - fromEnum IND_PERM = 30 - fromEnum IND_OLDGEN_PERM = 31 - fromEnum IND_STATIC = 32 - fromEnum RET_BCO = 33 - fromEnum RET_SMALL = 34 - fromEnum RET_BIG = 35 - fromEnum RET_DYN = 36 - fromEnum RET_FUN = 37 - fromEnum UPDATE_FRAME = 38 - fromEnum CATCH_FRAME = 39 - fromEnum STOP_FRAME = 40 - fromEnum CAF_BLACKHOLE = 41 - fromEnum BLACKHOLE = 42 - fromEnum MVAR_CLEAN = 43 - fromEnum MVAR_DIRTY = 44 - fromEnum ARR_WORDS = 45 - fromEnum MUT_ARR_PTRS_CLEAN = 46 - fromEnum MUT_ARR_PTRS_DIRTY = 47 - fromEnum MUT_ARR_PTRS_FROZEN0 = 48 - fromEnum MUT_ARR_PTRS_FROZEN = 49 - fromEnum MUT_VAR_CLEAN = 50 - fromEnum MUT_VAR_DIRTY = 51 - fromEnum WEAK = 52 - fromEnum STABLE_NAME = 53 - fromEnum TSO = 54 - fromEnum BLOCKED_FETCH = 55 - fromEnum FETCH_ME = 56 - fromEnum FETCH_ME_BQ = 57 - fromEnum RBH = 58 - fromEnum REMOTE_REF = 59 - fromEnum TVAR_WATCH_QUEUE = 60 - fromEnum INVARIANT_CHECK_QUEUE = 61 - fromEnum ATOMIC_INVARIANT = 62 - fromEnum TVAR = 63 - fromEnum TREC_CHUNK = 64 - fromEnum TREC_HEADER = 65 - fromEnum ATOMICALLY_FRAME = 66 - fromEnum CATCH_RETRY_FRAME = 67 - fromEnum CATCH_STM_FRAME = 68 - fromEnum WHITEHOLE = 69 - fromEnum N_CLOSURE_TYPES = 70 + fromEnum INVALID_OBJECT = 0 + fromEnum CONSTR = 1 + fromEnum CONSTR_1_0 = 2 + fromEnum CONSTR_0_1 = 3 + fromEnum CONSTR_2_0 = 4 + fromEnum CONSTR_1_1 = 5 + fromEnum CONSTR_0_2 = 6 + fromEnum CONSTR_STATIC = 7 + fromEnum CONSTR_NOCAF_STATIC = 8 + fromEnum FUN = 9 + fromEnum FUN_1_0 = 10 + fromEnum FUN_0_1 = 11 + fromEnum FUN_2_0 = 12 + fromEnum FUN_1_1 = 13 + fromEnum FUN_0_2 = 14 + fromEnum FUN_STATIC = 15 + fromEnum THUNK = 16 + fromEnum THUNK_1_0 = 17 + fromEnum THUNK_0_1 = 18 + fromEnum THUNK_2_0 = 19 + fromEnum THUNK_1_1 = 20 + fromEnum THUNK_0_2 = 21 + fromEnum THUNK_STATIC = 22 + fromEnum THUNK_SELECTOR = 23 + fromEnum BCO = 24 + fromEnum AP = 25 + fromEnum PAP = 26 + fromEnum AP_STACK = 27 + fromEnum IND = 28 + fromEnum IND_OLDGEN = 29 + fromEnum IND_PERM = 30 + fromEnum IND_OLDGEN_PERM = 31 + fromEnum IND_STATIC = 32 + fromEnum RET_BCO = 33 + fromEnum RET_SMALL = 34 + fromEnum RET_BIG = 35 + fromEnum RET_DYN = 36 + fromEnum RET_FUN = 37 + fromEnum UPDATE_FRAME = 38 + fromEnum CATCH_FRAME = 39 + fromEnum STOP_FRAME = 40 + fromEnum CAF_BLACKHOLE = 41 + fromEnum BLACKHOLE = 42 + fromEnum SE_BLACKHOLE = 43 + fromEnum SE_CAF_BLACKHOLE = 44 + fromEnum MVAR_CLEAN = 45 + fromEnum MVAR_DIRTY = 46 + fromEnum ARR_WORDS = 47 + fromEnum MUT_ARR_PTRS_CLEAN = 48 + fromEnum MUT_ARR_PTRS_DIRTY = 49 + fromEnum MUT_ARR_PTRS_FROZEN0 = 50 + fromEnum MUT_ARR_PTRS_FROZEN = 51 + fromEnum MUT_VAR_CLEAN = 52 + fromEnum MUT_VAR_DIRTY = 53 + fromEnum WEAK = 54 + fromEnum STABLE_NAME = 55 + fromEnum TSO = 56 + fromEnum BLOCKED_FETCH = 57 + fromEnum FETCH_ME = 58 + fromEnum FETCH_ME_BQ = 59 + fromEnum RBH = 60 + fromEnum REMOTE_REF = 62 + fromEnum TVAR_WATCH_QUEUE = 63 + fromEnum INVARIANT_CHECK_QUEUE = 64 + fromEnum ATOMIC_INVARIANT = 65 + fromEnum TVAR = 66 + fromEnum TREC_CHUNK = 67 + fromEnum TREC_HEADER = 68 + fromEnum ATOMICALLY_FRAME = 69 + fromEnum CATCH_RETRY_FRAME = 70 + fromEnum CATCH_STM_FRAME = 71 + fromEnum WHITEHOLE = 72 toEnum 0 = INVALID_OBJECT toEnum 1 = CONSTR toEnum 2 = CONSTR_1_0 @@ -245,34 +231,40 @@ toEnum 40 = STOP_FRAME toEnum 41 = CAF_BLACKHOLE toEnum 42 = BLACKHOLE - toEnum 43 = MVAR_CLEAN - toEnum 44 = MVAR_DIRTY - toEnum 45 = ARR_WORDS - toEnum 46 = MUT_ARR_PTRS_CLEAN - toEnum 47 = MUT_ARR_PTRS_DIRTY - toEnum 48 = MUT_ARR_PTRS_FROZEN0 - toEnum 49 = MUT_ARR_PTRS_FROZEN - toEnum 50 = MUT_VAR_CLEAN - toEnum 51 = MUT_VAR_DIRTY - toEnum 52 = WEAK - toEnum 53 = STABLE_NAME - toEnum 54 = TSO - toEnum 55 = BLOCKED_FETCH - toEnum 56 = FETCH_ME - toEnum 57 = FETCH_ME_BQ - toEnum 58 = RBH - toEnum 59 = REMOTE_REF - toEnum 60 = TVAR_WATCH_QUEUE - toEnum 61 = INVARIANT_CHECK_QUEUE - toEnum 62 = ATOMIC_INVARIANT - toEnum 63 = TVAR - toEnum 64 = TREC_CHUNK - toEnum 65 = TREC_HEADER - toEnum 66 = ATOMICALLY_FRAME - toEnum 67 = CATCH_RETRY_FRAME - toEnum 68 = CATCH_STM_FRAME - toEnum 69 = WHITEHOLE - toEnum 70 = N_CLOSURE_TYPES - toEnum _ = error "toEnum: ClosureType: invalid ClosureType" + toEnum 43 = SE_BLACKHOLE + toEnum 44 = SE_CAF_BLACKHOLE + toEnum 45 = MVAR_CLEAN + toEnum 46 = MVAR_DIRTY + toEnum 47 = ARR_WORDS + toEnum 48 = MUT_ARR_PTRS_CLEAN + toEnum 49 = MUT_ARR_PTRS_DIRTY + toEnum 50 = MUT_ARR_PTRS_FROZEN0 + toEnum 51 = MUT_ARR_PTRS_FROZEN + toEnum 52 = MUT_VAR_CLEAN + toEnum 53 = MUT_VAR_DIRTY + toEnum 54 = WEAK + toEnum 55 = STABLE_NAME + toEnum 56 = TSO + toEnum 57 = BLOCKED_FETCH + toEnum 58 = FETCH_ME + toEnum 59 = FETCH_ME_BQ + toEnum 60 = RBH + toEnum 62 = REMOTE_REF + toEnum 63 = TVAR_WATCH_QUEUE + toEnum 64 = INVARIANT_CHECK_QUEUE + toEnum 65 = ATOMIC_INVARIANT + toEnum 66 = TVAR + toEnum 67 = TREC_CHUNK + toEnum 68 = TREC_HEADER + toEnum 69 = ATOMICALLY_FRAME + toEnum 70 = CATCH_RETRY_FRAME + toEnum 71 = CATCH_STM_FRAME + toEnum 72 = WHITEHOLE + toEnum n = error ("toEnum: ClosureType: invalid ClosureType: " ++ show n) ------------------------------------------------- + + + + + + diff --git a/src/GHC/Vacuum/Dot.hs b/src/GHC/Vacuum/Dot.hs --- a/src/GHC/Vacuum/Dot.hs +++ b/src/GHC/Vacuum/Dot.hs @@ -2,7 +2,7 @@ module GHC.Vacuum.Dot ( graphToDot ,ppGraph,ppEdge,gStyle - ,Doc,text,render +-- ,Doc,text,render ) where import Text.PrettyPrint @@ -18,16 +18,16 @@ gStyle :: String gStyle = unlines - ["graph [rankdir=LR, splines=true];" - ,"node [label=\"\\N\", shape=none, fontcolor=blue, fontname=courier];" - ,"edge [color=black, style=dotted, fontname=courier, arrowname=onormal];"] + [" graph [rankdir=LR, splines=true];" + ," node [label=\"\\N\", shape=none, fontcolor=blue, fontname=courier];" + ," edge [color=black, style=dotted, fontname=courier, arrowname=onormal];"] ppGraph :: [(String, [String])] -> Doc ppGraph xs = (text "digraph g" <+> text "{") $+$ text gStyle $+$ nest indent (vcat . fmap ppEdge $ xs) $+$ text "}" - where indent = 4 + where indent = 2 ppEdge :: (String, [String]) -> Doc ppEdge (x,xs) = (dQText x) <+> (text "->") diff --git a/src/GHC/Vacuum/GHC.hs b/src/GHC/Vacuum/GHC.hs deleted file mode 100644 --- a/src/GHC/Vacuum/GHC.hs +++ /dev/null @@ -1,8 +0,0 @@ - -module GHC.Vacuum.GHC ( - module Internal - ,module Imports -) where - -import GHC.Vacuum.GHC.Imports as Imports -import GHC.Vacuum.GHC.Internal as Internal diff --git a/src/GHC/Vacuum/GHC/Imports.hs b/src/GHC/Vacuum/GHC/Imports.hs deleted file mode 100644 --- a/src/GHC/Vacuum/GHC/Imports.hs +++ /dev/null @@ -1,97 +0,0 @@ - --- | Want this module to be as isolated as possible, --- due to the extreme volatility of the GHC-API. - -module GHC.Vacuum.GHC.Imports ( - module Constants - ,module GHC.Ptr - ,module GHC.Prim - ,module GHC.Exts - ,module ByteCodeLink - ,module BCI - ,module Rt -- RtClosureInspect - ,module CgInfoTbls - ,module SMRep --- ,module GHC - ,module HscMain - ,module HscTypes - ,module DynFlags - ,module StaticFlags - ,module SysTools - ,module Packages --- ,module PackageConfig --- ,module Distribution.Package - ,module Name - ,module Module - ,module IfaceEnv --- ,module TcRnMonad - ,module Outputable - ,module FastString --- ,module Util - ,module Bag - ,ghciTablesNextToCode - ,setContext - ,stgItblPtrs -) where - - - - ------------------------------------------------- - -import Constants - -import GHC.Ptr(Ptr(..)) -import GHC.Prim -import GHC.Exts(Int(..)) - -import ByteCodeLink -import ByteCodeItbls as BCI hiding (ptrs) -import qualified ByteCodeItbls as BCI --- import RtClosureInspect hiding (ClosureType) -import RtClosureInspect as Rt hiding (tipe,ClosureType(..),isFun) -import CgInfoTbls hiding (infoTable) -import SMRep hiding (ClosureType(..)) - -import GHC (setContext) --- import GHC hiding (lookupName,compileExpr,LIE) -import HscMain -import HscTypes -import DynFlags -import StaticFlags -import SysTools (initSysTools) - -import Packages --- import PackageConfig -import Distribution.Package (PackageName(..)) - -import Name -import Module - -import IfaceEnv --- import TcRnMonad hiding (Env) - -import Outputable(ppr,showSDoc) -import qualified Outputable as O - -import FastString - hiding (uniq) -import Util (ghciTablesNextToCode) -import Bag - (unitBag - ,listToBag - ,emptyBag - ,isEmptyBag) - ------------------------------------------------- - -stgItblPtrs = BCI.ptrs - - - - ------------------------------------------------- - - - - diff --git a/src/GHC/Vacuum/GHC/Internal.hs b/src/GHC/Vacuum/GHC/Internal.hs deleted file mode 100644 --- a/src/GHC/Vacuum/GHC/Internal.hs +++ /dev/null @@ -1,335 +0,0 @@ - --- | Want this module to be as isolated as possible, --- due to the extreme volatility of the GHC-API. - -module GHC.Vacuum.GHC.Internal ( - GhcApiCfg(..) - ,defaultGhcApiConfig - ,withGhcApiCfg - ,dynFlagsOn,dynFlagsOff - ,defaultEnv,newEnv,myRunGhc - ,CabalPkg(..) - ,CabalPkgId - ,CabalPkgVersion - ,CabalModuleId - ,CabalModule(..) - ,cabalModulePkgId - ,cabalModulePkgVersion - ,cabalModuleModuleId - ,preludeCM - ,collectCabalModules - ,cabalPkgToModules - ,dataConInfoPtrToNames -) where - -import GHC.Paths(libdir) -import GHC.Vacuum.GHC.Imports as Imports -import Distribution.Package(PackageName(..)) - -import Data.Char -import Data.Word -import Data.List -import Data.IORef -import Data.Array.IArray -import Control.Monad -import Foreign - -import Data.List -import Data.Map(Map) -import Data.Set(Set) -import qualified Data.Set as S -import qualified Data.Map as M -import Data.Monoid(Monoid(..)) - ------------------------------------------------- - - - ------------------------------------------------- - -data GhcApiCfg = GhcApiCfg - {ghcApiLibDir :: FilePath - ,ghcApiImports :: [CabalPkg] - ,ghcApiDynFlagsOn :: [DynFlag] - ,ghcApiDynFlagsOff :: [DynFlag]} - deriving(Eq,Ord,Read,Show) - -deriving instance Ord DynFlag -deriving instance Read DynFlag - -defaultGhcApiConfig :: GhcApiCfg -defaultGhcApiConfig = GhcApiCfg - {ghcApiLibDir = GHC.Paths.libdir - ,ghcApiImports - -- e.g. - = CabalPkg "base" [] ["Prelude"] - : collectCabalModules - [CabalModule "base" [] "Prelude" - ,CabalModule "base" [] "Prelude"] - ,ghcApiDynFlagsOn - = [Opt_TemplateHaskell - ,Opt_QuasiQuotes - ,Opt_ViewPatterns - ,Opt_RankNTypes - ,Opt_KindSignatures - ,Opt_UnicodeSyntax - -- um, i assume this turns it _off_ (?) - ,Opt_MonomorphismRestriction - ,Opt_PatternGuards - ,Opt_ParallelListComp - ,Opt_ImplicitParams - ,Opt_BangPatterns] - ,ghcApiDynFlagsOff - = [Opt_PrintBindResult - ,Opt_PrintBindContents - ,Opt_PrintEvldWithShow]} - -withGhcApiCfg :: GhcApiCfg - -> (FilePath -> DynFlags -> [Module] -> o) - -> (DynFlags -> o) -withGhcApiCfg (GhcApiCfg - libdir - imports - ons offs) k dflags = k libdir - ((dynFlagsOn ons - . dynFlagsOff offs) dflags) - (concatMap cabalPkgToModules imports) - -dynFlagsOn :: [DynFlag] -> (DynFlags -> DynFlags) -dynFlagsOn = flip (foldl dopt_set) - -dynFlagsOff :: [DynFlag] -> (DynFlags -> DynFlags) -dynFlagsOff = flip (foldl dopt_unset) - ------------------------------------------------- - - - ------------------------------------------------- - -defaultEnv :: IO HscEnv -defaultEnv = newEnv defaultGhcApiConfig - (Just defaultDynFlags) - -newEnv :: GhcApiCfg -> Maybe DynFlags -> IO HscEnv -newEnv cfg dflagsM - = let - initEnv :: HscEnv -> [Module] -> IO HscEnv - initEnv hsc modules = do - let dflags = hsc_dflags hsc - (dflags', preload) <- initPackages - (dflags{ghcLink=LinkInMemory}) - let hsc' = hsc{hsc_dflags = dflags'} - myRunGhc hsc' (setContext [] modules) - return hsc' - - newEnv' :: Maybe FilePath -> DynFlags -> IO HscEnv - newEnv' mb_top_dir dflags00 = do - initStaticOpts - dflags0 <- initDynFlags dflags00 - dflags <- initSysTools mb_top_dir dflags0 - hsc <- newHscEnv dflags - return hsc - - in withGhcApiCfg cfg (\libdir dflags modules -> - do env <- newEnv' (Just libdir) dflags - env' <- initEnv env modules - return env') - (maybe defaultDynFlags id dflagsM) - -myRunGhc :: HscEnv -> Ghc a -> IO a -myRunGhc hsc_env ghc = do - wref <- newIORef emptyBag - ref <- newIORef hsc_env - unGhc ghc (Session ref wref) - ------------------------------------------------- - - - ------------------------------------------------- - -data CabalPkg = CabalPkg - {cabalPkgPkg :: CabalPkgId - ,cabalPkgVersion :: CabalPkgVersion - ,cabalPkgModules :: [CabalModuleId]} - deriving(Eq,Ord,Read,Show) - -type CabalPkgId = String -type CabalPkgVersion = [Int] -type CabalModuleId = String - -data CabalModule = CabalModule - CabalPkgId - CabalPkgVersion - CabalModuleId - deriving(Eq,Ord,Read,Show) - -cabalModulePkgId :: CabalModule -> CabalPkgId -cabalModulePkgVersion :: CabalModule -> CabalPkgVersion -cabalModuleModuleId :: CabalModule -> CabalModuleId - -cabalModulePkgId (CabalModule x _ _) = x -cabalModulePkgVersion (CabalModule _ x _) = x -cabalModuleModuleId (CabalModule _ _ x) = x - -preludeCM :: CabalModule -preludeCM = CabalModule "base" [] "Prelude" - -collectCabalModules :: [CabalModule] -> [CabalPkg] -collectCabalModules - = let f &&& g = \x -> (f x, g x) - keyify = cabalModulePkgId - &&& cabalModulePkgVersion - elemify = S.singleton . cabalModuleModuleId - toPkg ((pid,v),ms) = CabalPkg pid v (S.toList ms) - collect (<>) f g = M.toList . flip foldl' mempty - (\m a -> M.insertWith' (<>) (f a) - (g a) m) - in fmap toPkg . collect S.union keyify elemify - -cabalPkgToModules :: CabalPkg -> [Module] -cabalPkgToModules (CabalPkg - pid - ver - mods) = fmap (mkModule - (mkPackageId - (PackageIdentifier - (PackageName pid) - (Version ver []))) - . mkModuleName) mods - ------------------------------------------------- - - - ------------------------------------------------- - --- * This section is taken from Linker.lhs - --- % --- % (c) The University of Glasgow 2005-2006 --- % - --- | Given a data constructor in the heap, find its Name. --- The info tables for data constructors have a field which records --- the source name of the constructor as a Ptr Word8 (UTF-8 encoded --- string). The format is: --- --- Package:Module.Name --- --- We use this string to lookup the interpreter's internal representation of the name --- using the lookupOrig. - -dataConInfoPtrToNames :: Ptr () -> IO (String, String, String) -- (Either String Name) -- TcM (Either String Name) -dataConInfoPtrToNames x = do - readIORef justToInitGhc - initStaticOpts - theString <- do -- liftIO $ do - let ptr = castPtr x :: Ptr StgInfoTable - conDescAddress <- getConDescAddress ptr - peekArray0 0 conDescAddress - let (pkg, mod, occ) = parse theString - pkgFS = mkFastStringByteList pkg - modFS = mkFastStringByteList mod - occFS = mkFastStringByteList occ - occName = mkOccNameFS dataName occFS - modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) - return ((packageIdString . modulePackageId) modName - ,(moduleNameString . moduleName) modName - ,occNameString occName) --- return (showSDoc $ ppr modName O.<> O.dot O.<> ppr occName) - -- return (Left$ showSDoc$ ppr modName O.<> O.dot O.<> ppr occName) - -- `recoverM` (Right `fmap` lookupOrig modName occName) - - --- | This is needed to make sure that GHC is all initialized with its --- plethora of well-hidden and ill-documented global vars. I'm not --- bothering to NOINLINE it because i like to live dangerously. --- (clearly i'm beligerent at this point). -justToInitGhc :: IORef HscEnv -justToInitGhc = unsafePerformIO (newIORef =<< defaultEnv) - - - {- To find the string in the constructor's info table we need to consider - the layout of info tables relative to the entry code for a closure. - - An info table can be next to the entry code for the closure, or it can - be separate. The former (faster) is used in registerised versions of ghc, - and the latter (portable) is for non-registerised versions. - - The diagrams below show where the string is to be found relative to - the normal info table of the closure. - - 1) Code next to table: - - -------------- - | | <- pointer to the start of the string - -------------- - | | <- the (start of the) info table structure - | | - | | - -------------- - | entry code | - | .... | - - In this case the pointer to the start of the string can be found in - the memory location _one word before_ the first entry in the normal info - table. - - 2) Code NOT next to table: - - -------------- - info table structure -> | *------------------> -------------- - | | | entry code | - | | | .... | - -------------- - ptr to start of str -> | | - -------------- - - In this case the pointer to the start of the string can be found - in the memory location: info_table_ptr + info_table_size - -} - -getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) -getConDescAddress ptr - | ghciTablesNextToCode = do - offsetToString <- peek (ptr `plusPtr` (negate wORD_SIZE)) - return $ (ptr `plusPtr` stdInfoTableSizeB) - `plusPtr` (fromIntegral (offsetToString :: StgWord)) - | otherwise = peek . intPtrToPtr - . (+ fromIntegral - stdInfoTableSizeB) - . ptrToIntPtr $ ptr - -- parsing names is a little bit fiddly because we have a string in the form: - -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). - -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. - -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas - -- this is not the conventional way of writing Haskell names. We stick with - -- convention, even though it makes the parsing code more troublesome. - -- Warning: this code assumes that the string is well formed. XXXXXXXXXXXXXXXXXXX -parse :: [Word8] -> ([Word8], [Word8], [Word8]) -parse input = if not . all (>0) . fmap length $ [pkg,mod,occ] - then (error . concat) - ["getConDescAddress:parse:" - ,"(not . all (>0) . fmap le" - ,"ngth $ [pkg,mod,occ]"] - else (pkg, mod, occ) --- = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) -- XXXXXXXXXXXXXXXX - where - (pkg, rest1) = break (== fromIntegral (ord ':')) input - (mod, occ) - = (concat $ intersperse [dot] $ reverse modWords, occWord) - where - (modWords, occWord) = if (length rest1 < 1) -- XXXXXXXXx YUKX - then error "getConDescAddress:parse:length rest1 < 1" - else parseModOcc [] (tail rest1) - -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) - dot = fromIntegral (ord '.') - parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) - parseModOcc acc str - = case break (== dot) str of - (top, []) -> (acc, top) - (top, _:bot) -> parseModOcc (top : acc) bot - ------------------------------------------------- diff --git a/src/GHC/Vacuum/Internal.hs b/src/GHC/Vacuum/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vacuum/Internal.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE CPP #-} + +module GHC.Vacuum.Internal ( + HValue + ,HalfWord + ,ItblCode + ,StgInfoTable(..) + ,ghciTablesNextToCode + ,dataConInfoPtrToNames + ,wORD_SIZE + ,hALF_WORD_SIZE + ,S(..),get,gets,set,io,modify,runS +) where + +import Data.Char +import Data.Word +import Data.List +import Data.IORef +import Data.Array.IArray +import Control.Monad +import Control.Monad.Fix +import Foreign + +import Data.List +import Data.Map(Map) +import Data.Set(Set) +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Monoid(Monoid(..)) + +import GHC.Prim +import GHC.Exts + +#include "ghcplatform.h" +#include "ghcautoconf.h" +#define GHCI_TABLES_NEXT_TO_CODE + -- is there somewhere to get this define? + +----------------------------------------------------------------------------- + +-- * Fabricate what we need to avoid the ghc pkg dep + +type HValue = Any + +#if SIZEOF_VOID_P == 8 +type HalfWord = Word32 +#else +type HalfWord = Word16 +#endif + +-- | From SMRep +type ByteOff = Int + +-- | From SMRep +type WordOff = Int + +-- | From SMRep +type StgWord = Word + +-- hmmmmmm. Is there any way to tell this? +opt_SccProfilingOn = False + +-- ghci> wORD_SIZE +-- 8 +-- ghci> sizeOf (undefined :: Word) +-- 8 +wORD_SIZE :: Int +wORD_SIZE = sizeOf (undefined :: Word) + +hALF_WORD_SIZE :: Int +hALF_WORD_SIZE = wORD_SIZE `div` 2 + +-- | This is currently always True since +-- i'm not sure how to get at the CPP define +-- \"GHCI_TABLES_NEXT_TO_CODE\" (or equiv) to tell. +ghciTablesNextToCode :: Bool +#ifdef GHCI_TABLES_NEXT_TO_CODE +ghciTablesNextToCode = True +#else +ghciTablesNextToCode = False +#endif + +----------------------------------------------------------------------------- + +data StgInfoTable = StgInfoTable { +#ifndef GHCI_TABLES_NEXT_TO_CODE + entry :: Ptr (), +#endif + ptrs :: HalfWord, + nptrs :: HalfWord, + tipe :: HalfWord, + srtlen :: HalfWord +#ifdef GHCI_TABLES_NEXT_TO_CODE + , code :: [ItblCode] +#endif + } + +instance Storable StgInfoTable where + + sizeOf itbl + = sum + [ +#ifndef GHCI_TABLES_NEXT_TO_CODE + fieldSz entry itbl, +#endif + fieldSz ptrs itbl, + fieldSz nptrs itbl, + fieldSz tipe itbl, + fieldSz srtlen itbl +#ifdef GHCI_TABLES_NEXT_TO_CODE + ,fieldSz (head.code) itbl * itblCodeLength +#endif + ] + + alignment itbl + = SIZEOF_VOID_P + + poke a0 itbl + = flip evalS (castPtr a0) + $ do +#ifndef GHCI_TABLES_NEXT_TO_CODE + store (entry itbl) +#endif + store (ptrs itbl) + store (nptrs itbl) + store (tipe itbl) + store (srtlen itbl) +#ifdef GHCI_TABLES_NEXT_TO_CODE + sequence_ (map store (code itbl)) +#endif + + peek a0 + = flip evalS (castPtr a0) + $ do +#ifndef GHCI_TABLES_NEXT_TO_CODE + entry <- load +#endif + ptrs <- load + nptrs <- load + tipe <- load + srtlen <- load +#ifdef GHCI_TABLES_NEXT_TO_CODE + code <- sequence (replicate itblCodeLength load) +#endif + return + StgInfoTable { +#ifndef GHCI_TABLES_NEXT_TO_CODE + entry = entry, +#endif + ptrs = ptrs, + nptrs = nptrs, + tipe = tipe, + srtlen = srtlen +#ifdef GHCI_TABLES_NEXT_TO_CODE + ,code = code +#endif + } + +fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int +fieldSz sel x = sizeOf (sel x) + +type PtrIO = S (Ptr Word8) + +advance :: Storable a => PtrIO (Ptr a) +advance = S adv where + adv k addr = case castPtr addr of + addrCast -> k addrCast + (addr `plusPtr` + sizeOfPointee addrCast) + +sizeOfPointee :: (Storable a) => Ptr a -> Int +sizeOfPointee addr = sizeOf (typeHack addr) + where typeHack = undefined :: Ptr a -> a + +store :: Storable a => a -> PtrIO () +store x = do addr <- advance + io (poke addr x) + +load :: Storable a => PtrIO a +load = do addr <- advance + io (peek addr) + +newtype S s a = S {unS :: forall o. (a -> s -> IO o) -> s -> IO o} +instance Functor (S s) where + fmap f (S g) = S (\k -> g (k . f)) +instance Monad (S s) where + return a = S (\k -> k a) + S g >>= f = S (\k -> g (\a -> unS (f a) k)) +instance MonadFix (S s) where + mfix f = S (\k s -> + uncurry k =<< mfix (\ ~(a,_) -> + -- the lazy pattern is ESSENTIAL, otherwise <> + unS (f a) (\a s -> return (a,s)) s)) +get :: S s s +get = S (\k s -> k s s) +gets :: (s -> a) -> S s a +gets f = S (\k s -> k (f s) s) +set :: s -> S s () +set s = S (\k _ -> k () s) +io :: IO a -> S s a +io m = S (\k s -> flip k s =<< m) +modify :: (s -> s) -> S s () +modify f = S (\k -> k () . f) +runS :: S s a -> s -> IO (a, s) +runS (S g) = g (\a -> return . (,) a) +evalS :: S s a -> s -> IO a +evalS (S g) = g (\a _ -> return a) +execS :: S s a -> s -> IO s +execS (S g) = g (\_ -> return) + +----------------------------------------------------------------------------- + +-- VACUUM: All this just to get itblCodeLength. + +-- Make code which causes a jump to the given address. This is the +-- only arch-dependent bit of the itbl story. The returned list is +-- itblCodeLength elements (bytes) long. + +-- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc. +-- #include "nativeGen/NCG.h" +-- VACUUM: we get *_TARGET_ARCH from ghcplatform.h instead + +itblCodeLength :: Int +itblCodeLength = length (mkJumpToAddr undefined) + +mkJumpToAddr :: Ptr () -> [ItblCode] + +ptrToInt (Ptr a#) = I# (addr2Int# a#) + +#if sparc_TARGET_ARCH +-- After some consideration, we'll try this, where +-- 0x55555555 stands in for the address to jump to. +-- According to ghc/includes/MachRegs.h, %g3 is very +-- likely indeed to be baggable. +-- +-- 0000 07155555 sethi %hi(0x55555555), %g3 +-- 0004 8610E155 or %g3, %lo(0x55555555), %g3 +-- 0008 81C0C000 jmp %g3 +-- 000c 01000000 nop + +type ItblCode = Word32 +mkJumpToAddr a + = let w32 = fromIntegral (ptrToInt a) + + hi22, lo10 :: Word32 -> Word32 + lo10 x = x .&. 0x3FF + hi22 x = (x `shiftR` 10) .&. 0x3FFFF + + in [ 0x07000000 .|. (hi22 w32), + 0x8610E000 .|. (lo10 w32), + 0x81C0C000, + 0x01000000 ] + +#elif powerpc_TARGET_ARCH +-- We'll use r12, for no particular reason. +-- 0xDEADBEEF stands for the adress: +-- 3D80DEAD lis r12,0xDEAD +-- 618CBEEF ori r12,r12,0xBEEF +-- 7D8903A6 mtctr r12 +-- 4E800420 bctr + +type ItblCode = Word32 +mkJumpToAddr a = + let w32 = fromIntegral (ptrToInt a) + hi16 x = (x `shiftR` 16) .&. 0xFFFF + lo16 x = x .&. 0xFFFF + in [ + 0x3D800000 .|. hi16 w32, + 0x618C0000 .|. lo16 w32, + 0x7D8903A6, 0x4E800420 + ] + +#elif i386_TARGET_ARCH +-- Let the address to jump to be 0xWWXXYYZZ. +-- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax +-- which is +-- B8 ZZ YY XX WW FF E0 + +type ItblCode = Word8 +mkJumpToAddr a + = let w32 = fromIntegral (ptrToInt a) :: Word32 + insnBytes :: [Word8] + insnBytes + = [0xB8, byte0 w32, byte1 w32, + byte2 w32, byte3 w32, + 0xFF, 0xE0] + in + insnBytes + +#elif x86_64_TARGET_ARCH +-- Generates: +-- jmpq *.L1(%rip) +-- .align 8 +-- .L1: +-- .quad +-- +-- We need a full 64-bit pointer (we can't assume the info table is +-- allocated in low memory). Assuming the info pointer is aligned to +-- an 8-byte boundary, the addr will also be aligned. + +type ItblCode = Word8 +mkJumpToAddr a + = let w64 = fromIntegral (ptrToInt a) :: Word64 + insnBytes :: [Word8] + insnBytes + = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, + byte0 w64, byte1 w64, byte2 w64, byte3 w64, + byte4 w64, byte5 w64, byte6 w64, byte7 w64] + in + insnBytes + +#elif alpha_TARGET_ARCH +type ItblCode = Word32 +mkJumpToAddr a + = [ 0xc3800000 -- br at, .+4 + , 0xa79c000c -- ldq at, 12(at) + , 0x6bfc0000 -- jmp (at) # with zero hint -- oh well + , 0x47ff041f -- nop + , fromIntegral (w64 .&. 0x0000FFFF) + , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ] + where w64 = fromIntegral (ptrToInt a) :: Word64 + +#else +type ItblCode = Word32 +mkJumpToAddr a + = undefined +#endif + +byte0, byte1, byte2, byte3, byte4, byte5, byte6, byte7 + :: (Integral w, Bits w) => w -> Word8 +byte0 w = fromIntegral w +byte1 w = fromIntegral (w `shiftR` 8) +byte2 w = fromIntegral (w `shiftR` 16) +byte3 w = fromIntegral (w `shiftR` 24) +byte4 w = fromIntegral (w `shiftR` 32) +byte5 w = fromIntegral (w `shiftR` 40) +byte6 w = fromIntegral (w `shiftR` 48) +byte7 w = fromIntegral (w `shiftR` 56) + +----------------------------------------------------------------------------- +-- +-- Info table offsets +-- +----------------------------------------------------------------------------- + +stdInfoTableSizeW :: WordOff +-- The size of a standard info table varies with profiling/ticky etc, +-- so we can't get it from Constants +-- It must vary in sync with mkStdInfoTable +stdInfoTableSizeW + = size_fixed + size_prof + where + size_fixed = 2 -- layout, type + size_prof | opt_SccProfilingOn = 2 + | otherwise = 0 + +stdInfoTableSizeB :: ByteOff +stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE + +stdSrtBitmapOffset :: ByteOff +-- Byte offset of the SRT bitmap half-word which is +-- in the *higher-addressed* part of the type_lit +stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE + +stdClosureTypeOffset :: ByteOff +-- Byte offset of the closure type half-word +stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE + +stdPtrsOffset, stdNonPtrsOffset :: ByteOff +stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE +stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE + +------------------------------------------------ + +-- * This section is taken from Linker.lhs + +-- % +-- % (c) The University of Glasgow 2005-2006 +-- % + +-- | Given a data constructor in the heap, find its Name. +-- The info tables for data constructors have a field which records +-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded +-- string). The format is: +-- +-- Package:Module.Name +-- +-- We use this string to lookup the interpreter's internal representation of the name +-- using the lookupOrig. + +b2s :: [Word8] -> String +b2s = fmap (chr . fromIntegral) + +dataConInfoPtrToNames :: Ptr () -> IO (String, String, String) +dataConInfoPtrToNames x = do + let ptr = castPtr x :: Ptr StgInfoTable + conDescAddress <- getConDescAddress ptr + theString <- peekArray0 0 conDescAddress + let (pkg, mod, occ) = parse theString + return (b2s pkg, b2s mod, b2s occ) + +{- To find the string in the constructor's info table we need to consider + the layout of info tables relative to the entry code for a closure. + + An info table can be next to the entry code for the closure, or it can + be separate. The former (faster) is used in registerised versions of ghc, + and the latter (portable) is for non-registerised versions. + + The diagrams below show where the string is to be found relative to + the normal info table of the closure. + + 1) Code next to table: + + -------------- + | | <- pointer to the start of the string + -------------- + | | <- the (start of the) info table structure + | | + | | + -------------- + | entry code | + | .... | + + In this case the pointer to the start of the string can be found in + the memory location _one word before_ the first entry in the normal info + table. + + 2) Code NOT next to table: + + -------------- + info table structure -> | *------------------> -------------- + | | | entry code | + | | | .... | + -------------- + ptr to start of str -> | | + -------------- + + In this case the pointer to the start of the string can be found + in the memory location: info_table_ptr + info_table_size +-} + +getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) +getConDescAddress ptr + | ghciTablesNextToCode = do + offsetToString <- peek (ptr `plusPtr` (negate wORD_SIZE)) + return $ (ptr `plusPtr` stdInfoTableSizeB) + `plusPtr` (fromIntegral (offsetToString :: StgWord)) + | otherwise = peek . intPtrToPtr + . (+ fromIntegral + stdInfoTableSizeB) + . ptrToIntPtr $ ptr + -- parsing names is a little bit fiddly because we have a string in the form: + -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo"). + -- Thus we split at the leftmost colon and the rightmost occurrence of the dot. + -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas + -- this is not the conventional way of writing Haskell names. We stick with + -- convention, even though it makes the parsing code more troublesome. + -- Warning: this code assumes that the string is well formed. XXXXXXXXXXXXXXXXXXX +parse :: [Word8] -> ([Word8], [Word8], [Word8]) +parse input = if not . all (>0) . fmap length $ [pkg,mod,occ] + then (error . concat) + ["getConDescAddress:parse:" + ,"(not . all (>0) . fmap le" + ,"ngth $ [pkg,mod,occ]"] + else (pkg, mod, occ) +-- = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) -- XXXXXXXXXXXXXXXX + where + (pkg, rest1) = break (== fromIntegral (ord ':')) input + (mod, occ) + = (concat $ intersperse [dot] $ reverse modWords, occWord) + where + (modWords, occWord) = if (length rest1 < 1) -- XXXXXXXXx YUKX + then error "getConDescAddress:parse:length rest1 < 1" + else parseModOcc [] (tail rest1) + -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) + dot = fromIntegral (ord '.') + parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) + parseModOcc acc str + = case break (== dot) str of + (top, []) -> (acc, top) + (top, _:bot) -> parseModOcc (top : acc) bot + +------------------------------------------------ diff --git a/vacuum.cabal b/vacuum.cabal --- a/vacuum.cabal +++ b/vacuum.cabal @@ -1,40 +1,26 @@ name: vacuum -version: 0.0.93 +version: 0.0.94 cabal-version: >= 1.6 build-type: Simple license: LGPL license-file: LICENSE -category: Interpreter, GHC +category: Debug, GHC author: Matt Morrow -copyright: (c) Matt Morrow 2008 +copyright: (c) Matt Morrow 2009 maintainer: Matt Morrow homepage: http://moonpatio.com/vacuum/ stability: experimental synopsis: Extract graph representations of ghc heap values. -description: . - -flag ghc-six-ten-one - description: ghc-6.10.1 - default: True +description: library hs-source-dirs: src - ghc-options: -O2 -fglasgow-exts - extensions: + ghc-options: -O2 -fglasgow-exts -funbox-strict-fields + extensions: CPP, BangPatterns + includes: ghcautoconf.h exposed-modules: GHC.Vacuum, - GHC.Vacuum.ClosureType, GHC.Vacuum.Dot, - GHC.Vacuum.GHC.Internal - other-modules: GHC.Vacuum.GHC, - GHC.Vacuum.GHC.Imports - - if flag(ghc-six-ten-one) - build-depends: base==4.*, ghc-prim, ghc-paths, - ghc == 6.10.1, Cabal == 1.6.0.1, - array, containers, array, - pretty, haskell-src-meta - else - build-depends: base==4.*, ghc-prim, ghc-paths, - ghc == 6.10.2, Cabal == 1.6.0.3, - array, containers, array, - pretty, haskell-src-meta + GHC.Vacuum.ClosureType, + GHC.Vacuum.Internal + build-depends: base==4.*, ghc-prim, array, + containers, pretty, haskell-src-meta