vacuum 0.0.93 → 0.0.94

raw patch · 8 files changed

+803/−633 lines, 8 filesdep −Cabaldep −ghcdep −ghc-pathsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: Cabal, ghc, ghc-paths

API changes (from Hackage documentation)

Files

• src/GHC/Vacuum.hs +192/−43
• src/GHC/Vacuum/ClosureType.hs +112/−120
• src/GHC/Vacuum/Dot.hs +5/−5
• src/GHC/Vacuum/GHC.hs +0/−8
• src/GHC/Vacuum/GHC/Imports.hs +0/−97
• src/GHC/Vacuum/GHC/Internal.hs +0/−335
• src/GHC/Vacuum/Internal.hs +483/−0
• vacuum.cabal +11/−25

@@ -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 

@@ -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) -------------------------------------------------++++++

@@ -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 "->")

@@ -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

@@ -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---------------------------------------------------------

@@ -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--------------------------------------------------

@@ -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++------------------------------------------------

@@ -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