diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +> import Distribution.Simple +> main :: IO () +> main = defaultMain diff --git a/src/GHC/Vacuum.hs b/src/GHC/Vacuum.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vacuum.hs @@ -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)) + +------------------------------------------------ diff --git a/src/GHC/Vacuum/ClosureType.hs b/src/GHC/Vacuum/ClosureType.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vacuum/ClosureType.hs @@ -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" + +------------------------------------------------ diff --git a/src/GHC/Vacuum/Dot.hs b/src/GHC/Vacuum/Dot.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vacuum/Dot.hs @@ -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,"&"] +-} + +------------------------------------------------ diff --git a/src/GHC/Vacuum/GHC.hs b/src/GHC/Vacuum/GHC.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vacuum/GHC.hs @@ -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 diff --git a/src/GHC/Vacuum/GHC/Imports.hs b/src/GHC/Vacuum/GHC/Imports.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vacuum/GHC/Imports.hs @@ -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) + +------------------------------------------------ diff --git a/src/GHC/Vacuum/GHC/Internal.hs b/src/GHC/Vacuum/GHC/Internal.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vacuum/GHC/Internal.hs @@ -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 + +------------------------------------------------ diff --git a/vacuum.cabal b/vacuum.cabal new file mode 100644 --- /dev/null +++ b/vacuum.cabal @@ -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 +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