diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash, BangPatterns #-} +{-# LANGUAGE MagicHash, BangPatterns, CPP #-} import GHC.Exts import GHC.HeapView @@ -27,7 +27,11 @@ 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) diff --git a/cbits/HeapView.c b/cbits/HeapView.c --- a/cbits/HeapView.c +++ b/cbits/HeapView.c @@ -6,9 +6,9 @@ } static void -gtc_heap_view_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, uint32_t size ) { - nat i, j, b; + uint32_t i, j, b; StgWord bitmap; b = 0; @@ -35,8 +35,12 @@ [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", @@ -57,18 +61,13 @@ [PAP] = "PAP", [AP_STACK] = "AP_STACK", [IND] = "IND", -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if !MIN_VERSION_GLASGOW_HASKELL(8,1,0,0) +#if defined(GHC_8_0) [IND_PERM] = "IND_PERM", #endif -#endif [IND_STATIC] = "IND_STATIC", [RET_BCO] = "RET_BCO", [RET_SMALL] = "RET_SMALL", [RET_BIG] = "RET_BIG", -#if !defined(GHC_7_7) && !defined(GHC_8_0) - [RET_DYN] = "RET_DYN", -#endif [RET_FUN] = "RET_FUN", [UPDATE_FRAME] = "UPDATE_FRAME", [CATCH_FRAME] = "CATCH_FRAME", @@ -78,9 +77,6 @@ [BLOCKING_QUEUE] = "BLOCKING_QUEUE", [MVAR_CLEAN] = "MVAR_CLEAN", [MVAR_DIRTY] = "MVAR_DIRTY", -#if defined(GHC_7_7) || defined(GHC_8_0) - [TVAR] = "TVAR", -#endif [ARR_WORDS] = "ARR_WORDS", [MUT_ARR_PTRS_CLEAN] = "MUT_ARR_PTRS_CLEAN", [MUT_ARR_PTRS_DIRTY] = "MUT_ARR_PTRS_DIRTY", @@ -97,13 +93,20 @@ [ATOMICALLY_FRAME] = "ATOMICALLY_FRAME", [CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME", [CATCH_STM_FRAME] = "CATCH_STM_FRAME", - [WHITEHOLE] = "WHITEHOLE" + [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; - StgFunInfoTable *fun_info; + const StgFunInfoTable *fun_info; fun_info = get_fun_itbl(UNTAG_CLOSURE(fun)); // ASSERT(fun_info->i.type != PAP); @@ -150,7 +153,7 @@ StgClosure **end; StgClosure **ptr; - StgInfoTable *info = get_itbl(closure); + const StgInfoTable *info = get_itbl(closure); StgThunkInfoTable *thunk_info; StgFunInfoTable *fun_info; @@ -170,8 +173,12 @@ 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: @@ -234,10 +241,8 @@ break; case IND: -#ifdef MIN_VERSION_GLASGOW_HASKELL -#if !MIN_VERSION_GLASGOW_HASKELL(8,1,0,0) +#if defined(GHC_8_0) case IND_PERM: -#endif #endif case IND_STATIC: case BLACKHOLE: diff --git a/cbits/HeapViewPrim.cmm b/cbits/HeapViewPrim.cmm --- a/cbits/HeapViewPrim.cmm +++ b/cbits/HeapViewPrim.cmm @@ -1,7 +1,5 @@ #include "Cmm.h" -#if GHC_8_0 - aToWordzh (P_ clos) { return (clos); @@ -53,115 +51,3 @@ clos2 = UNTAG(clos2); return (clos1 == clos2); } - -#elif GHC_7_7 - -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_StgArrWords + 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); - StgArrWords_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); -} - -#else -aToWordzh -{ - W_ clos; - clos = R1; - RET_N(clos); -} - -// Taken from stg_unpackClosurezh in rts/PrimOps.cmm -slurpClosurezh -{ -/* args: R1 = closure to analyze */ - - W_ clos, len; - clos = UNTAG(R1); - - W_ info; - info = %GET_STD_INFO(clos); - - (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") [R1]; - - W_ data_arr_sz; - data_arr_sz = SIZEOF_StgArrWords + WDS(len); - - ALLOC_PRIM (data_arr_sz, R1_PTR, slurpClosurezh); - - W_ data_arr; - data_arr = Hp - data_arr_sz + WDS(1); - - SET_HDR(data_arr, stg_ARR_WORDS_info, CCCS); - StgArrWords_bytes(data_arr) = WDS(len); - W_ p; - p = 0; -for: - if(p < len) { - // W_[BYTE_ARR_CTS(data_arr) + WDS(p)] = StgClosure_payload(clos, p); - W_[BYTE_ARR_CTS(data_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") []; - - RET_NPP(info, data_arr, ptrArray); -} - -reallyUnsafePtrEqualityUpToTag -{ - W_ clos1; - W_ clos2; - clos1 = UNTAG(R1); - clos2 = UNTAG(R2); - RET_N(clos1 == clos2); -} -#endif 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.5.9 +Version: 0.5.10 Synopsis: Extract the heap representation of Haskell values and thunks Description: This library provides functions to introspect the Haskell heap, for example @@ -48,7 +48,7 @@ bug-reports: https://github.com/nomeata/ghc-heap-view Category: Debug, GHC Build-type: Custom -Cabal-version: >=1.14 +Cabal-version: >=1.23 Extra-source-files: Demo.hs data-files: ghci @@ -56,10 +56,15 @@ Description: The used GHC supports Any as an argument to foreign prim functions (GHC ticket #5931) Default: False -Flag ghc_7_7 - Flag ghc_8_0 +Flag ghc_8_2 + +custom-setup + setup-depends: base + setup-depends: filepath + setup-depends: Cabal >= 1.24 && < 2.1 + Library Default-Language: Haskell2010 Exposed-modules: @@ -68,24 +73,25 @@ GHC.Disassembler GHC.HeapView.Debug Build-depends: - base >= 4.5 && < 4.10, + base >= 4.5 && < 4.11, containers, transformers, template-haskell, bytestring >= 0.10, binary - if flag(ghc_7_7) - build-depends: ghc >= 7.7 && < 8 - cc-options: -DGHC_7_7 - cpp-options: -DGHC_7_7 + 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_0) - build-depends: ghc >= 8 - cc-options: -DGHC_8_0 - cpp-options: -DGHC_8_0 + if flag(ghc_8_2) + build-depends: ghc >= 8.2 && < 8.4 + cc-options: -DGHC_8_2 + cpp-options: -DGHC_8_2 else - build-depends: ghc < 7.7 + build-depends: ghc == 0.0 + C-Sources: cbits/HeapView.c cbits/HeapViewPrim.cmm Hs-source-dirs: src/ diff --git a/src/GHC/Disassembler.hs b/src/GHC/Disassembler.hs --- a/src/GHC/Disassembler.hs +++ b/src/GHC/Disassembler.hs @@ -16,7 +16,6 @@ import Data.Foldable ( Foldable ) import Data.Traversable ( Traversable ) import Control.Applicative ((<$>)) -import Data.Monoid #include "ghcautoconf.h" #include "rts/Bytecodes.h" diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -214,8 +214,12 @@ | 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 @@ -236,14 +240,13 @@ | PAP | AP_STACK | IND +#if defined(GHC_8_0) | IND_PERM +#endif | IND_STATIC | RET_BCO | RET_SMALL | RET_BIG -#if !defined(GHC_7_7) && !defined(GHC_8_0) - | RET_DYN -#endif | RET_FUN | UPDATE_FRAME | CATCH_FRAME @@ -253,9 +256,7 @@ | BLACKHOLE | MVAR_CLEAN | MVAR_DIRTY -#if defined(GHC_7_7) || defined(GHC_8_0) | TVAR -#endif | ARR_WORDS | MUT_ARR_PTRS_CLEAN | MUT_ARR_PTRS_DIRTY @@ -273,11 +274,12 @@ | CATCH_RETRY_FRAME | CATCH_STM_FRAME | WHITEHOLE -#if defined(GHC_8_0) | 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) @@ -551,7 +553,13 @@ (iptr, wds, ptrs) <- getClosureRaw x itbl <- peek iptr case tipe itbl of - t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do + 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