Browse files

Release 0.0.94

  • Loading branch information...
1 parent 026fd3d commit fc1e41d68c8d411a6ced00cd10f8bc003becec10 @kfish committed Oct 17, 2011
View
235 src/GHC/Vacuum.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{- |
> ghci> toAdjList $ vacuum (fix (0:))
@@ -36,8 +37,8 @@ module GHC.Vacuum (
HNodeId
,HNode(..)
,emptyHNode
- ,vacuum,dump
- ,vacuumTo,dumpTo
+ ,vacuum,vacuumTo,vacuumLazy
+ ,dump,dumpTo,dumpLazy
,toAdjList
,nameGraph
,ShowHNode(..)
@@ -48,13 +49,19 @@ module GHC.Vacuum (
,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 Data.Array.IArray
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 @@ vacuum a = unsafePerformIO (dump a)
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 -> IO Closure
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 @@ getClosure_ a = a `seq`
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,37 +371,45 @@ emptyEnv = Env
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)).
data Box a = Box a
-- | 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 @@ rootH a = let b = Box a
-- 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 @@ nodeH a = a `seq` do
------------------------------------------------
+-- 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 @@ getId hval = hval `seq` do
,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 @@ look hval ((x,i):xs)
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 @@ 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)))
@@ -459,10 +607,11 @@ 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))
+-}
------------------------------------------------
-{- RE: the array entering problem:
+{-
rts/StgMiscClosures.cmm
View
232 src/GHC/Vacuum/ClosureType.hs
@@ -1,23 +1,9 @@
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
@@ -98,6 +84,8 @@ data ClosureType
| STOP_FRAME
| CAF_BLACKHOLE
| BLACKHOLE
+ | SE_BLACKHOLE
+ | SE_CAF_BLACKHOLE
| MVAR_CLEAN
| MVAR_DIRTY
| ARR_WORDS
@@ -125,83 +113,81 @@ data ClosureType
| 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 @@ instance Enum ClosureType where
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)
+
+
+
+
+
+
-------------------------------------------------
View
10 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 @@ graphToDot f = ppGraph . fmap (f *** fmap f)
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 "->")
View
8 src/GHC/Vacuum/GHC.hs
@@ -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
View
97 src/GHC/Vacuum/GHC/Imports.hs
@@ -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
-
-
-
-
-------------------------------------------------
-
-
-
-
View
335 src/GHC/Vacuum/GHC/Internal.hs
@@ -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
-
-------------------------------------------------
View
483 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 <<loop>>
+ 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 <addr>
+--
+-- 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
+
+------------------------------------------------
View
36 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 <morrow@moonpatio.com>
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: <http://moonpatio.com/vacuum/>
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

0 comments on commit fc1e41d

Please sign in to comment.