ghc-heap-view 0.5.11 → 0.6.0
raw patch · 8 files changed
+66/−916 lines, 8 filesdep +ghc-heapdep −ghcdep ~base
Dependencies added: ghc-heap
Dependencies removed: ghc
Dependency ranges changed: base
Files
- Test.hs +3/−8
- cbits/HeapView.c +0/−288
- cbits/HeapViewPrim.cmm +0/−53
- ghc-heap-view.cabal +9/−36
- src/GHC/AssertNF.hs +5/−7
- src/GHC/Disassembler.hs +2/−1
- src/GHC/HeapView.hs +43/−519
- src/GHC/HeapView/Debug.hs +4/−4
Test.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash, BangPatterns, CPP #-}+{-# LANGUAGE MagicHash, BangPatterns #-} import GHC.Exts import GHC.HeapView@@ -27,12 +27,7 @@ unless eq $ fail "Doesn't reference list" getClosureData args >>= \ cl ->-#if MIN_VERSION_GLASGOW_HASKELL(8,1,0,0) assertClosureType CONSTR_0_1 (info cl)-#else- assertClosureType CONSTR_NOCAF_STATIC (info cl)-#endif- getClosureData x >>= \ cl -> assertClosureType THUNK_2_0 (info cl) @@ -74,8 +69,8 @@ getClosureAssert x = do cl <- getClosureData x case cl of- ConsClosure {} -> pure cl- _ -> fail "Expected ConsClosure"+ ConstrClosure {} -> pure cl+ _ -> fail "Expected ConstrClosure" assertClosureType :: ClosureType -> StgInfoTable -> IO ()
− cbits/HeapView.c
@@ -1,288 +0,0 @@-#include "Rts.h"--StgWord gtc_heap_view_closureSize(StgClosure *closure) {- ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));- return closure_sizeW(closure);-}--static void-gtc_heap_view_closure_ptrs_in_large_bitmap(StgClosure *ptrs[], StgWord *nptrs, StgClosure **p, StgLargeBitmap *large_bitmap, uint32_t size )-{- uint32_t i, j, b;- StgWord bitmap;-- b = 0;-- for (i = 0; i < size; b++) {- bitmap = large_bitmap->bitmap[b];- j = stg_min(size-i, BITS_IN(W_));- i += j;- for (; j > 0; j--, p++) {- if ((bitmap & 1) == 0) {- ptrs[(*nptrs)++] = *p;- }- bitmap = bitmap >> 1;- } - }-}--// from rts/Printer.c-char *gtc_heap_view_closure_type_names[] = {- [INVALID_OBJECT] = "INVALID_OBJECT",- [CONSTR] = "CONSTR",- [CONSTR_1_0] = "CONSTR_1_0",- [CONSTR_0_1] = "CONSTR_0_1",- [CONSTR_2_0] = "CONSTR_2_0",- [CONSTR_1_1] = "CONSTR_1_1",- [CONSTR_0_2] = "CONSTR_0_2",-#if defined(GHC_8_0)- [CONSTR_STATIC] = "CONSTR_STATIC",- [CONSTR_NOCAF_STATIC] = "CONSTR_NOCAF_STATIC",-#else- [CONSTR_NOCAF] = "CONSTR_NOCAF",-#endif- [FUN] = "FUN",- [FUN_1_0] = "FUN_1_0",- [FUN_0_1] = "FUN_0_1",- [FUN_2_0] = "FUN_2_0",- [FUN_1_1] = "FUN_1_1",- [FUN_0_2] = "FUN_0_2",- [FUN_STATIC] = "FUN_STATIC",- [THUNK] = "THUNK",- [THUNK_1_0] = "THUNK_1_0",- [THUNK_0_1] = "THUNK_0_1",- [THUNK_2_0] = "THUNK_2_0",- [THUNK_1_1] = "THUNK_1_1",- [THUNK_0_2] = "THUNK_0_2",- [THUNK_STATIC] = "THUNK_STATIC",- [THUNK_SELECTOR] = "THUNK_SELECTOR",- [BCO] = "BCO",- [AP] = "AP",- [PAP] = "PAP",- [AP_STACK] = "AP_STACK",- [IND] = "IND",-#if defined(GHC_8_0)- [IND_PERM] = "IND_PERM",-#endif- [IND_STATIC] = "IND_STATIC",- [RET_BCO] = "RET_BCO",- [RET_SMALL] = "RET_SMALL",- [RET_BIG] = "RET_BIG",- [RET_FUN] = "RET_FUN",- [UPDATE_FRAME] = "UPDATE_FRAME",- [CATCH_FRAME] = "CATCH_FRAME",- [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME",- [STOP_FRAME] = "STOP_FRAME",- [BLACKHOLE] = "BLACKHOLE",- [BLOCKING_QUEUE] = "BLOCKING_QUEUE",- [MVAR_CLEAN] = "MVAR_CLEAN",- [MVAR_DIRTY] = "MVAR_DIRTY",- [ARR_WORDS] = "ARR_WORDS",- [MUT_ARR_PTRS_CLEAN] = "MUT_ARR_PTRS_CLEAN",- [MUT_ARR_PTRS_DIRTY] = "MUT_ARR_PTRS_DIRTY",- [MUT_ARR_PTRS_FROZEN0] = "MUT_ARR_PTRS_FROZEN0",- [MUT_ARR_PTRS_FROZEN] = "MUT_ARR_PTRS_FROZEN",- [MUT_VAR_CLEAN] = "MUT_VAR_CLEAN",- [MUT_VAR_DIRTY] = "MUT_VAR_DIRTY",- [WEAK] = "WEAK",- [PRIM] = "PRIM",- [MUT_PRIM] = "MUT_PRIM",- [TSO] = "TSO",- [STACK] = "STACK",- [TREC_CHUNK] = "TREC_CHUNK",- [ATOMICALLY_FRAME] = "ATOMICALLY_FRAME",- [CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME",- [CATCH_STM_FRAME] = "CATCH_STM_FRAME",- [WHITEHOLE] = "WHITEHOLE",- [SMALL_MUT_ARR_PTRS_CLEAN] = "SMALL_MUT_ARR_PTRS_CLEAN",- [SMALL_MUT_ARR_PTRS_DIRTY] = "SMALL_MUT_ARR_PTRS_DIRTY",- [SMALL_MUT_ARR_PTRS_FROZEN0] = "SMALL_MUT_ARR_PTRS_FROZEN0",- [SMALL_MUT_ARR_PTRS_FROZEN] = "SMALL_MUT_ARR_PTRS_FROZEN",-#if defined(GHC_8_2)- [COMPACT_NFDATA] = "COMPACT_NFDATA",-#endif-};---void gtc_heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs, StgClosure *fun, StgClosure **payload, StgWord size) {- StgWord bitmap;- const StgFunInfoTable *fun_info;-- fun_info = get_fun_itbl(UNTAG_CLOSURE(fun));- // ASSERT(fun_info->i.type != PAP);- StgClosure **p = payload;-- switch (fun_info->f.fun_type) {- case ARG_GEN:- bitmap = BITMAP_BITS(fun_info->f.b.bitmap);- goto small_bitmap;- case ARG_GEN_BIG:- gtc_heap_view_closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, GET_FUN_LARGE_BITMAP(fun_info), size);- break;- case ARG_BCO:- 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]);- small_bitmap:- while (size > 0) {- if ((bitmap & 1) == 0) {- ptrs[(*nptrs)++] = *p;- }- bitmap = bitmap >> 1;- p++;- size--;- }- break;- }-}--StgMutArrPtrs *gtc_heap_view_closurePtrs(Capability *cap, StgClosure *closure) {- ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));-- StgWord size = gtc_heap_view_closureSize(closure);- StgWord nptrs = 0;- StgWord i;-- // First collect all pointers here, with the comfortable memory bound- // of the whole closure. Afterwards we know how many pointers are in- // the closure and then we can allocate space on the heap and copy them- // there- StgClosure *ptrs[size];-- StgClosure **end;- StgClosure **ptr;-- const StgInfoTable *info = get_itbl(closure);- StgThunkInfoTable *thunk_info;- StgFunInfoTable *fun_info;-- switch (info->type) {- case INVALID_OBJECT:- barf("Invalid Object");- break;-- // No pointers- case ARR_WORDS:- break;-- // Default layout- case CONSTR_1_0:- case CONSTR_0_1:- case CONSTR_2_0:- case CONSTR_1_1:- case CONSTR_0_2:- case CONSTR:-#if defined(GHC_8_0)- case CONSTR_STATIC:- case CONSTR_NOCAF_STATIC:-#else- case CONSTR_NOCAF:-#endif- case PRIM:-- case FUN:- case FUN_1_0:- case FUN_0_1:- case FUN_1_1:- case FUN_2_0:- case FUN_0_2:- case FUN_STATIC:- end = closure->payload + info->layout.payload.ptrs;- for (ptr = closure->payload; ptr < end; ptr++) {- ptrs[nptrs++] = *ptr;- }- break;-- case THUNK:- case THUNK_1_0:- case THUNK_0_1:- case THUNK_1_1:- case THUNK_2_0:- case THUNK_0_2:- case THUNK_STATIC:- end = ((StgThunk *)closure)->payload + info->layout.payload.ptrs;- for (ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {- ptrs[nptrs++] = *ptr;- }- break;-- case THUNK_SELECTOR:- ptrs[nptrs++] = ((StgSelector *)closure)->selectee;- break;- - case AP:- ptrs[nptrs++] = ((StgAP *)closure)->fun;- gtc_heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs,- ((StgAP *)closure)->fun,- ((StgAP *)closure)->payload,- ((StgAP *)closure)->n_args);- break;- - case PAP:- ptrs[nptrs++] = ((StgPAP *)closure)->fun;- gtc_heap_view_closure_ptrs_in_pap_payload(ptrs, &nptrs,- ((StgPAP *)closure)->fun,- ((StgPAP *)closure)->payload,- ((StgPAP *)closure)->n_args);- break;- - case AP_STACK:- ptrs[nptrs++] = ((StgAP_STACK *)closure)->fun;- for (i = 0; i < ((StgAP_STACK *)closure)->size; ++i) {- ptrs[nptrs++] = ((StgAP_STACK *)closure)->payload[i];- }- break;- - case BCO:- ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->instrs;- ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->literals;- ptrs[nptrs++] = (StgClosure *)((StgBCO *)closure)->ptrs;- break;- - case IND:-#if defined(GHC_8_0)- case IND_PERM:-#endif- case IND_STATIC:- case BLACKHOLE:- ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee);- break;-- case MUT_ARR_PTRS_CLEAN:- case MUT_ARR_PTRS_DIRTY:- case MUT_ARR_PTRS_FROZEN:- case MUT_ARR_PTRS_FROZEN0:- for (i = 0; i < ((StgMutArrPtrs *)closure)->ptrs; ++i) {- ptrs[nptrs++] = ((StgMutArrPtrs *)closure)->payload[i];- }- break;- case MUT_VAR_CLEAN:- ptrs[nptrs++] = ((StgMutVar *)closure)->var;- break;- case MVAR_DIRTY:- case MVAR_CLEAN:- ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->head;- ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->tail;- ptrs[nptrs++] = ((StgMVar *)closure)->value;- break;-- default:- //fprintf(stderr,"closurePtrs: Cannot handle type %s yet\n", gtc_heap_view_closure_type_names[info->type]);- break;- }-- size = nptrs + mutArrPtrsCardTableSize(nptrs);- StgMutArrPtrs *arr = - (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);- TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), nptrs, 0);- SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_info, CCCS);- arr->ptrs = nptrs;- arr->size = size;-- for (i = 0; i<nptrs; i++) {- arr->payload[i] = ptrs[i];- }-- return arr;-}
− cbits/HeapViewPrim.cmm
@@ -1,53 +0,0 @@-#include "Cmm.h"--aToWordzh (P_ clos)-{- return (clos);-}--slurpClosurezh ( P_ closure )-{- W_ info, ptrs, nptrs, p, ptrs_arr, dat_arr;- info = %GET_STD_INFO(UNTAG(closure));-- ptrs = TO_W_(%INFO_PTRS(info));- nptrs = TO_W_(%INFO_NPTRS(info));-- W_ clos;- clos = UNTAG(closure);-- W_ len;- (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr");-- W_ ptrs_arr_sz, ptrs_arr_cards, dat_arr_sz;- dat_arr_sz = SIZEOF_StgArrBytes + WDS(len);-- ALLOC_PRIM_P (dat_arr_sz, slurpClosurezh, closure);-- dat_arr = Hp - dat_arr_sz + WDS(1);--- SET_HDR(dat_arr, stg_ARR_WORDS_info, CCCS);- StgArrBytes_bytes(dat_arr) = WDS(len);- p = 0;-for:- if(p < len) {- W_[BYTE_ARR_CTS(dat_arr) + WDS(p)] = W_[clos + WDS(p)];- p = p + 1;- goto for;- }-- W_ ptrArray;-- ("ptr" ptrArray) = foreign "C" gtc_heap_view_closurePtrs(MyCapability() "ptr", clos "ptr");-- return (info, dat_arr, ptrArray);-}---reallyUnsafePtrEqualityUpToTag (W_ clos1, W_ clos2)-{- clos1 = UNTAG(clos1);- clos2 = UNTAG(clos2);- return (clos1 == clos2);-}
ghc-heap-view.cabal view
@@ -1,11 +1,11 @@ Name: ghc-heap-view-Version: 0.5.11+Version: 0.6.0 Synopsis: Extract the heap representation of Haskell values and thunks Description: This library provides functions to introspect the Haskell heap, for example to investigate sharing and lazy evaluation. As this is tied to the internals- of the compiler, it only works with specific versions. Currently, GHC 7.4- through 7.10 should be supported.+ of the compiler, it only works with specific versions. This version supports,+ GHC 8.6. For older GHC versions see ghc-heap-view-0.5.10. . It has been inspired by (and taken code from) the vacuum package and the GHCi debugger, but also allows to investigate thunks and other closures.@@ -40,15 +40,16 @@ . The work on this package has been supported by the Deutsche Telekom Stiftung (<http://telekom-stiftung.de>).+tested-with: GHC == 8.6.1, GHC == 8.6.2, GHC == 8.6.3, GHC == 8.6.4, GHC == 8.6.5 License: BSD3 License-file: LICENSE Author: Joachim Breitner, Dennis Felsing Maintainer: Joachim Breitner <mail@joachim-breitner.de>-Copyright: 2012-2014 Joachim Breitner+Copyright: 2012-2019 Joachim Breitner bug-reports: https://github.com/nomeata/ghc-heap-view Category: Debug, GHC Build-type: Custom-Cabal-version: >=1.24+Cabal-version: 1.24 Extra-source-files: Demo.hs data-files: ghci @@ -56,16 +57,10 @@ Description: The used GHC supports Any as an argument to foreign prim functions (GHC ticket #5931) Default: False -Flag ghc_8_0--Flag ghc_8_2--Flag ghc_8_4- custom-setup setup-depends: base setup-depends: filepath- setup-depends: Cabal >= 1.24 && < 3.2+ setup-depends: Cabal >= 1.24 && < 2.6 Library Default-Language: Haskell2010@@ -75,37 +70,15 @@ GHC.Disassembler GHC.HeapView.Debug Build-depends:- base >= 4.5 && < 4.12,+ base >= 4.12 && < 4.13,+ ghc-heap, containers, transformers, template-haskell, bytestring >= 0.10, binary-- if flag(ghc_8_0)- build-depends: ghc >= 8.0 && < 8.2- cc-options: -DGHC_8_0- cpp-options: -DGHC_8_0- else- if flag(ghc_8_2)- build-depends: ghc >= 8.2 && < 8.4- cc-options: -DGHC_8_2- cpp-options: -DGHC_8_2- else- if flag(ghc_8_4)- build-depends: ghc >= 8.4 && < 8.6- cc-options: -DGHC_8_4- cpp-options: -DGHC_8_4- else- build-depends: ghc == 0.0--- C-Sources: cbits/HeapView.c cbits/HeapViewPrim.cmm Hs-source-dirs: src/ Ghc-options: -Wall-- if flag(prim-supports-any)- cpp-options: -DPRIM_SUPPORTS_ANY test-suite Test type: exitcode-stdio-1.0
src/GHC/AssertNF.hs view
@@ -2,7 +2,7 @@ {-| Module : GHC.AssertNF-Copyright : (c) 2013 Joachim Breitner+Copyright : (c) 2013-2019 Joachim Breitner License : BSD3 Maintainer : Joachim Breitner <mail@joachim-breitner.de> @@ -114,9 +114,8 @@ if nf then do c' <- getBoxedClosureData b- concat <$> mapM (assertNFBoxed (d+1)) (allPtrs c')- else do- return [d]+ concat <$> mapM (assertNFBoxed (d+1)) (allClosures c')+ else return [d] -- | Invoke this function at the top of your 'main' method to turn every call -- to 'assertNF' and its variants to noops.@@ -136,9 +135,8 @@ if nf then do c' <- getBoxedClosureData b- allM isNFBoxed (allPtrs c')- else do- return False+ allM isNFBoxed (allClosures c')+ else return False -- From Control.Monad.Loops in monad-loops, but I'd like to avoid too many -- trivial dependencies
src/GHC/Disassembler.hs view
@@ -234,7 +234,7 @@ _ <- getWord16host _ <- getWord16host return BCIBRK_FUN- x -> error $ "Unknown opcode " ++ show x+ x -> return $ BCI_DECODE_ERROR x (i :) `fmap` nextInst @@ -296,6 +296,7 @@ | BCIBRK_FUN -- ^ We do not parse this opcode's arguments | BCITESTLT_W Word Int | BCITESTEQ_W Word Int+ | BCI_DECODE_ERROR Word16 deriving (Show, Functor, Traversable, Foldable) #if MIN_VERSION_binary(0,8,1)
src/GHC/HeapView.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-} {-| Module : GHC.HeapView-Copyright : (c) 2012 Joachim Breitner+Copyright : (c) 2012-2019 Joachim Breitner License : BSD3 Maintainer : Joachim Breitner <mail@joachim-breitner.de> @@ -14,7 +16,7 @@ -- * Heap data types GenClosure(..), Closure,- allPtrs,+ allClosures, -- was allPtrs ClosureType(..), StgInfoTable(..), HalfWord,@@ -50,15 +52,16 @@ where import GHC.Exts ( Any,- Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,+ Ptr(..), Addr#, Int(..), Word(..), ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#, unsafeCoerce# ) -import GHC.Arr (Array(..))+import GHC.Exts.Heap+import GHC.Exts.Heap.Constants +import GHC.Arr (Array(..)) import Foreign hiding ( void )-import Numeric ( showHex ) import Data.Char import Data.List import Data.Maybe ( catMaybes )@@ -81,71 +84,11 @@ #include "ghcautoconf.h" --- | 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--- required, e.g. in 'getBoxedClosureData', the function knows how far it has--- to evalue the argument.-data Box = Box Any--#if SIZEOF_VOID_P == 8-type HalfWord = Word32-#else-type HalfWord = Word16-#endif--instance Show Box where--- From libraries/base/GHC/Ptr.lhs- showsPrec _ (Box a) rs =- -- unsafePerformIO (print "↓" >> pClosure a) `seq`- pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs- where- ptr = W# (aToWord# a)- tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)- addr = ptr - tag- -- want 0s prefixed to pad it out to a fixed length.- pad_out ls =- '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls---- | Boxes can be compared, but this is not pure, as different heap objects can,--- after garbage collection, become the same object.-areBoxesEqual :: Box -> Box -> IO Bool-areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of- 0# -> return False- _ -> return True---{-|- This takes an arbitrary value and puts it into a box. Note that calls like-- > asBox (head list)-- will put the thunk \"head list\" into the box, /not/ the element at the head- of the list. For that, use careful case expressions:-- > case list of x:_ -> asBox x--}-asBox :: a -> Box-asBox x = Box (unsafeCoerce# x)--{-- StgInfoTable parsing derived from ByteCodeItbls.lhs- Removed the code parameter for now- Replaced Type by an enumeration- Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE- -}--{-| This is a somewhat faithful representation of an info table. See- <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>- for more details on this data structure. Note that the 'Storable' instance- provided here does _not_ support writing.- -}-data StgInfoTable = StgInfoTable {- ptrs :: HalfWord,- nptrs :: HalfWord,- tipe :: ClosureType,- srtlen :: HalfWord- }- deriving (Show)+-- Deriving for Functor, Foldable and Traversable is missing in GHC 8.6+-- will be available in GHC 8.8+deriving instance Functor GenClosure+deriving instance Foldable GenClosure+deriving instance Traversable GenClosure instance Storable StgInfoTable where @@ -173,10 +116,12 @@ srtlen' <- load return StgInfoTable {+ entry = Nothing, -- Storable instance needed for EntryFunPtr!! ptrs = ptrs', nptrs = nptrs', tipe = toEnum (fromIntegral (tipe'::HalfWord)),- srtlen = srtlen'+ srtlen = srtlen',+ code = Nothing -- Storable instance needed for ItblCodes } fieldSz :: Storable b => (a -> b) -> a -> Int@@ -197,254 +142,8 @@ sizeOfPointee addr = sizeOf (typeHack addr) where typeHack = undefined :: Ptr a -> a -{-- Data Type representing Closures- -} --{-| A closure type enumeration, in order matching the actual value on the heap.- Needs to be synchronized with- <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>- -}-data ClosureType =- INVALID_OBJECT- | CONSTR- | CONSTR_1_0- | CONSTR_0_1- | CONSTR_2_0- | CONSTR_1_1- | CONSTR_0_2-#if defined(GHC_8_0)- | CONSTR_STATIC- | CONSTR_NOCAF_STATIC-#else- | CONSTR_NOCAF-#endif- | 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-#if defined(GHC_8_0)- | IND_PERM-#endif- | IND_STATIC- | RET_BCO- | RET_SMALL- | RET_BIG- | RET_FUN- | UPDATE_FRAME- | CATCH_FRAME- | UNDERFLOW_FRAME- | STOP_FRAME- | BLOCKING_QUEUE- | BLACKHOLE- | MVAR_CLEAN- | MVAR_DIRTY- | TVAR- | 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- | PRIM- | MUT_PRIM- | TSO- | STACK- | TREC_CHUNK- | ATOMICALLY_FRAME- | CATCH_RETRY_FRAME- | CATCH_STM_FRAME- | WHITEHOLE- | SMALL_MUT_ARR_PTRS_CLEAN- | SMALL_MUT_ARR_PTRS_DIRTY- | SMALL_MUT_ARR_PTRS_FROZEN0- | SMALL_MUT_ARR_PTRS_FROZEN-#if defined(GHC_8_2)- | COMPACT_NFDATA-#endif- deriving (Show, Eq, Enum, Bounded, Ord)--{-| This is the main data type of this module, representing a Haskell value on- the heap. This reflects- <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>-- The data type is parametrized by the type to store references in, which- is usually a 'Box' with appropriate type synonym 'Closure'.- -}-data GenClosure b =- ConsClosure {- info :: StgInfoTable- , ptrArgs :: [b]- , dataArgs :: [Word]- , pkg :: String- , modl :: String- , name :: String- } |- ThunkClosure {- info :: StgInfoTable- , ptrArgs :: [b]- , dataArgs :: [Word]- } |- SelectorClosure {- info :: StgInfoTable- , selectee :: b- } |- IndClosure {- info :: StgInfoTable- , indirectee :: b- } |- BlackholeClosure {- info :: StgInfoTable- , indirectee :: b- } |- -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported- -- functions fun actually find the name here.- -- At least the other direction works via "lookupSymbol- -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)- APClosure {- info :: StgInfoTable- , arity :: HalfWord- , n_args :: HalfWord- , fun :: b- , payload :: [b]- } |- PAPClosure {- info :: StgInfoTable- , arity :: HalfWord- , n_args :: HalfWord- , fun :: b- , payload :: [b]- } |- APStackClosure {- info :: StgInfoTable- , fun :: b- , payload :: [b]- } |- BCOClosure {- info :: StgInfoTable- , instrs :: b- , literals :: b- , bcoptrs :: b- , arity :: HalfWord- , size :: HalfWord- , bitmap :: Word- } |- ArrWordsClosure {- info :: StgInfoTable- , bytes :: Word- , arrWords :: [Word]- } |- MutArrClosure {- info :: StgInfoTable- , mccPtrs :: Word- , mccSize :: Word- , mccPayload :: [b]- -- Card table ignored- } |- MutVarClosure {- info :: StgInfoTable- , var :: b- } |- MVarClosure {- info :: StgInfoTable- , queueHead :: b- , queueTail :: b- , value :: b- } |- FunClosure {- info :: StgInfoTable- , ptrArgs :: [b]- , dataArgs :: [Word]- } |- BlockingQueueClosure {- info :: StgInfoTable- , link :: b- , blackHole :: b- , owner :: b- , queue :: b- } |- OtherClosure {- info :: StgInfoTable- , hvalues :: [b]- , rawWords :: [Word]- } |- UnsupportedClosure {- info :: StgInfoTable- }- deriving (Show, Functor, Foldable, Traversable)---type Closure = GenClosure Box---- | For generic code, this function returns all referenced closures.-allPtrs :: GenClosure b -> [b]-allPtrs (ConsClosure {..}) = ptrArgs-allPtrs (ThunkClosure {..}) = ptrArgs-allPtrs (SelectorClosure {..}) = [selectee]-allPtrs (IndClosure {..}) = [indirectee]-allPtrs (BlackholeClosure {..}) = [indirectee]-allPtrs (APClosure {..}) = fun:payload-allPtrs (PAPClosure {..}) = fun:payload-allPtrs (APStackClosure {..}) = fun:payload-allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]-allPtrs (ArrWordsClosure {..}) = []-allPtrs (MutArrClosure {..}) = mccPayload-allPtrs (MutVarClosure {..}) = [var]-allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]-allPtrs (FunClosure {..}) = ptrArgs-allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]-allPtrs (OtherClosure {..}) = hvalues-allPtrs (UnsupportedClosure {..}) = []---#ifdef PRIM_SUPPORTS_ANY-foreign import prim "aToWordzh" aToWord# :: Any -> Word#-foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)-foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#-#else--- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was--- accepted---- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#-foreign import prim "slurpClosurezh" slurpClosure'# :: Word# -> (# Addr#, ByteArray#, Array# b #)--foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#---- This is a datatype that has the same layout as Ptr, so that by--- unsafeCoerce'ing, we obtain the Addr of the wrapped value-data Ptr' a = Ptr' a--aToWord# :: Any -> Word#-aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr--slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)-slurpClosure# a = slurpClosure'# (aToWord# a)--reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#-reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)-#endif----pClosure x = do--- getClosure x >>= print+foreign import prim "stg_unpackClosurezh" unpackClosurezh# :: Any -> (# Addr#, ByteArray#, Array# b #) -- | This returns the raw representation of the given argument. The second -- component of the triple are the words on the heap, and the third component@@ -453,7 +152,7 @@ -- 'Box' will still point to the correct value. getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box]) getClosureRaw x =- case slurpClosure# (unsafeCoerce# x) of+ case unpackClosurezh# (unsafeCoerce# x) of (# iptr, dat, ptrs #) -> do let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]@@ -473,200 +172,16 @@ where g (I# i#) = case indexArray# arr# i# of (# e #) -> f e --- 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, String, String)-dataConInfoPtrToNames ptr = do- conDescAddress <- getConDescAddress ptr- wl <- peekArray0 0 conDescAddress- 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- offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))- return $ (ptr' `plusPtr` stdInfoTableSizeB)- `plusPtr` (fromIntegral (offsetToString :: Word))- -- This is code for !ghciTablesNextToCode:- {-- | otherwise = peek . intPtrToPtr- . (+ fromIntegral- stdInfoTableSizeB)- . ptrToIntPtr $ ptr- -}-- -- hmmmmmm. Is there any way to tell this?- opt_SccProfilingOn = False-- stdInfoTableSizeW :: Int- -- The size of a standard info table varies with profiling/ticky etc,- -- so we can't get it from Constants- -- It must vary in sync with mkStdInfoTable- stdInfoTableSizeW- = size_fixed + size_prof- where- size_fixed = 2 -- layout, type- size_prof | opt_SccProfilingOn = 2- | otherwise = 0-- 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--- 'asBox' apply.-getClosureData :: a -> IO Closure-getClosureData x = do- (iptr, wds, ptrs) <- getClosureRaw x- itbl <- peek iptr- case tipe itbl of- t | t >= CONSTR-#if defined(GHC_8_0)- , t <= CONSTR_NOCAF_STATIC-#else- , t <= CONSTR_NOCAF-#endif- -> do- (pkg, modl, name) <- dataConInfoPtrToNames iptr- if modl == "ByteCodeInstr" && name == "BreakInfo"- then return $ UnsupportedClosure itbl- else 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)-- t | t >= FUN && t <= FUN_STATIC -> do- return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)-- AP -> do- unless (length ptrs >= 1) $- fail "Expected at least 1 ptr argument to AP"- unless (length wds >= 3) $- fail "Expected at least 3 raw words to AP"- return $ APClosure itbl- (fromIntegral $ wds !! 2)- (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))- (head ptrs) (tail ptrs)-- PAP -> do- unless (length ptrs >= 1) $- fail "Expected at least 1 ptr argument to PAP"- unless (length wds >= 3) $- fail "Expected at least 3 raw words to AP"- return $ PAPClosure itbl- (fromIntegral $ wds !! 2)- (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))- (head ptrs) (tail ptrs)-- AP_STACK -> do- unless (length ptrs >= 1) $- fail "Expected at least 1 ptr argument to AP_STACK"- return $ APStackClosure itbl (head ptrs) (tail ptrs)-- THUNK_SELECTOR -> do- unless (length ptrs >= 1) $- fail "Expected at least 1 ptr argument to THUNK_SELECTOR"- return $ SelectorClosure itbl (head ptrs)-- IND -> do- unless (length ptrs >= 1) $- fail "Expected at least 1 ptr argument to IND"- return $ IndClosure itbl (head ptrs)- IND_STATIC -> do- unless (length ptrs >= 1) $- fail "Expected at least 1 ptr argument to IND_STATIC"- return $ IndClosure itbl (head ptrs)- BLACKHOLE -> do- unless (length ptrs >= 1) $- fail "Expected at least 1 ptr argument to BLACKHOLE"- return $ BlackholeClosure itbl (head ptrs)-- BCO -> do- unless (length ptrs >= 3) $- fail $ "Expected at least 3 ptr argument to BCO, found " ++ show (length ptrs)- unless (length wds >= 6) $- fail $ "Expected at least 6 words to BCO, found " ++ show (length wds)- return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)- (fromIntegral $ wds !! 4)- (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))- (wds !! 5)-- ARR_WORDS -> do- unless (length wds >= 2) $- fail $ "Expected at least 2 words to ARR_WORDS, found " ++ show (length wds)- return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)-- t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 -> do- unless (length wds >= 3) $- fail $ "Expected at least 3 words to MUT_ARR_PTRS_FROZEN0 found " ++ show (length wds)- return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs-- t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->- return $ MutVarClosure itbl (head ptrs)-- t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do- unless (length ptrs >= 3) $- fail $ "Expected at least 3 ptrs to MVAR, found " ++ show (length ptrs)- return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)-- BLOCKING_QUEUE ->- return $ OtherClosure itbl ptrs wds- -- return $ BlockingQueueClosure itbl- -- (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)-- -- return $ OtherClosure itbl ptrs wds- --- _ ->- return $ UnsupportedClosure itbl---- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.-getBoxedClosureData :: Box -> IO Closure-getBoxedClosureData (Box a) = getClosureData a-- isChar :: GenClosure b -> Maybe Char-isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))+isChar (ConstrClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch)) isChar _ = Nothing isCons :: GenClosure b -> Maybe (b, b)-isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)+isCons (ConstrClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t) isCons _ = Nothing isTup :: GenClosure b -> Maybe [b]-isTup (ConsClosure { dataArgs = [], ..}) =+isTup (ConstrClosure { dataArgs = [], ..}) = if length name >= 3 && head name == '(' && last name == ')' && all (==',') (tail (init name))@@ -675,7 +190,7 @@ isNil :: GenClosure b -> Bool-isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True+isNil (ConstrClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True isNil _ = False -- | A pretty-printer that tries to generate valid Haskell for evalutated data.@@ -691,7 +206,7 @@ showBox 5 h ++ " : " ++ showBox 4 t _ | Just vs <- isTup c -> "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"- ConsClosure {..} -> app $+ ConstrClosure {..} -> app $ name : map (showBox 10) ptrArgs ++ map show dataArgs ThunkClosure {..} -> app $ "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs@@ -708,11 +223,12 @@ APStackClosure {..} -> app $ map (showBox 10) $ fun : payload BCOClosure {..} -> app- ["_bco"]+ ["_bco", showBox 10 bcoptrs] ArrWordsClosure {..} -> app ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ] MutArrClosure {..} -> app- ["toMutArray", "("++show (length mccPayload) ++ " ptrs)", intercalate "," (shorten (map (showBox 10) mccPayload))]+ --["toMutArray", "("++show (length mccPayload) ++ " ptrs)", intercalate "," (shorten (map (showBox 10) mccPayload))]+ ["[", intercalate ", " (shorten (map (showBox 10) mccPayload)),"]"] MutVarClosure {..} -> app $ ["_mutVar", (showBox 10) var] MVarClosure {..} -> app $@@ -721,6 +237,20 @@ "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs) BlockingQueueClosure {..} -> "_blockingQueue"+ IntClosure {..} -> app+ ["Int", show intVal]+ WordClosure {..} -> app+ ["Word", show wordVal]+ Int64Closure {..} -> app+ ["Int64", show int64Val]+ Word64Closure {..} -> app+ ["Word64", show word64Val]+ AddrClosure {..} -> app+ ["Addr", show addrVal]+ FloatClosure {..} -> app+ ["Float", show floatVal]+ DoubleClosure {..} -> app+ ["Double", show doubleVal] OtherClosure {..} -> "_other" UnsupportedClosure {..} ->@@ -1024,7 +554,7 @@ -- second parameter adds external references, commonly @[heapGraphRoot]@. boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex] boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $- roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m)+ roots ++ concatMap (catMaybes . allClosures . hgeClosure) (M.elems m) -- | This function integrates the disassembler in "GHC.Disassembler". The first -- argument should a function that dereferences the pointer in the closure to a@@ -1032,6 +562,8 @@ -- -- If any of these return 'Nothing', then 'disassembleBCO' returns Nothing disassembleBCO :: (a -> Maybe (GenClosure b)) -> GenClosure a -> Maybe [BCI b]+-- Disable the assembler+disassembleBCO _ _ | id True = Nothing disassembleBCO deref (BCOClosure {..}) = do opsC <- deref instrs litsC <- deref literals@@ -1054,11 +586,3 @@ braceize :: [String] -> String braceize [] = "" braceize xs = "{" ++ intercalate "," xs ++ "}"---- This used to be available via GHC.Constants-#include "MachDeps.h"-wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int-wORD_SIZE = SIZEOF_HSWORD-tAG_MASK = (1 `shift` TAG_BITS) - 1-wORD_SIZE_IN_BITS = WORD_SIZE_IN_BITS-
src/GHC/HeapView/Debug.hs view
@@ -38,7 +38,7 @@ isCC <- isCharCons c unless isCC $ do modifyIORef seenRef ((b,prefix):)- forM_ (zip [(0::Int)..] (allPtrs c)) $ \(n,box) ->+ forM_ (zip [(0::Int)..] (allClosures c)) $ \(n,box) -> go seenRef (prefix ++ [n]) box walkPrefix :: [Int] -> a -> IO Box@@ -47,7 +47,7 @@ go [] a = return a go (x:xs) a = do c <- getBoxedClosureData a- walkPrefix xs (allPtrs c !! x)+ walkPrefix xs (allClosures c !! x) findM :: (a -> IO Bool) -> [a] -> IO (Maybe a)@@ -61,9 +61,9 @@ isCharCons _ = return False isCons :: GenClosure b -> Maybe (b, b)-isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)+isCons (ConstrClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t) isCons _ = Nothing isChar :: GenClosure b -> Maybe Char-isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))+isChar (ConstrClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch)) isChar _ = Nothing