diff --git a/Demo.hs b/Demo.hs --- a/Demo.hs +++ b/Demo.hs @@ -31,7 +31,6 @@ putStrLn "> args <- map length `fmap` getArgs" putStrLn $ "gives us at " ++ show (asBox args) ++ " a static, but at compile time unknown list:" getClosureData args >>= printInd - getClosureData [] >>= printInd putStrLn $ "And now we have, at " ++ show (asBox x) ++ ", the concatenation of them, but unevaluated:" putStrLn "> let x = l ++ l2 ++ args" putStrLn "The thunk keeps a reference to l2 and args, but not l, as that is at a static address, unless you are running this in GHCi:" @@ -59,7 +58,7 @@ x `seq` return () putStrLn $ "So it is unevaluated. Let us evaluate it using seq. Now we have, still at " ++ show (asBox x) ++ ":" getClosureData x >>= printInd - IndClosure {indirectee = target} <- getClosureData x + target <- indirectee `fmap` getClosureData x putStrLn $ "The thunk was replaced by an indirection. If we look at the target, " ++ show target ++ ", we see that it is a newly created cons-cell referencing the original location of x:" getBoxedClosureData target >>= printInd performGC diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} + +import GHC.Exts +import GHC.HeapView +import Control.DeepSeq + +import System.Environment +import System.Mem + +import Control.Monad + +l = [1,2,3] + +main = do + args <- map length `fmap` getArgs + let l2 = 4:l + (l ++ l2 ++ args) `deepseq` return () + + let x = l ++ l2 ++ args + performGC + cl <- getClosureData l + case cl of ConsClosure {} -> return () + unless (name cl == ":") $ do + fail "Wrong name" + + cl <- getClosureData l2 + case cl of ConsClosure {} -> return () + eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox l) + unless eq $ do + fail "Doesnt reference l" + + cl <- getClosureData args + unless (tipe (info cl) == CONSTR_NOCAF_STATIC) $ do + fail "Not a CONSTR_NOCAF_STATIC" + + cl <- getClosureData x + unless (tipe (info cl) == THUNK_2_0) $ do + fail "Not a THUNK_2_0" + + + let !(I# m) = length args + 42 + let !(I# m') = length args + 23 + let f = \x n -> take (I# m + I# x) n ++ args + t = f m' l2 + + cl <- getClosureData f + unless (tipe (info cl) == FUN_1_1) $ do + fail "Not a FUN_1_1" + unless (dataArgs cl == [42]) $ do + fail "Wrong data arg" + cl <- getClosureData t + unless (tipe (info cl) == THUNK) $ do + fail "Not a THUNK" + unless (dataArgs cl == [23]) $ do + fail "Wrong data arg" + eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox f) + unless eq $ do + fail "t doesnt reference f" + + let x = id (:) () x + x `seq` return () + performGC + cl <- getClosureData x + case cl of ConsClosure {} -> return () + eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox x) + unless eq $ do + fail "x doesnt reference itself" diff --git a/cbits/HeapView.c b/cbits/HeapView.c --- a/cbits/HeapView.c +++ b/cbits/HeapView.c @@ -62,7 +62,9 @@ [RET_BCO] = "RET_BCO", [RET_SMALL] = "RET_SMALL", [RET_BIG] = "RET_BIG", +#ifndef GHC_7_7 [RET_DYN] = "RET_DYN", +#endif [RET_FUN] = "RET_FUN", [UPDATE_FRAME] = "UPDATE_FRAME", [CATCH_FRAME] = "CATCH_FRAME", @@ -72,6 +74,9 @@ [BLOCKING_QUEUE] = "BLOCKING_QUEUE", [MVAR_CLEAN] = "MVAR_CLEAN", [MVAR_DIRTY] = "MVAR_DIRTY", +#ifdef GHC_7_7 + [TVAR] = "TVAR", +#endif [ARR_WORDS] = "ARR_WORDS", [MUT_ARR_PTRS_CLEAN] = "MUT_ARR_PTRS_CLEAN", [MUT_ARR_PTRS_DIRTY] = "MUT_ARR_PTRS_DIRTY", diff --git a/cbits/HeapViewPrim.cmm b/cbits/HeapViewPrim.cmm --- a/cbits/HeapViewPrim.cmm +++ b/cbits/HeapViewPrim.cmm @@ -1,5 +1,60 @@ #include "Cmm.h" +#if 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; @@ -55,3 +110,4 @@ 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.1 +Version: 0.5.2 Synopsis: Extract the heap representation of Haskell values and thunks Description: This library provides functions to introspect the Haskell heap, for example @@ -42,7 +42,8 @@ License-file: LICENSE Author: Joachim Breitner, Dennis Felsing Maintainer: Joachim Breitner -Copyright: 2012-2013 Joachim Breitner +Copyright: 2012-2014 Joachim Breitner +bug-reports: https://github.com/nomeata/ghc-heap-view Category: Debug, GHC Build-type: Custom Cabal-version: >=1.14 @@ -53,6 +54,8 @@ Description: The used GHC supports Any as an argument to foreign prim functions (GHC ticket #5931) Default: False +Flag ghc_7_7 + Library Default-Language: Haskell2010 Exposed-modules: @@ -61,20 +64,35 @@ GHC.Disassembler GHC.HeapView.Debug Build-depends: - base >= 4.5 && < 4.7, + base >= 4.5 && < 4.8, containers, transformers, template-haskell, bytestring >= 0.10, - binary, - ghc + binary + if flag(ghc_7_7) + build-depends: ghc >= 7.7 + cc-options: -DGHC_7_7 + cpp-options: -DGHC_7_7 + else + build-depends: ghc < 7.7 C-Sources: cbits/HeapView.c cbits/HeapViewPrim.cmm Hs-source-dirs: src/ Ghc-options: -Wall + default-language: Haskell2010 if flag(prim-supports-any) cpp-options: -DPRIM_SUPPORTS_ANY + +test-suite Test + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base, ghc-heap-view, deepseq + default-language: Haskell2010 + Ghc-options: -O0 + source-repository head - type: darcs - location: http://darcs.nomeata.de/ghc-heap-view/ + type: git + location: git://git.nomeata.de/ghc-heap-view.git + subdir: Cabal diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -56,7 +56,6 @@ import GHC.Arr (Array(..)) -import GHC.Constants ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS ) import Foreign hiding ( unsafePerformIO, void ) import Numeric ( showHex ) @@ -242,7 +241,9 @@ | RET_BCO | RET_SMALL | RET_BIG +#ifndef GHC_7_7 | RET_DYN +#endif | RET_FUN | UPDATE_FRAME | CATCH_FRAME @@ -252,6 +253,9 @@ | BLACKHOLE | MVAR_CLEAN | MVAR_DIRTY +#ifdef GHC_7_7 + | TVAR +#endif | ARR_WORDS | MUT_ARR_PTRS_CLEAN | MUT_ARR_PTRS_DIRTY @@ -553,29 +557,43 @@ t | t >= FUN && t <= FUN_STATIC -> do return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds) - AP -> + AP -> do + unless (length ptrs >= 1) $ + fail "Expected at least 1 ptr argument to AP" return $ APClosure itbl (fromIntegral $ wds !! 2) (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2)) (head ptrs) (tail ptrs) - PAP -> + PAP -> do + unless (length ptrs >= 1) $ + fail "Expected at least 1 ptr argument to PAP" return $ PAPClosure itbl (fromIntegral $ wds !! 2) (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2)) (head ptrs) (tail ptrs) - AP_STACK -> + 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 -> + THUNK_SELECTOR -> do + unless (length ptrs >= 1) $ + fail "Expected at least 1 ptr argument to THUNK_SELECTOR" return $ SelectorClosure itbl (head ptrs) - IND -> + IND -> do + unless (length ptrs >= 1) $ + fail "Expected at least 1 ptr argument to IND" return $ IndClosure itbl (head ptrs) - IND_STATIC -> + IND_STATIC -> do + unless (length ptrs >= 1) $ + fail "Expected at least 1 ptr argument to IND_STATIC" return $ IndClosure itbl (head ptrs) - BLACKHOLE -> + BLACKHOLE -> do + unless (length ptrs >= 1) $ + fail "Expected at least 1 ptr argument to BLACKHOLE" return $ BlackholeClosure itbl (head ptrs) BCO -> @@ -1008,3 +1026,11 @@ 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 +