vacuum 0.0.2 → 0.0.3
raw patch · 5 files changed
+305/−59 lines, 5 files
Files
- src/GHC/Vacuum.hs +274/−56
- src/GHC/Vacuum/ClosureType.hs +12/−1
- src/GHC/Vacuum/GHC/Imports.hs +17/−1
- src/GHC/Vacuum/GHC/Internal.hs +1/−0
- vacuum.cabal +1/−1
src/GHC/Vacuum.hs view
@@ -1,24 +1,25 @@ {- |-> ghci> ppHs . toAdjList $ vacuum (fix (0:))-> [(0, [1, 0]), (1, [])]+> ghci> 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 = ":"}),+> HNode{nodePtrs = [1, 0], nodeLits = [40425920],+> nodeInfo =+> ConInfo{itabPkg = "ghc-prim", itabMod = "GHC.Types", itabCon = ":",+> itabPtrs = 2, itabLits = 0, itabType = CONSTR_2_0, itabSrtLen = 1,+> itabCode =+> [72, 131, 195, 2, 255, 101, 0, 144, 224, 30, 0, 0, 0, 0, 0, 0]}}), > (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#"})]+> HNode{nodePtrs = [], nodeLits = [0, 40425920],+> nodeInfo =+> ConInfo{itabPkg = "integer", itabMod = "GHC.Integer.Internals",+> itabCon = "S#", itabPtrs = 0, itabLits = 1, itabType = CONSTR_0_1,+> itabSrtLen = 0,+> itabCode =+> [72, 255, 195, 255, 101, 0, 102, 144, 152, 0, 0, 0, 0, 0, 0, 0]}})] > > ghci> ppDot . nameGraph $ vacuum (fix (0:)) > digraph g {@@ -36,13 +37,19 @@ ,HNode(..) ,emptyHNode ,vacuum,dump+ ,vacuumTo,dumpTo ,toAdjList ,nameGraph ,ppHs,ppDot+ ,Closure(..)+ ,InfoTab(..)+ ,getClosure+ ,nodePkg,nodeMod+ ,nodeName,itabName ) where import GHC.Vacuum.Dot as Dot import GHC.Vacuum.ClosureType-import GHC.Vacuum.GHC as GHC+import GHC.Vacuum.GHC as GHC hiding (Closure) import Data.Char import Data.Word import Data.List@@ -54,25 +61,43 @@ import Data.Array.IArray import System.IO.Unsafe import Control.Monad+import Data.Bits import Language.Haskell.Meta.Utils(pretty) +import Foreign+import GHC.Arr(Array(..))+import GHC.Exts+ ----------------------------------------------------------------------------- -- | . vacuum :: a -> IntMap HNode vacuum a = unsafePerformIO (dump a) +-- | Stop after a given depth.+vacuumTo :: Int -> a -> IntMap HNode+vacuumTo n a = unsafePerformIO (dumpTo n a)+ dump :: a -> IO (IntMap HNode) dump a = execH (dumpH a) +dumpTo :: Int -> a -> IO (IntMap HNode)+dumpTo n a = execH (dumpToH n 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+ pp i = maybe "..."+ (\n -> nodeName n ++ "|" ++ show i)+ (IM.lookup i m) in fmap (\(x,xs) -> (pp x, fmap pp xs)) g +-----------------------------------------------------------------------------+ ppHs :: (Show a) => a -> Doc ppHs = text . pretty @@ -86,29 +111,108 @@ data HNode = HNode {nodePtrs :: [HNodeId] ,nodeLits :: [Word]- ,nodeTag :: Word- ,nodeIPtr :: Word- ,nodeICode :: [Word]- ,nodeCType :: ClosureType- ,nodePkg :: String- ,nodeMod :: String- ,nodeName :: String}+ ,nodeInfo :: InfoTab} deriving(Eq,Ord,Read,Show) +data InfoTab+ = ConInfo {itabPkg :: String+ ,itabMod :: String+ ,itabCon :: String+ ,itabPtrs :: Word+ ,itabLits :: Word+ ,itabType :: ClosureType+ ,itabSrtLen :: Word+ ,itabCode :: [Word]}+ | OtherInfo {itabPtrs :: Word+ ,itabLits :: Word+ ,itabType :: ClosureType+ ,itabSrtLen :: Word+ ,itabCode :: [Word]}+ deriving(Eq,Ord,Read,Show)++data Closure = Closure+ {closPtrs :: [HValue]+ ,closLits :: [Word]+ ,closITab :: InfoTab}+ deriving(Show)++-- So we can derive Show for Closure+instance Show HValue where show _ = "(HValue)"++------------------------------------------------+ emptyHNode :: ClosureType -> HNode emptyHNode ct = HNode {nodePtrs = [] ,nodeLits = []- ,nodeTag = 0- ,nodeIPtr = 0- ,nodeICode = []- ,nodeCType = ct- ,nodePkg = []- ,nodeMod = []- ,nodeName = []}+ ,nodeInfo = if isCon ct+ then ConInfo [] [] [] 0 0 ct 0 []+ else OtherInfo 0 0 ct 0 []} ------------------------------------------------------------------------------+nodePkg :: HNode -> String+nodeMod :: HNode -> String+nodeName :: HNode -> String+nodePkg = fst3 . itabName . nodeInfo+nodeMod = snd3 . itabName . nodeInfo+nodeName = trd3 . itabName . nodeInfo +fst3 (x,_,_) = x+snd3 (_,x,_) = x+trd3 (_,_,x) = x++itabName :: InfoTab -> (String, String, String)+itabName i@(ConInfo{}) = (itabPkg i, itabMod i, itabCon i)+itabName _ = ([], [], [])++------------------------------------------------++-- | This is in part borrowed from @RtClosureInspect.getClosureData@.+getClosure :: a -> IO Closure+getClosure a = a `seq`+ case unpackClosure# a of+ (# iptr+ ,ptrs+ ,nptrs #) -> 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.+ itab <- peekInfoTab iptr'+ let elems = fromIntegral (itabPtrs itab)+ ptrsList = if elems < 1+ then []+ else dumpArray (Array 0 (elems - 1) elems ptrs)+ lits = [W# (indexWordArray# nptrs i)+ | I# i <- [0.. fromIntegral (itabLits itab)] ]+ return (Closure ptrsList lits itab)++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)}+ _ -> return $ OtherInfo+ {itabPtrs = (fromIntegral . GHC.stgItblPtrs) stg+ ,itabLits = (fromIntegral . GHC.nptrs) stg+ ,itabType = ct+ ,itabSrtLen = fromIntegral (GHC.srtlen stg)+ ,itabCode = fmap fromIntegral (GHC.code stg)}++------------------------------------------------+ type H a = S Env a execH :: H a -> IO (IntMap HNode)@@ -145,6 +249,18 @@ [] -> 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+ ids <- nodeH a+ case ids of+ [] -> return ()+ _ -> mapM_ (go (n-1)) =<< mapM getHVal ids+ -- | Needed since i don't know of a way -- to go @a -> HValue@ directly (unsafeCoercing -- directly doesn't work (i tried)).@@ -163,35 +279,33 @@ -- 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+-- CURRENTLY unpackClosure# ENTERS *_ARR_WORDS+-- (WHICH IT SHOULDN'T, SEE BOTTOM OF THIS FILE)+-- (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)+ clos <- io (getClosure 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+ 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#+ _ -> return ptrs+ | otherwise -> return 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 ------------------------------------------------ @@ -268,3 +382,107 @@ runS (S g) s = g s (\s a -> return (a, s)) ------------------------------------------------++{- RE: the array entering problem:++rts/StgMiscClosures.cmm++/* ----------------------------------------------------------------------------+ Arrays++ These come in two basic flavours: arrays of data (StgArrWords) and arrays of+ pointers (StgArrPtrs). They all have a similar layout:++ ___________________________+ | Info | No. of | data....+ | Ptr | Words |+ ---------------------------++ These are *unpointed* objects: i.e. they cannot be entered. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!++ ------------------------------------------------------------------------- */++INFO_TABLE(stg_ARR_WORDS, 0, 0, ARR_WORDS, "ARR_WORDS", "ARR_WORDS")+{ foreign "C" barf("ARR_WORDS object entered!") never returns; }++INFO_TABLE(stg_MUT_ARR_PTRS_CLEAN, 0, 0, MUT_ARR_PTRS_CLEAN, "MUT_ARR_PTRS_CLEAN", "MUT_ARR_PTRS_CLEAN")+{ foreign "C" barf("MUT_ARR_PTRS_CLEAN object entered!") never returns; }++INFO_TABLE(stg_MUT_ARR_PTRS_DIRTY, 0, 0, MUT_ARR_PTRS_DIRTY, "MUT_ARR_PTRS_DIRTY", "MUT_ARR_PTRS_DIRTY")+{ foreign "C" barf("MUT_ARR_PTRS_DIRTY object entered!") never returns; }++INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN, 0, 0, MUT_ARR_PTRS_FROZEN, "MUT_ARR_PTRS_FROZEN", "MUT_ARR_PTRS_FROZEN")+{ foreign "C" barf("MUT_ARR_PTRS_FROZEN object entered!") never returns; }++INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN0, 0, 0, MUT_ARR_PTRS_FROZEN0, "MUT_ARR_PTRS_FROZEN0", "MUT_ARR_PTRS_FROZEN0")+{ foreign "C" barf("MUT_ARR_PTRS_FROZEN0 object entered!") never returns; }+-}++{-+unpackClosurezh_fast+{+/* args: R1 = closure to analyze */+// TODO: Consider the absence of ptrs or nonptrs as a special case ?++ W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;+ info = %GET_STD_INFO(UNTAG(R1));++ // Some closures have non-standard layout, so we omit those here.+ W_ type;+ type = TO_W_(%INFO_TYPE(info));+ switch [0 .. N_CLOSURE_TYPES] type {+ case THUNK_SELECTOR : {+ ptrs = 1;+ nptrs = 0;+ goto out;+ }+ case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,+ THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : { -- XXXXXXXXXXX: need to check for *ARR_WORDS here too!+ ptrs = 0;+ nptrs = 0;+ goto out;+ }+ default: {+ ptrs = TO_W_(%INFO_PTRS(info));+ nptrs = TO_W_(%INFO_NPTRS(info));+ goto out;+ }}+out:++ W_ ptrs_arr_sz, nptrs_arr_sz;+ nptrs_arr_sz = SIZEOF_StgArrWords + WDS(nptrs);+ ptrs_arr_sz = SIZEOF_StgMutArrPtrs + WDS(ptrs);++ ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast);++ W_ clos;+ clos = UNTAG(R1);++ ptrs_arr = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);+ nptrs_arr = Hp - nptrs_arr_sz + WDS(1);++ SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);+ StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;+ p = 0;+for:+ if(p < ptrs) {+ W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);+ p = p + 1;+ goto for;+ }++ SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);+ StgArrWords_words(nptrs_arr) = nptrs;+ p = 0;+for2:+ if(p < nptrs) {+ W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);+ p = p + 1;+ goto for2;+ }+ RET_NPP(info, ptrs_arr, nptrs_arr);+}++-}++
src/GHC/Vacuum/ClosureType.hs view
@@ -2,7 +2,7 @@ module GHC.Vacuum.ClosureType ( closureType ,ClosureType(..)- ,isFun,isThunk+ ,isFun,isThunk,isCon ) where import GHC.Vacuum.GHC as GHC@@ -40,6 +40,17 @@ isThunk THUNK_STATIC = True isThunk THUNK_SELECTOR = True isThunk _ = False++isCon :: ClosureType -> Bool+isCon CONSTR = True+isCon CONSTR_1_0 = True+isCon CONSTR_0_1 = True+isCon CONSTR_2_0 = True+isCon CONSTR_1_1 = True+isCon CONSTR_0_2 = True+isCon CONSTR_STATIC = True+isCon CONSTR_NOCAF_STATIC = True+isCon _ = False ------------------------------------------------
src/GHC/Vacuum/GHC/Imports.hs view
@@ -20,7 +20,7 @@ ,module SysTools ,module Packages -- ,module PackageConfig- ,module Distribution.Package+-- ,module Distribution.Package ,module Name ,module Module ,module IfaceEnv@@ -31,8 +31,12 @@ ,module Bag ,ghciTablesNextToCode ,setContext+ ,stgItblPtrs ) where +++ ------------------------------------------------ import Constants@@ -43,6 +47,7 @@ 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)@@ -79,3 +84,14 @@ ,isEmptyBag) ------------------------------------------------++stgItblPtrs = BCI.ptrs+++++------------------------------------------------++++
src/GHC/Vacuum/GHC/Internal.hs view
@@ -24,6 +24,7 @@ import GHC.Paths(libdir) import GHC.Vacuum.GHC.Imports as Imports+import Distribution.Package(PackageName(..)) import Data.Char import Data.Word
vacuum.cabal view
@@ -1,5 +1,5 @@ name: vacuum-version: 0.0.2+version: 0.0.3 cabal-version: >= 1.6 build-type: Simple license: BSD3