ghc-heap-view 0.5.1 → 0.5.2

raw patch · 6 files changed

+188/−17 lines, 6 filesdep +deepseqdep +ghc-heap-viewdep ~basedep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, ghc-heap-view

Dependency ranges changed: base, ghc

API changes (from Hackage documentation)

Files

• Demo.hs +1/−2
• Test.hs +67/−0
• cbits/HeapView.c +5/−0
• cbits/HeapViewPrim.cmm +56/−0
• ghc-heap-view.cabal +25/−7
• src/GHC/HeapView.hs +34/−8

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

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

@@ -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",

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

@@ -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 <mail@joachim-breitner.de>-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

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