ghc-heap-view 0.2 → 0.3

raw patch · 4 files changed

+63/−24 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• cbits/HeapView.c +13/−13
• cbits/HeapViewPrim.cmm +2/−2
• ghc-heap-view.cabal +2/−2
• src/GHC/HeapView.hs +46/−7

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

@@ -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); }

@@ -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 @@   (<http://telekom-stiftung.de>). License:             BSD3 License-file:        LICENSE-Author:              Joachim Breitner+Author:              Joachim Breitner, Dennis Felsing Maintainer:          Joachim Breitner <mail@joachim-breitner.de> Copyright:           2012 Joachim Breitner Category:            Debug, GHC

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