diff --git a/Demo.hs b/Demo.hs new file mode 100644 --- /dev/null +++ b/Demo.hs @@ -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 " " diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/HeapView.c b/cbits/HeapView.c new file mode 100644 --- /dev/null +++ b/cbits/HeapView.c @@ -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; ipayload[i] = ptrs[i]; + } + + return arr; +} diff --git a/cbits/HeapViewPrim.cmm b/cbits/HeapViewPrim.cmm new file mode 100644 --- /dev/null +++ b/cbits/HeapViewPrim.cmm @@ -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); +} + diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal new file mode 100644 --- /dev/null +++ b/ghc-heap-view.cabal @@ -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 + . +License: BSD3 +License-file: LICENSE +Author: Joachim Breitner +Maintainer: Joachim Breitner +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/ + diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs new file mode 100644 --- /dev/null +++ b/src/GHC/HeapView.hs @@ -0,0 +1,476 @@ +{-| +Module : GHC.HeapView +Copyright : (c) 2012 Joachim Breitner +License : BSD3 +Maintainer : Joachim Breitner + +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 + + 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 + + -} +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 + + -} +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 +