ghc-heap-view (empty) → 0.1
raw patch · 7 files changed
+939/−0 lines, 7 filesdep +basedep +ghcsetup-changed
Dependencies added: base, ghc
Files
- Demo.hs +80/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- cbits/HeapView.c +260/−0
- cbits/HeapViewPrim.cmm +49/−0
- ghc-heap-view.cabal +42/−0
- src/GHC/HeapView.hs +476/−0
+ Demo.hs view
@@ -0,0 +1,80 @@+{-# 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 ""+ putStrLn "Here are a four different lists, where the first three are already evaluated."+ putStrLn "The first one, l, was defined as a top level constant as "+ putStrLn "> l = [1,2,3]"+ putStrLn $ "and is now found at " ++ show (asBox l) ++ " (where the /2 is the pointer tag information) and fully evaluated:"+ getClosureData l >>= printInd+ putStrLn $ "The second one, l2, is locally defined"+ putStrLn "> let l2 = 4:l" + putStrLn $ "and now found at " ++ show (asBox l2) ++ ". See how the cons-cell references l!"+ getClosureData l2 >>= printInd+ putStrLn "And the binding"+ 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:"+ getClosureData x >>= printInd++ putStrLn ""+ putStrLn "Now to some more closure types. m and m' locally bound of type the unboxed type Int#, with values 42 resp. 23."+ putStrLn "> let f = \\x n -> take (I# m + I# x) n ++ args"+ putStrLn " t = f m' l2"+ 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 $ "So here is (" ++ show (asBox f) ++ "), referncing its free variables args and 42:"+ getClosureData f >>= printInd+ putStrLn "And t is a thunk that applies f (also referenced here) to an unboxed value (23) and l2:"+ getClosureData t >>= printInd++ putStrLn ""+ putStrLn "Lastly, 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 >>= printInd+ 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+ 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+ 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 >>= printInd++printInd :: Show a => a -> IO ()+printInd x = putStrLn $ " " ++ show x++recurse :: Int -> Box -> IO ()+recurse m = go 0+ where go i b = if i >= m then return () else do+ putStrLn $ ind ++ show b+ c <- getBoxedClosureData b+ putStrLn $ ind ++ show c+ mapM_ (go (succ i)) (allPtrs c)+ where+ ind = concat $ replicate i " "
+ LICENSE view
@@ -0,0 +1,30 @@+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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/HeapView.c view
@@ -0,0 +1,260 @@+#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;+}
+ cbits/HeapViewPrim.cmm view
@@ -0,0 +1,49 @@+#include "Cmm.h"++aToWordzh+{+ 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);+}+
+ ghc-heap-view.cabal view
@@ -0,0 +1,42 @@+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 evaluation.+ .+ 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. + .+ The work on this package has been supported by the Deutsche Telekom Stiftung+ <http://telekom-stiftung.de>.+License: BSD3+License-file: LICENSE+Author: Joachim Breitner+Maintainer: Joachim Breitner <mail@joachim-breitner.de>+Copyright: 2012 Joachim Breitner+Category: Debug, GHC+Build-type: Simple+Cabal-version: >=1.6+Extra-source-files: Demo.hs++Flag prim-supports-any+ Description: The used GHC supports Any as an argument to foreign prim functions (GHC ticket #5931)+ Default: False++Library+ Exposed-modules: GHC.HeapView + Build-depends:+ base == 4.5.*,+ ghc+ 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+ +source-repository head+ type: darcs+ location: http://darcs.nomeata.de/darcswatch/+
+ src/GHC/HeapView.hs view
@@ -0,0 +1,476 @@+{-|+Module : GHC.HeapView+Copyright : (c) 2012 Joachim Breitner+License : BSD3+Maintainer : Joachim Breitner <mail@joachim-breitner.de>++With this module, you can investigate the heap representation of Haskell+values, i.e. to investigate sharing and lazy evaluation.+-}++{-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards #-}++module GHC.HeapView (+ -- * Heap data types+ Closure(..),+ allPtrs,+ ClosureType(..),+ StgInfoTable(..),+ HalfWord,+ -- * Reading from the heap+ getClosureData,+ getBoxedClosureData,+ getClosureRaw,+ -- * Boxes+ Box(..),+ asBox,+ )+ where++import GHC.Exts+import GHC.Arr (Array(..))++import GHC.Constants ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )++import Foreign+import Numeric ( showHex )+import Data.Char++-- | 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++type HalfWord = Word32++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++{-|+ 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+ <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>+ 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)++instance Storable StgInfoTable where++ sizeOf itbl + = sum+ [+ fieldSz ptrs itbl,+ fieldSz nptrs itbl,+ sizeOf (undefined :: HalfWord),+ fieldSz srtlen itbl+ ]++ alignment _ + = wORD_SIZE++ poke _a0 _itbl+ = error "Storable StgInfoTable is read-only"++ peek a0+ = runState (castPtr a0)+ $ do+ 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++{-+ 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 :: Monad m => m a -> State s m a+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+ -}+++{-| A closure type enumeration, in order matching the actual value on the heap.+ Needs to be synchronized with+ <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>+ -}+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)++{-| This is the main data type of this module, representing a Haskell value on+ the heap. This reflects+ <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>+ -}+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+ , arrWords :: [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]+ , rawWords :: [Word]+ }+ deriving (Show)++-- | For generic code, this function returns all referenced closures. +allPtrs :: Closure -> [Box]+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 (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]+allPtrs (OtherClosure {..}) = hvalues++++#ifdef PRIM_SUPPORTS_ANY+foreign import prim "aToWordzh" aToWord# :: Any -> Word#+foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)+#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 #)++-- 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)+#endif++--pClosure x = do+-- getClosure x >>= print++-- | 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+-- are those words that are actually pointers. Once back in Haskell word, the+-- 'Word' may be outdated after a garbage collector run, but the corresponding+-- 'Box' will still point to the correct value.+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+ rawWords = [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` rawWords `seq` return (Ptr iptr, rawWords, 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++-- 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'+ | 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+ ++-- | 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 && t <= CONSTR_NOCAF_STATIC -> do+ name <- dataConInfoPtrToNames iptr+ return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) 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 ->+ return $ APClosure itbl + (fromIntegral $ wds !! 2)+ (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))+ (head ptrs) (tail ptrs)++ PAP ->+ return $ PAPClosure itbl + (fromIntegral $ wds !! 2)+ (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))+ (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 $ wds !! 4)+ (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))+ (wds !! 5)++ ARR_WORDS ->+ return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)+ MUT_ARR_PTRS_FROZEN ->+ return $ MutArrClosure itbl (wds !! 2) (wds !! 3) ptrs++ BLOCKING_QUEUE ->+ return $ OtherClosure itbl ptrs wds+ -- return $ BlockingQueueClosure itbl+ -- (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)++ -- return $ OtherClosure itbl ptrs wds+ closure -> error $ "getClosureData: Cannot handle closure type " ++ show closure++-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.+getBoxedClosureData :: Box -> IO Closure+getBoxedClosureData (Box a) = getClosureData a+