Initial check-in
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 12 Mar 2012 13:55:53 +0000 (13:55 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 12 Mar 2012 13:55:53 +0000 (13:55 +0000)
Demo.hs [new file with mode: 0644]
LICENSE [new file with mode: 0644]
Setup.hs [new file with mode: 0644]
cbits/HeapView.c [new file with mode: 0644]
cbits/HeapViewPrim.cmm [new file with mode: 0644]
ghc-heap-view.cabal [new file with mode: 0644]
src/GHC/HeapView.hs [new file with mode: 0644]

diff --git a/Demo.hs b/Demo.hs
new file mode 100644 (file)
index 0000000..e0e2ca0
--- /dev/null
+++ b/Demo.hs
@@ -0,0 +1,66 @@
+{-# 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 "  "
diff --git a/LICENSE b/LICENSE
new file mode 100644 (file)
index 0000000..bfb8a93
--- /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 (file)
index 0000000..9a994af
--- /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 (file)
index 0000000..6d2598b
--- /dev/null
@@ -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;
+}
diff --git a/cbits/HeapViewPrim.cmm b/cbits/HeapViewPrim.cmm
new file mode 100644 (file)
index 0000000..f6f9b5c
--- /dev/null
@@ -0,0 +1,49 @@
+#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);
+}
+
diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal
new file mode 100644 (file)
index 0000000..8cf1840
--- /dev/null
@@ -0,0 +1,24 @@
+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/
+  
diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs
new file mode 100644 (file)
index 0000000..a16ebb6
--- /dev/null
@@ -0,0 +1,423 @@
+{-# 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