diff --git a/cbits/HeapView.c b/cbits/HeapView.c --- a/cbits/HeapView.c +++ b/cbits/HeapView.c @@ -1,12 +1,12 @@ #include "Rts.h" -StgWord closureSize(StgClosure *closure) { +StgWord gtc_heap_view_closureSize(StgClosure *closure) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); return closure_sizeW(closure); } static void -closure_ptrs_in_large_bitmap(StgClosure *ptrs[], StgWord *nptrs, StgClosure **p, StgLargeBitmap *large_bitmap, nat size ) +gtc_heap_view_closure_ptrs_in_large_bitmap(StgClosure *ptrs[], StgWord *nptrs, StgClosure **p, StgLargeBitmap *large_bitmap, nat size ) { nat i, j, b; StgWord bitmap; @@ -27,7 +27,7 @@ } // from rts/Printer.c -char *closure_type_names[] = { +char *gtc_heap_view_closure_type_names[] = { [INVALID_OBJECT] = "INVALID_OBJECT", [CONSTR] = "CONSTR", [CONSTR_1_0] = "CONSTR_1_0", @@ -92,12 +92,12 @@ }; -void closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs, StgClosure *fun, StgClosure **payload, StgWord size) { +void gtc_heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs, StgClosure *fun, StgClosure **payload, StgWord size) { StgWord bitmap; StgFunInfoTable *fun_info; - + fun_info = get_fun_itbl(UNTAG_CLOSURE(fun)); - ASSERT(fun_info->i.type != PAP); + // ASSERT(fun_info->i.type != PAP); StgClosure **p = payload; switch (fun_info->f.fun_type) { @@ -105,10 +105,10 @@ bitmap = BITMAP_BITS(fun_info->f.b.bitmap); goto small_bitmap; case ARG_GEN_BIG: - closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, GET_FUN_LARGE_BITMAP(fun_info), size); + gtc_heap_view_closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, GET_FUN_LARGE_BITMAP(fun_info), size); break; case ARG_BCO: - closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, BCO_BITMAP(fun), size); + gtc_heap_view_closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, BCO_BITMAP(fun), size); break; default: bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); @@ -125,10 +125,10 @@ } } -StgMutArrPtrs *closurePtrs(Capability *cap, StgClosure *closure) { +StgMutArrPtrs *gtc_heap_view_closurePtrs(Capability *cap, StgClosure *closure) { ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure)); - StgWord size = closureSize(closure); + StgWord size = gtc_heap_view_closureSize(closure); StgWord nptrs = 0; StgWord i; @@ -197,7 +197,7 @@ case AP: ptrs[nptrs++] = ((StgAP *)closure)->fun; - closure_ptrs_in_pap_payload(ptrs, &nptrs, + gtc_heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs, ((StgAP *)closure)->fun, ((StgAP *)closure)->payload, ((StgAP *)closure)->n_args); @@ -205,7 +205,7 @@ case PAP: ptrs[nptrs++] = ((StgPAP *)closure)->fun; - closure_ptrs_in_pap_payload(ptrs, &nptrs, + gtc_heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs, ((StgPAP *)closure)->fun, ((StgPAP *)closure)->payload, ((StgPAP *)closure)->n_args); @@ -249,7 +249,7 @@ break; default: - fprintf(stderr,"closurePtrs: Cannot handle type %s yet\n", closure_type_names[info->type]); + fprintf(stderr,"closurePtrs: Cannot handle type %s yet\n", gtc_heap_view_closure_type_names[info->type]); break; } diff --git a/cbits/HeapViewPrim.cmm b/cbits/HeapViewPrim.cmm --- a/cbits/HeapViewPrim.cmm +++ b/cbits/HeapViewPrim.cmm @@ -18,7 +18,7 @@ W_ info; info = %GET_STD_INFO(clos); - (len) = foreign "C" closureSize(clos "ptr") []; + (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") []; W_ data_arr_sz; data_arr_sz = SIZEOF_StgArrWords + WDS(len); @@ -42,7 +42,7 @@ W_ ptrArray; - ("ptr" ptrArray) = foreign "C" closurePtrs(MyCapability() "ptr", clos "ptr") []; + ("ptr" ptrArray) = foreign "C" gtc_heap_view_closurePtrs(MyCapability() "ptr", clos "ptr") []; RET_NPP(info, data_arr, ptrArray); } diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal --- a/ghc-heap-view.cabal +++ b/ghc-heap-view.cabal @@ -1,5 +1,5 @@ Name: ghc-heap-view -Version: 0.2 +Version: 0.3 Synopsis: Extract the heap representation of Haskell values and thunks Description: This library provides functions to introspect the Haskell heap, for example @@ -12,7 +12,7 @@ (). License: BSD3 License-file: LICENSE -Author: Joachim Breitner +Author: Joachim Breitner, Dennis Felsing Maintainer: Joachim Breitner Copyright: 2012 Joachim Breitner Category: Debug, GHC diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -35,6 +35,7 @@ import Foreign import Numeric ( showHex ) import Data.Char +import Data.List ( intersperse ) -- | An arbitrarily Haskell value in a safe Box. The point is that even -- unevaluated thunks can safely be moved around inside the Box, and when @@ -244,7 +245,9 @@ info :: StgInfoTable , ptrArgs :: [Box] , dataArgs :: [Word] - , descr :: String + , pkg :: String + , modl :: String + , name :: String } | ThunkClosure { info :: StgInfoTable @@ -259,6 +262,10 @@ info :: StgInfoTable , indirectee :: Box } | + BlackholeClosure { + info :: StgInfoTable + , indirectee :: Box + } | APClosure { info :: StgInfoTable , arity :: HalfWord @@ -329,6 +336,7 @@ allPtrs (ThunkClosure {..}) = ptrArgs allPtrs (SelectorClosure {..}) = [selectee] allPtrs (IndClosure {..}) = [indirectee] +allPtrs (BlackholeClosure {..}) = [indirectee] allPtrs (APClosure {..}) = fun:payload allPtrs (PAPClosure {..}) = fun:payload allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs] @@ -389,12 +397,16 @@ -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from -- compiler/ghci/DebuggerUtils.hs -dataConInfoPtrToNames :: Ptr StgInfoTable -> IO String +dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String) dataConInfoPtrToNames ptr = do conDescAddress <- getConDescAddress ptr wl <- peekArray0 0 conDescAddress - return $ fmap (chr . fromIntegral) wl + let (pkg, modl, name) = parse wl + return (b2s pkg, b2s modl, b2s name) where + b2s :: [Word8] -> String + b2s = fmap (chr . fromIntegral) + getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8) getConDescAddress ptr' | True = do @@ -425,8 +437,35 @@ stdInfoTableSizeB :: Int stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE - +-- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs +parse :: [Word8] -> ([Word8], [Word8], [Word8]) +parse input = if not . all (>0) . fmap length $ [pkg,modl,occ] + --then (error . concat) + -- ["getConDescAddress:parse:" + -- ,"(not . all (>0) . fmap le" + -- ,"ngth $ [pkg,modl,occ]"] + then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE + else (pkg, modl, occ) +-- = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ) -- XXXXXXXXXXXXXXXX + where + (pkg, rest1) = break (== fromIntegral (ord ':')) input + (modl, occ) + = (concat $ intersperse [dot] $ reverse modWords, occWord) + where + (modWords, occWord) = if (length rest1 < 1) -- XXXXXXXXx YUKX + --then error "getConDescAddress:parse:length rest1 < 1" + then parseModOcc [] [] + 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 + + -- | This function returns parsed heap representation of the argument _at this -- moment_, even if it is unevaluated or an indirection or other exotic stuff. -- Beware when passing something to this function, the same caveats as for @@ -437,8 +476,8 @@ itbl <- peek iptr case tipe itbl of t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do - name <- dataConInfoPtrToNames iptr - return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) name + (pkg, modl, name) <- dataConInfoPtrToNames iptr + return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name t | t >= THUNK && t <= THUNK_STATIC -> do return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds) @@ -466,7 +505,7 @@ IND_STATIC -> return $ IndClosure itbl (head ptrs) BLACKHOLE -> - return $ IndClosure itbl (head ptrs) + return $ BlackholeClosure itbl (head ptrs) BCO -> return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)