--- /dev/null
+{-# LANGUAGE MagicHash, BangPatterns #-}
+
+import GHC.Exts
+import GHC.HeapView
+import Control.DeepSeq
+
+import System.Environment
+import System.Mem
+
+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
+ putStrLn "ghc-heap-view-demo"
+ putStrLn "Here are a few different lists."
+ putStrLn $ "The first one, l, found at " ++ show (asBox l) ++ " is a module-level constant, and fully evaluated:"
+ getClosureData l >>= print
+ putStrLn $ "The second one, l2, found at " ++ show (asBox l2) ++ " is locally defined as l2 = 4:l. See how the cons-cell references l!"
+ getClosureData l2 >>= print
+ putStrLn $ "And here is the list args (" ++ show (asBox args) ++ ") that is not known at compiletime, as it depends on the command line arguemnts:"
+ getClosureData args >>= print
+ putStrLn $ "And now we have, at " ++ show (asBox x) ++ ", the concatenation of them, but unevaluated. The thunk keeps a reference to l2 and args, but not l, as that is at a static address:"
+ getClosureData x >>= print
+
+ putStrLn ""
+ putStrLn "Now to some more closure types:"
+ 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
+ putStrLn $ "The following value f (" ++ show (asBox f) ++ ") is a locally defined function that has args as a free variable, as well as an unboxed integer (42):"
+ getClosureData f >>= print
+ putStrLn "And the following is a thunk that applies f (also references here) to an unboxed value (23) and l2:"
+ getClosureData t >>= print
+
+ putStrLn ""
+ putStrLn "Here is the standard example for self reference:"
+ putStrLn "> let x = id (:) () x"
+ let x = id (:) () x
+ putStrLn $ "This is what x (" ++ show (asBox x) ++ ") looks like, at least without -O:"
+ getClosureData x >>= print
+ x `seq` return ()
+ putStrLn $ "So it is unevaluated. Let us evaluate it using seq. Now we have, still at " ++ show (asBox x) ++ ":"
+ getClosureData x >>= print
+ IndClosure {indirectee = target} <- 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:"
+ getHValueClosureData target >>= print
+ performGC
+ putStrLn $ "After running the garbage collector (performGC), we find that the address of x is now " ++ show (asBox x) ++ " and that the self-reference is without indirections:"
+ getClosureData x >>= print
+
+
+recurse :: Int -> Box -> IO ()
+recurse m = go 0
+ where go i b = if i >= m then return () else do
+ putStrLn $ ind ++ show b
+ c <- getHValueClosureData b
+ putStrLn $ ind ++ show c
+ mapM_ (go (succ i)) (allPtrs c)
+ where
+ ind = concat $ replicate i " "
--- /dev/null
+Copyright (c)2012, Joachim Breitner
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Joachim Breitner nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /dev/null
+import Distribution.Simple
+main = defaultMain
--- /dev/null
+#include "Rts.h"
+
+StgWord closureSize(StgClosure *closure) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+ return closure_sizeW(closure);
+}
+
+static void
+closure_ptrs_in_large_bitmap(StgClosure *ptrs[], StgWord *nptrs, StgClosure **p, StgLargeBitmap *large_bitmap, nat size )
+{
+ nat 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 *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",
+ [CONSTR_STATIC] = "CONSTR_STATIC",
+ [CONSTR_NOCAF_STATIC] = "CONSTR_NOCAF_STATIC",
+ [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",
+ [IND_PERM] = "IND_PERM",
+ [IND_STATIC] = "IND_STATIC",
+ [RET_BCO] = "RET_BCO",
+ [RET_SMALL] = "RET_SMALL",
+ [RET_BIG] = "RET_BIG",
+ [RET_DYN] = "RET_DYN",
+ [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"
+};
+
+
+void closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs, StgClosure *fun, StgClosure **payload, StgWord size) {
+ StgWord bitmap;
+ 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:
+ closure_ptrs_in_large_bitmap(ptrs, nptrs, payload, GET_FUN_LARGE_BITMAP(fun_info), size);
+ break;
+ case ARG_BCO:
+ 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 *closurePtrs(Capability *cap, StgClosure *closure) {
+ ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+
+ StgWord size = 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;
+
+ 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:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ 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;
+ 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;
+ 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:
+ case IND_PERM:
+ 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:
+ for (i = 0; i < ((StgMutArrPtrs *)closure)->ptrs; ++i) {
+ ptrs[nptrs++] = ((StgMutArrPtrs *)closure)->payload[i];
+ }
+ break;
+
+ default:
+ fprintf(stderr,"closurePtrs: Cannot handle type %s yet\n", 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;
+}
--- /dev/null
+#include "Cmm.h"
+
+aToInt
+{
+ W_ clos;
+ clos = R1;
+ RET_N(clos);
+}
+
+slurpClosurezh
+{
+/* args: R1 = closure to analyze */
+// TODO: Consider the absence of ptrs or nonptrs as a special case ?
+
+ W_ clos, len;
+ clos = UNTAG(R1);
+
+ W_ info;
+ info = %GET_STD_INFO(clos);
+
+ (len) = foreign "C" closureSize(clos "ptr") [];
+
+ 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" closurePtrs(MyCapability() "ptr", clos "ptr") [];
+
+ RET_NPP(info, data_arr, ptrArray);
+}
+
--- /dev/null
+Name: ghc-heap-view
+Version: 0.1
+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 eavaluation.
+ .
+ It has been inspired by (and taken code from) the vacuum package and the GHCi
+ debugger, but also allows to investiage thunks and other closures.
+License: BSD3
+License-file: LICENSE
+Author: Joachim Breitner
+Maintainer: Joachim Breitner <mail@joachim-breitner.de>
+Category: Debug, GHC
+Build-type: Simple
+Cabal-version: >=1.2
+Extra-source-files: Demo.hs
+
+Library
+ Exposed-modules: GHC.HeapView
+ Build-depends: base, ghc, integer-gmp, ghc-prim
+ C-Sources: cbits/HeapView.c cbits/HeapViewPrim.cmm
+ Hs-source-dirs: src/
+
--- /dev/null
+{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards #-}
+
+module GHC.HeapView where
+
+import System.IO.Unsafe
+import GHC.Exts
+import GHC.Prim
+import System.Environment
+import GHC.Arr ((!), Array(..), elems)
+
+import Constants ( wORD_SIZE )
+import Util (ghciTablesNextToCode)
+
+import System.Mem
+import System.Mem.StableName
+import Foreign
+import Foreign.C
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Array
+import Numeric ( showHex )
+import Data.Word
+import Data.Bits
+import Data.Char
+import GHC.Integer (wordToInteger)
+import Control.Monad
+
+newtype HValue = HValue Any
+
+-- A Safegard of HValues
+data Box = Box HValue
+
+#include "MachDeps.h"
+
+type HalfWord = Word32
+
+instance Show Box where
+-- From libraries/base/GHC/Ptr.lhs
+ showsPrec _ (Box (HValue any)) rs =
+ -- unsafePerformIO (print "↓" >> pClosure any) `seq`
+ pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
+ where
+ ptr = wordToInteger(int2Word#(aToInt# any))
+ tag = ptr `mod` fromIntegral wORD_SIZE
+ addr = ptr - tag
+ -- want 0s prefixed to pad it out to a fixed length.
+ pad_out ls =
+ '0':'x':(replicate (2*SIZEOF_HSPTR - length ls) '0') ++ ls
+
+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
+ -}
+
+
+data StgInfoTable = StgInfoTable {
+ ptrs :: HalfWord,
+ nptrs :: HalfWord,
+ tipe :: ClosureType,
+ srtlen :: HalfWord
+ }
+ deriving (Show)
+
+instance Storable StgInfoTable where
+
+ sizeOf itbl
+ = sum
+ [
+ if ghciTablesNextToCode then 0 else sizeOf (undefined::HalfWord),
+ fieldSz ptrs itbl,
+ fieldSz nptrs itbl,
+ sizeOf (undefined :: HalfWord),
+ fieldSz srtlen itbl
+ ]
+
+ alignment _
+ = SIZEOF_VOID_P
+
+ poke a0 itbl
+ = error "Storable StgInfoTable is read-only"
+
+ peek a0
+ = runState (castPtr a0)
+ $ do
+ unless ghciTablesNextToCode $ (load :: PtrIO HalfWord) >> return ()
+ ptrs' <- load
+ nptrs' <- load
+ tipe' <- load
+ srtlen' <- load
+ return
+ StgInfoTable {
+ ptrs = ptrs',
+ nptrs = nptrs',
+ tipe = toEnum (fromIntegral (tipe'::HalfWord)),
+ srtlen = srtlen'
+ }
+
+fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
+fieldSz sel x = sizeOf (sel x)
+
+load :: Storable a => PtrIO a
+load = do addr <- advance
+ lift (peek addr)
+
+type PtrIO = State (Ptr Word8) IO
+
+advance :: Storable a => PtrIO (Ptr a)
+advance = State adv where
+ adv addr = case castPtr addr of { addrCast -> return
+ (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
+
+sizeOfPointee :: (Storable a) => Ptr a -> Int
+sizeOfPointee addr = sizeOf (typeHack addr)
+ where typeHack = undefined :: Ptr a -> a
+
+store :: Storable a => a -> PtrIO ()
+store x = do addr <- advance
+ lift (poke addr x)
+
+{-
+ - Embedded StateT, also from ByteCodeItbls
+ -}
+
+newtype State s m a = State (s -> m (s, a))
+
+instance Monad m => Monad (State s m) where
+ return a = State (\s -> return (s, a))
+ State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
+ fail str = State (\_ -> fail str)
+
+lift m = State (\s -> m >>= \a -> return (s, a))
+
+runState :: (Monad m) => s -> State s m a -> m a
+runState s (State m) = m s >>= return . snd
+
+{-
+ - Data Type representing Closures
+ -}
+
+
+data ClosureType =
+ INVALID_OBJECT
+ | CONSTR
+ | CONSTR_1_0
+ | CONSTR_0_1
+ | CONSTR_2_0
+ | CONSTR_1_1
+ | CONSTR_0_2
+ | CONSTR_STATIC
+ | CONSTR_NOCAF_STATIC
+ | 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
+ | IND_PERM
+ | IND_STATIC
+ | RET_BCO
+ | RET_SMALL
+ | RET_BIG
+ | RET_DYN
+ | RET_FUN
+ | UPDATE_FRAME
+ | CATCH_FRAME
+ | UNDERFLOW_FRAME
+ | STOP_FRAME
+ | BLOCKING_QUEUE
+ | BLACKHOLE
+ | MVAR_CLEAN
+ | MVAR_DIRTY
+ | 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
+ deriving (Show, Eq, Enum, Ord)
+
+data Closure =
+ ConsClosure {
+ info :: StgInfoTable
+ , ptrArgs :: [Box]
+ , dataArgs :: [Word]
+ , descr :: String
+ } |
+ ThunkClosure {
+ info :: StgInfoTable
+ , ptrArgs :: [Box]
+ , dataArgs :: [Word]
+ } |
+ SelectorClosure {
+ info :: StgInfoTable
+ , selectee :: Box
+ } |
+ IndClosure {
+ info :: StgInfoTable
+ , indirectee :: Box
+ } |
+ APClosure {
+ info :: StgInfoTable
+ , arity :: HalfWord
+ , n_args :: HalfWord
+ , fun :: Box
+ , payload :: [Box]
+ } |
+ PAPClosure {
+ info :: StgInfoTable
+ , arity :: HalfWord
+ , n_args :: HalfWord
+ , fun :: Box
+ , payload :: [Box]
+ } |
+ BCOClosure {
+ info :: StgInfoTable
+ , instrs :: Box
+ , literals :: Box
+ , bcoptrs :: Box
+ , arity :: HalfWord
+ , size :: HalfWord
+ , bitmap :: Word
+ } |
+ ArrWordsClosure {
+ info :: StgInfoTable
+ , bytes :: Word
+ , words :: [Word]
+ } |
+ MutArrClosure {
+ info :: StgInfoTable
+ , mccPtrs :: Word
+ , mccSize :: Word
+ , mccPayload :: [Box]
+ -- Card table ignored
+ } |
+ FunClosure {
+ info :: StgInfoTable
+ , ptrArgs :: [Box]
+ , dataArgs :: [Word]
+ } |
+ BlockingQueueClosure {
+ info :: StgInfoTable
+ , link :: Box
+ , blackHole :: Box
+ , owner :: Box
+ , queue :: Box
+ } |
+ OtherClosure {
+ info :: StgInfoTable
+ , hvalues :: [Box]
+ , words :: [Word]
+ }
+ deriving (Show)
+
+allPtrs (ConsClosure {..}) = ptrArgs
+allPtrs (ThunkClosure {..}) = ptrArgs
+allPtrs (SelectorClosure {..}) = [selectee]
+allPtrs (IndClosure {..}) = [indirectee]
+allPtrs (APClosure {..}) = fun:payload
+allPtrs (PAPClosure {..}) = fun:payload
+allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
+allPtrs (ArrWordsClosure {..}) = []
+allPtrs (MutArrClosure {..}) = mccPayload
+allPtrs (FunClosure {..}) = ptrArgs
+allPtrs (OtherClosure {..}) = hvalues
+
+foreign import prim "aToInt" aToInt# :: Any -> Int#
+foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
+
+--pClosure x = do
+-- getClosure x >>= print
+
+getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
+getClosureRaw x =
+ case slurpClosure# (unsafeCoerce# x) of
+ (# iptr, dat, ptrs #) -> do
+ let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
+ words = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
+ pelems = I# (sizeofArray# ptrs)
+ ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
+ ptrList `seq` words `seq` return (Ptr iptr, words, ptrList)
+
+-- From compiler/ghci/RtClosureInspect.hs
+amap' :: (t -> b) -> Array Int t -> [b]
+amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
+ where g (I# i#) = case indexArray# arr# i# of
+ (# e #) -> f e
+
+
+
+-- #include "../includes/rts/storage/ClosureTypes.h"
+
+getHValueClosureData :: Box -> IO Closure
+getHValueClosureData b@(Box a) = getClosureData a
+
+-- 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
+dataConInfoPtrToNames ptr = do
+ conDescAddress <- getConDescAddress ptr
+ wl <- peekArray0 0 conDescAddress
+ return $ fmap (chr . fromIntegral) wl
+ where
+ getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
+ getConDescAddress ptr
+ | ghciTablesNextToCode = do
+ offsetToString <- peek (ptr `plusPtr` (negate wORD_SIZE))
+ return $ (ptr `plusPtr` stdInfoTableSizeB)
+ `plusPtr` (fromIntegral (offsetToString :: Word))
+ | 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
+
+
+getClosureData :: a -> IO Closure
+getClosureData x = do
+ (iptr, words, ptrs) <- getClosureRaw x
+ let iptr' | ghciTablesNextToCode = iptr
+ | otherwise = iptr `plusPtr` negate wORD_SIZE
+ -- the info pointer we get back from unpackClosure#
+ -- is to the beginning of the standard info table,
+ -- but the Storable instance for info tables takes
+ -- into account the extra entry pointer when
+ -- !ghciTablesNextToCode, so we must adjust here
+ itbl <- peek iptr'
+ case tipe itbl of
+ t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
+ name <- dataConInfoPtrToNames iptr
+ return $ ConsClosure itbl ptrs (drop (length ptrs + 1) words) name
+
+ t | t >= THUNK && t <= THUNK_STATIC -> do
+ return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) words)
+
+ t | t >= FUN && t <= FUN_STATIC -> do
+ return $ FunClosure itbl ptrs (drop (length ptrs + 1) words)
+
+ AP ->
+ return $ APClosure itbl
+ (fromIntegral $ words !! 2)
+ (fromIntegral $ shiftR (words !! 2) (wORD_SIZE*4))
+ (head ptrs) (tail ptrs)
+
+ PAP ->
+ return $ PAPClosure itbl
+ (fromIntegral $ words !! 2)
+ (fromIntegral $ shiftR (words !! 2) (wORD_SIZE*4))
+ (head ptrs) (tail ptrs)
+
+ THUNK_SELECTOR ->
+ return $ SelectorClosure itbl (head ptrs)
+
+ IND ->
+ return $ IndClosure itbl (head ptrs)
+ IND_STATIC ->
+ return $ IndClosure itbl (head ptrs)
+ BLACKHOLE ->
+ return $ IndClosure itbl (head ptrs)
+
+ BCO ->
+ return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
+ (fromIntegral $ words !! 4)
+ (fromIntegral $ shiftR (words !! 4) (wORD_SIZE*4))
+ (words !! 5)
+
+ ARR_WORDS ->
+ return $ ArrWordsClosure itbl (words !! 1) (drop 2 words)
+ MUT_ARR_PTRS_FROZEN ->
+ return $ MutArrClosure itbl (words !! 2) (words !! 3) ptrs
+
+ BLOCKING_QUEUE ->
+ return $ OtherClosure itbl ptrs words
+ -- return $ BlockingQueueClosure itbl
+ -- (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
+
+ -- return $ OtherClosure itbl ptrs words
+ x -> error $ "getClosureData: Cannot handle closure type " ++ show x
projects / ghc-heap-view.git / commitdiff