vacuum (empty) → 0.0.1
raw patch · 9 files changed
+1088/−0 lines, 9 filesdep +Cabaldep +arraydep +basesetup-changed
Dependencies added: Cabal, array, base, containers, ghc, ghc-paths, ghc-prim, haskell-src-meta, pretty
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- src/GHC/Vacuum.hs +269/−0
- src/GHC/Vacuum/ClosureType.hs +267/−0
- src/GHC/Vacuum/Dot.hs +66/−0
- src/GHC/Vacuum/GHC.hs +8/−0
- src/GHC/Vacuum/GHC/Imports.hs +81/−0
- src/GHC/Vacuum/GHC/Internal.hs +335/−0
- vacuum.cabal +29/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Matt Morrow++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+> import Distribution.Simple +> main :: IO () +> main = defaultMain
+ src/GHC/Vacuum.hs view
@@ -0,0 +1,269 @@++{- |+> ghci> ppHs . toAdjList $ vacuum (fix (0:))+> [(0, [1, 0]), (1, [])]+>+> ghci> ppHs $ vacuum (fix (0:))+> fromList+> [(0,+> HNode{nodePtrs = [1, 0], nodeLits = [1084647872], nodeTag = 4,+> nodeIPtr = 1515520,+> nodeICode =+> [72, 131, 195, 2, 255, 101, 0, 144, 224, 30, 0, 0, 0, 0, 0, 0],+> nodeCType = CONSTR_2_0, nodePkg = "ghc-prim",+> nodeMod = "GHC.Types", nodeName = ":"}),+> (1,+> HNode{nodePtrs = [], nodeLits = [0, 1084647872], nodeTag = 3,+> nodeIPtr = 1871952,+> nodeICode =+> [72, 255, 195, 255, 101, 0, 102, 144, 152, 0, 0, 0, 0, 0, 0, 0],+> nodeCType = CONSTR_0_1, nodePkg = "integer",+> nodeMod = "GHC.Integer.Internals", nodeName = "S#"})]+>+> ghci> ppDot . nameGraph $ vacuum (fix (0:))+> digraph g {+> graph [rankdir=LR, splines=true];+> node [label="\N", shape=none, fontcolor=blue, fontname=courier];+> edge [color=black, style=dotted, fontname=courier, arrowname=onormal];+>+> ":|0" -> {"S#|1",":|0"}+> "S#|1" -> {}+> }+-}++module GHC.Vacuum (+ HNodeId+ ,HNode(..)+ ,emptyHNode+ ,vacuum,dump+ ,toAdjList+ ,nameGraph+ ,ppHs,ppDot+) where+import GHC.Vacuum.Dot as Dot+import GHC.Vacuum.ClosureType+import GHC.Vacuum.GHC as GHC+import Data.Char+import Data.Word+import Data.List+import Data.Map(Map)+import Data.IntMap(IntMap)+import qualified Data.IntMap as IM+import qualified Data.Map as M+import Data.Monoid(Monoid(..))+import Data.Array.IArray+import System.IO.Unsafe+import Control.Monad+import Language.Haskell.Meta.Utils(pretty)++-----------------------------------------------------------------------------++vacuum :: a -> IntMap HNode+vacuum a = unsafePerformIO (dump a)++dump :: a -> IO (IntMap HNode)+dump a = execH (dumpH a)++toAdjList :: IntMap HNode -> [(Int, [Int])]+toAdjList = fmap (mapsnd nodePtrs) . IM.toList++nameGraph :: IntMap HNode -> [(String, [String])]+nameGraph m = let g = toAdjList m+ pp i = nodeName (m IM.! i) ++ "|" ++ show i+ in fmap (\(x,xs) -> (pp x, fmap pp xs)) g++ppHs :: (Show a) => a -> Doc+ppHs = text . pretty++ppDot :: [(String, [String])] -> Doc+ppDot = Dot.graphToDot id++-----------------------------------------------------------------------------++type HNodeId = Int++data HNode = HNode+ {nodePtrs :: [HNodeId]+ ,nodeLits :: [Word]+ ,nodeTag :: Word+ ,nodeIPtr :: Word+ ,nodeICode :: [Word]+ ,nodeCType :: ClosureType+ ,nodePkg :: String+ ,nodeMod :: String+ ,nodeName :: String}+ deriving(Eq,Ord,Read,Show)++emptyHNode :: ClosureType -> HNode+emptyHNode ct = HNode+ {nodePtrs = []+ ,nodeLits = []+ ,nodeTag = 0+ ,nodeIPtr = 0+ ,nodeICode = []+ ,nodeCType = ct+ ,nodePkg = []+ ,nodeMod = []+ ,nodeName = []}++-----------------------------------------------------------------------------++type H a = S Env a++execH :: H a -> IO (IntMap HNode)+execH m = snd `fmap` runH m++runH :: H a -> IO (a, IntMap HNode)+runH m = do+ (a, s) <- runS m emptyEnv+ return (a, graph s)++data Env = Env+ {uniq :: HNodeId+ ,seen :: [(HValue, HNodeId)]+ ,hvals :: IntMap HValue+ ,graph :: IntMap HNode}++emptyEnv :: Env+emptyEnv = Env+ {uniq = 0+ ,seen = []+ ,hvals = mempty+ ,graph = mempty}++------------------------------------------------++-- | Walk the reachable heap (sub)graph rooted at @a@,+-- and collect it as a graph of @HNode@s in @H@'s state.+dumpH :: a -> H ()+dumpH a = go =<< rootH a+ where go :: HValue -> H ()+ go a = a `seq` do+ ids <- nodeH a+ case ids of+ [] -> return ()+ _ -> mapM_ go =<< mapM getHVal ids++-- | 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 = a `seq` Box a+ in b `seq` do+ c <- io (getClosureData b)+ case dumpArray (GHC.ptrs c) of+ [hval] -> return hval+ _ -> error "zomg"++-- | Add this @HValue@ to the graph, then+-- add it's successor's not already seen, and+-- return the @HNodeId@'s of these newly-seen nodes+-- (which we've added to the graph in @H@'s state).+-- CURRENTLY CAN'T SEEM TO MANAGE TO NOT ENTER AN+-- ARR_WORDS (e.g. BbyteArray#). THIS IS A PROBLEM+-- FOR LARGE INTEGERS, AMONG OTHER THINGS.+nodeH :: HValue -> H [HNodeId]+nodeH a = a `seq` do+ c <- io (getClosureData a)+ (i, _) <- getId a+ let itab = infoTable c+ tag = (fromIntegral . GHC.tipe) itab+ ctype = (toEnum . fromIntegral) tag+ case ctype of+ -- XXX: i think this isn't necessary for BCOs+ BCO -> insertG i (emptyHNode BCO) >> return []+ t | isThunk t -> insertG i (emptyHNode t) >> return []+ _ -> do+ (pkg,mod,name) <- case isFun ctype of+ False -> io (GHC.dataConInfoPtrToNames (infoPtr c))+ True -> return ([],[],[])+ let iptr = (fromIntegral . p2i . infoPtr) c+ ls = nonPtrs c+ let icode = (fmap fromIntegral . GHC.code) itab+ -- XXX: do something better with the thunks than discarding them+-- xs <- io (filterM (\a -> (not . isBadNews) `fmap` closureType a)+-- (dumpArray (GHC.ptrs c)))+ ys <- mapM getId (dumpArray (GHC.ptrs c)) -- xs+ let news = (fmap fst . fst . partition snd) ys+ n = HNode (fmap fst ys) ls tag iptr icode ctype pkg mod name+ insertG i n+ return news++------------------------------------------------++getHVal :: HNodeId -> H HValue+getHVal i = (IM.! i) `fmap` gets hvals++insertG :: HNodeId -> HNode -> H ()+insertG i n = do+ g <- gets graph+ modify (\e->e{graph = IM.insert i n g})++newId :: H HNodeId+newId = do+ n <- gets uniq+ modify (\e->e{uniq=n+1})+ return n++getId :: HValue -> H (HNodeId, Bool)+getId hval = hval `seq` do+ s <- gets seen+ case look hval s of+ Just i -> return (i, False)+ Nothing -> do+ i <- newId+ vs <- gets hvals+ modify (\e->e{seen=(hval,i):s+ ,hvals= IM.insert i hval vs})+ return (i, True)++------------------------------------------------++look :: HValue -> [(HValue, a)] -> Maybe a+look _ [] = Nothing+look hval ((x,i):xs)+ | hval .==. x = Just i+ | otherwise = look hval xs++(.==.) :: HValue -> HValue -> Bool+a .==. b = a `seq` b `seq`+ (0 /= I# (reallyUnsafePtrEquality# a b))++dumpArray :: Array Int a -> [a]+dumpArray a = let (m,n) = bounds a+ in fmap (a!) [m..n]++mapfst f = \(a,b) -> (f a,b)+mapsnd f = \(a,b) -> (a,f b)+f *** g = \(a, b) -> (f a, g b)++p2i :: Ptr a -> Int+i2p :: Int -> Ptr a+p2i (Ptr a#) = I# (addr2Int# a#)+i2p (I# n#) = Ptr (int2Addr# n#)++------------------------------------------------++newtype S s a = S {unS :: forall o. s -> (s -> a -> IO o) -> IO o}+instance Functor (S s) where+ fmap f (S g) = S (\s k -> g s (\s a -> k s (f a)))+instance Monad (S s) where+ return a = S (\s k -> k s a)+ S g >>= f = S (\s k -> g s (\s a -> unS (f a) s k))+get :: S s s+get = S (\s k -> k s s)+gets :: (s -> a) -> S s a+gets f = S (\s k -> k s (f s))+set :: s -> S s ()+set s = S (\_ k -> k s ())+io :: IO a -> S s a+io m = S (\s k -> k s =<< m)+modify :: (s -> s) -> S s ()+modify f = S (\s k -> k (f s) ())+runS :: S s a -> s -> IO (a, s)+runS (S g) s = g s (\s a -> return (a, s))++------------------------------------------------
+ src/GHC/Vacuum/ClosureType.hs view
@@ -0,0 +1,267 @@++module GHC.Vacuum.ClosureType (+ closureType+ ,ClosureType(..)+ ,isFun,isThunk+) 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+isFun FUN_0_1 = True+isFun FUN_2_0 = True+isFun FUN_1_1 = True+isFun FUN_0_2 = True+isFun FUN_STATIC = True+isFun _ = False++isThunk :: ClosureType -> Bool+isThunk THUNK = True+isThunk THUNK_1_0 = True+isThunk THUNK_0_1 = True+isThunk THUNK_2_0 = True+isThunk THUNK_1_1 = True+isThunk THUNK_0_2 = True+isThunk THUNK_STATIC = True+isThunk THUNK_SELECTOR = True+isThunk _ = False++------------------------------------------------++data ClosureType+ = INVALID_OBJECT+ | CONSTR+ | CONSTR_1_0+ | CONSTR_0_1+ | CONSTR_2_0+ | CONSTR_1_1+ | CONSTR_0_2+ | CONSTR_STATIC+ | CONSTR_NOCAF_STATIC+ | FUN+ | FUN_1_0+ | FUN_0_1+ | FUN_2_0+ | FUN_1_1+ | FUN_0_2+ | FUN_STATIC+ | THUNK+ | THUNK_1_0+ | THUNK_0_1+ | THUNK_2_0+ | THUNK_1_1+ | THUNK_0_2+ | THUNK_STATIC+ | THUNK_SELECTOR+ | BCO+ | AP+ | PAP+ | AP_STACK+ | IND+ | IND_OLDGEN+ | IND_PERM+ | IND_OLDGEN_PERM+ | IND_STATIC+ | RET_BCO+ | RET_SMALL+ | RET_BIG+ | RET_DYN+ | RET_FUN+ | UPDATE_FRAME+ | CATCH_FRAME+ | STOP_FRAME+ | CAF_BLACKHOLE+ | BLACKHOLE+ | MVAR_CLEAN+ | MVAR_DIRTY+ | ARR_WORDS+ | MUT_ARR_PTRS_CLEAN+ | MUT_ARR_PTRS_DIRTY+ | MUT_ARR_PTRS_FROZEN0+ | MUT_ARR_PTRS_FROZEN+ | MUT_VAR_CLEAN+ | MUT_VAR_DIRTY+ | WEAK+ | STABLE_NAME+ | TSO+ | BLOCKED_FETCH+ | FETCH_ME+ | FETCH_ME_BQ+ | RBH+ | REMOTE_REF+ | TVAR_WATCH_QUEUE+ | INVARIANT_CHECK_QUEUE+ | ATOMIC_INVARIANT+ | TVAR+ | TREC_CHUNK+ | TREC_HEADER+ | ATOMICALLY_FRAME+ | CATCH_RETRY_FRAME+ | CATCH_STM_FRAME+ | WHITEHOLE+ | N_CLOSURE_TYPES+ 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+ toEnum 0 = INVALID_OBJECT+ toEnum 1 = CONSTR+ toEnum 2 = CONSTR_1_0+ toEnum 3 = CONSTR_0_1+ toEnum 4 = CONSTR_2_0+ toEnum 5 = CONSTR_1_1+ toEnum 6 = CONSTR_0_2+ toEnum 7 = CONSTR_STATIC+ toEnum 8 = CONSTR_NOCAF_STATIC+ toEnum 9 = FUN+ toEnum 10 = FUN_1_0+ toEnum 11 = FUN_0_1+ toEnum 12 = FUN_2_0+ toEnum 13 = FUN_1_1+ toEnum 14 = FUN_0_2+ toEnum 15 = FUN_STATIC+ toEnum 16 = THUNK+ toEnum 17 = THUNK_1_0+ toEnum 18 = THUNK_0_1+ toEnum 19 = THUNK_2_0+ toEnum 20 = THUNK_1_1+ toEnum 21 = THUNK_0_2+ toEnum 22 = THUNK_STATIC+ toEnum 23 = THUNK_SELECTOR+ toEnum 24 = BCO+ toEnum 25 = AP+ toEnum 26 = PAP+ toEnum 27 = AP_STACK+ toEnum 28 = IND+ toEnum 29 = IND_OLDGEN+ toEnum 30 = IND_PERM+ toEnum 31 = IND_OLDGEN_PERM+ toEnum 32 = IND_STATIC+ toEnum 33 = RET_BCO+ toEnum 34 = RET_SMALL+ toEnum 35 = RET_BIG+ toEnum 36 = RET_DYN+ toEnum 37 = RET_FUN+ toEnum 38 = UPDATE_FRAME+ toEnum 39 = CATCH_FRAME+ 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"++------------------------------------------------
+ src/GHC/Vacuum/Dot.hs view
@@ -0,0 +1,66 @@++module GHC.Vacuum.Dot (+ graphToDot+ ,ppGraph,ppEdge,gStyle+ ,Doc,text,render+) where++import Text.PrettyPrint++------------------------------------------------++-- | .+graphToDot :: (a -> String) -> [(a, [a])] -> Doc+graphToDot f = ppGraph . fmap (f *** fmap f)+ where f *** g = \(a, b)->(f a, g b)++------------------------------------------------++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];"]++ppGraph :: [(String, [String])] -> Doc+ppGraph xs = (text "digraph g" <+> text "{")+ $+$ text gStyle+ $+$ nest indent (vcat . fmap ppEdge $ xs)+ $+$ text "}"+ where indent = 4++ppEdge :: (String, [String]) -> Doc+ppEdge (x,xs) = (dQText x) <+> (text "->")+ <+> (braces . hcat . punctuate comma+ . fmap dQText $ xs)++dQText :: String -> Doc+dQText = doubleQuotes . text++{-+import System.Cmd+import System.Exit+graphToDotPng :: FilePath -> [(String,[String])] -> IO Bool+graphToDotPng fpre g = do+ let [dot,png] = fmap (fpre++) [".dot",".png"]+ writeFile dot+ . render . ppGraph+ -- . fmap (show***fmap show)+ $ g+ ((==ExitSuccess) `fmap`) .system . intercalate " " $+ -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]+ ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","display",png,"&"]++graphToDotPdf :: FilePath -> [(String,[String])] -> IO Bool+graphToDotPdf fpre g = do+ let [dot,png] = fmap (fpre++) [".dot",".pdf"]+ writeFile dot+ . render . ppGraph+ -- . fmap (show***fmap show)+ $ g+ ((==ExitSuccess) `fmap`) .system . intercalate " " $+ -- ["cat",dot,"|","dot -Tpng",">",png,"2>/dev/null;","gliv",png,"&"]+ ["cat",dot,"tred","|","dot -Tpdf",">",png,"2>/dev/null;","evince",png,"&"]+-}++------------------------------------------------
+ src/GHC/Vacuum/GHC.hs view
@@ -0,0 +1,8 @@++module GHC.Vacuum.GHC (+ module Internal+ ,module Imports+) where++import GHC.Vacuum.GHC.Imports as Imports+import GHC.Vacuum.GHC.Internal as Internal
+ src/GHC/Vacuum/GHC/Imports.hs view
@@ -0,0 +1,81 @@++-- | 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+) where++------------------------------------------------++import Constants++import GHC.Ptr(Ptr(..))+import GHC.Prim+import GHC.Exts(Int(..))++import ByteCodeLink+import ByteCodeItbls as BCI hiding (ptrs)+-- 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)++------------------------------------------------
+ src/GHC/Vacuum/GHC/Internal.hs view
@@ -0,0 +1,335 @@++-- | 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 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 turn 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)++-- | Escape this hideous Ghc monad :-)+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++------------------------------------------------
+ vacuum.cabal view
@@ -0,0 +1,29 @@+name: vacuum+version: 0.0.1+cabal-version: >= 1.6+build-type: Simple+license: BSD3+license-file: LICENSE+category: Interpreter, GHC+author: Matt Morrow+copyright: (c) Matt Morrow 2008+maintainer: Matt Morrow <morrow@moonpatio.com>+stability: experimental+synopsis: Extract graph representations of ghc heap values.+description: .++library+ hs-source-dirs: src+ ghc-options: -O2 -fglasgow-exts+ extensions:+ build-depends: base==4.*,+ ghc==6.10.1, ghc-prim,+ array, containers, array,+ pretty, haskell-src-meta,+ Cabal >= 1.6, ghc-paths+ exposed-modules: GHC.Vacuum,+ GHC.Vacuum.ClosureType,+ GHC.Vacuum.Dot,+ GHC.Vacuum.GHC.Internal+ other-modules: GHC.Vacuum.GHC,+ GHC.Vacuum.GHC.Imports