diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 () diff --git a/cbits/HeapView.c b/cbits/HeapView.c deleted file mode 100644 --- a/cbits/HeapView.c +++ /dev/null @@ -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; ipayload[i] = ptrs[i]; - } - - return arr; -} diff --git a/cbits/HeapViewPrim.cmm b/cbits/HeapViewPrim.cmm deleted file mode 100644 --- a/cbits/HeapViewPrim.cmm +++ /dev/null @@ -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); -} diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal --- a/ghc-heap-view.cabal +++ b/ghc-heap-view.cabal @@ -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 (). +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 -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 diff --git a/src/GHC/AssertNF.hs b/src/GHC/AssertNF.hs --- a/src/GHC/AssertNF.hs +++ b/src/GHC/AssertNF.hs @@ -2,7 +2,7 @@ {-| Module : GHC.AssertNF -Copyright : (c) 2013 Joachim Breitner +Copyright : (c) 2013-2019 Joachim Breitner License : BSD3 Maintainer : Joachim Breitner @@ -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 diff --git a/src/GHC/Disassembler.hs b/src/GHC/Disassembler.hs --- a/src/GHC/Disassembler.hs +++ b/src/GHC/Disassembler.hs @@ -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) diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -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 @@ -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 - - 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 - - -} -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 - - - 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 - diff --git a/src/GHC/HeapView/Debug.hs b/src/GHC/HeapView/Debug.hs --- a/src/GHC/HeapView/Debug.hs +++ b/src/GHC/HeapView/Debug.hs @@ -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