Add HeapView functionality

This pulls parts of Joachim Breitner's ghc-heap-view library inside GHC.
The bits added are the C hooks into the RTS and a basic Haskell wrapper
to these C hooks. The main reason for these to be added to GHC proper
is that the code needs to be kept in sync with the closure types
defined by the RTS. It is expected that the version of HeapView shipped
with GHC will always work with that version of GHC and that extra
functionality can be layered on top with a library like ghc-heap-view
distributed via Hackage.

Test Plan: validate

Reviewers: simonmar, hvr, nomeata, austin, Phyx, bgamari, erikd

Reviewed By: bgamari

Subscribers: carter, patrickdoc, tmcgilchrist, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3055

3 files changed, 253 insertions, 57 deletions

diff --git a/rts/Heap.c b/rts/Heap.c
new file mode 100644
index 0000000000..14289b896f
--- /dev/null
+++ b/rts/Heap.c
@@ -0,0 +1,220 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2006-2017
+ *
+ * Introspection into GHC's heap representation
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsAPI.h"
+
+#include "Capability.h"
+#include "Printer.h"
+
+StgWord heap_view_closureSize(StgClosure *closure) {
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+    return closure_sizeW(closure);
+}
+
+static void
+heap_view_closure_ptrs_in_large_bitmap(StgClosure *ptrs[], StgWord *nptrs
+                        , StgClosure **p, StgLargeBitmap *large_bitmap
+                        , uint32_t size )
+{
+    uint32_t 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;
+        }
+    }
+}
+
+void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
+                      , StgClosure *fun, StgClosure **payload, StgWord size) {
+    StgWord bitmap;
+    const 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:
+        heap_view_closure_ptrs_in_large_bitmap(ptrs, nptrs, payload,
+                                         GET_FUN_LARGE_BITMAP(fun_info), size);
+        break;
+    case ARG_BCO:
+        heap_view_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 *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+
+    StgWord size = heap_view_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;
+
+    const StgInfoTable *info = get_itbl(closure);
+
+    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 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;
+            heap_view_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;
+            heap_view_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_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:
+        case MUT_ARR_PTRS_FROZEN0:
+            for (i = 0; i < ((StgMutArrPtrs *)closure)->ptrs; ++i) {
+                ptrs[nptrs++] = ((StgMutArrPtrs *)closure)->payload[i];
+            }
+            break;
+        case MUT_VAR_CLEAN:
+        case MUT_VAR_DIRTY:
+            ptrs[nptrs++] = ((StgMutVar *)closure)->var;
+            break;
+        case MVAR_DIRTY:
+        case MVAR_CLEAN:
+            ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->head;
+            ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->tail;
+            ptrs[nptrs++] = ((StgMVar *)closure)->value;
+            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, cap->r.rCCCS);
+    arr->ptrs = nptrs;
+    arr->size = size;
+
+    for (i = 0; i<nptrs; i++) {
+        arr->payload[i] = ptrs[i];
+    }
+
+    return arr;
+}
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index e3f6e4cd19..8c2eeb1b98 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2020,70 +2020,44 @@ stg_mkApUpd0zh ( P_ bco )
 
 stg_unpackClosurezh ( P_ closure )
 {
-    W_ clos, info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
-    clos  = UNTAG(closure);
-    info  = %GET_STD_INFO(clos);
-
-    // Some closures have non-standard layout, so we omit those here.
-    W_ type;
-    type = TO_W_(%INFO_TYPE(info));
-    switch [0 .. N_CLOSURE_TYPES] type {
-    case THUNK_SELECTOR : {
-        ptrs = 1;
-        nptrs = 0;
-        goto out;
-    }
-    case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
-         THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
-        ptrs = 0;
-        nptrs = 0;
-        goto out;
-    }
-    default: {
-        ptrs  = TO_W_(%INFO_PTRS(info));
-        nptrs = TO_W_(%INFO_NPTRS(info));
-        goto out;
-    }}
-
-out:
-    W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
-    nptrs_arr_sz = SIZEOF_StgArrBytes   + WDS(nptrs);
-    ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
-    ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
-
-    ALLOC_PRIM_P (ptrs_arr_sz + nptrs_arr_sz, stg_unpackClosurezh, closure);
-
-    ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
-    nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
-
-    SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);
-    StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
-    StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
+    W_ info, ptrs, nptrs, p, ptrs_arr, dat_arr;
+    info  = %GET_STD_INFO(UNTAG(closure));
 
-    p = 0;
+    ptrs  = TO_W_(%INFO_PTRS(info));
+    nptrs = TO_W_(%INFO_NPTRS(info));
 
-write_ptrs:
-    if(p < ptrs) {
-         W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
-         p = p + 1;
-         goto write_ptrs;
-    }
-    /* We can leave the card table uninitialised, since the array is
-       allocated in the nursery.  The GC will fill it in if/when the array
-       is promoted. */
+    W_ clos;
+    clos = UNTAG(closure);
 
-    SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS);
-    StgArrBytes_bytes(nptrs_arr) = WDS(nptrs);
-    p = 0;
+    W_ len;
+    // The array returned is the raw data for the entire closure.
+    // The length is variable based upon the closure type, ptrs, and non-ptrs
+    (len) = foreign "C" heap_view_closureSize(clos "ptr");
+
+    W_ ptrs_arr_sz, ptrs_arr_cards, dat_arr_sz;
+    dat_arr_sz = SIZEOF_StgArrBytes + WDS(len);
+
+    ALLOC_PRIM_P (dat_arr_sz, stg_unpackClosurezh, closure);
 
-write_nptrs:
-    if(p < nptrs) {
-         W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
+    dat_arr = Hp - dat_arr_sz + WDS(1);
+
+
+    SET_HDR(dat_arr, stg_ARR_WORDS_info, CCCS);
+    StgArrBytes_bytes(dat_arr) = WDS(len);
+    p = 0;
+for:
+    if(p < len) {
+         W_[BYTE_ARR_CTS(dat_arr) + WDS(p)] = W_[clos + WDS(p)];
          p = p + 1;
-         goto write_nptrs;
+         goto for;
     }
 
-    return (info, ptrs_arr, nptrs_arr);
+    W_ ptrArray;
+
+    // Follow the pointers
+    ("ptr" ptrArray) = foreign "C" heap_view_closurePtrs(MyCapability() "ptr", clos "ptr");
+
+    return (info, dat_arr, ptrArray);
 }
 
 /* -----------------------------------------------------------------------------
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index aae1dd4334..d41135ddd3 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -143,6 +143,7 @@ library
                       rts/storage/ClosureTypes.h
                       rts/storage/Closures.h
                       rts/storage/FunTypes.h
+                      rts/storage/Heap.h
                       rts/storage/GC.h
                       rts/storage/InfoTables.h
                       rts/storage/MBlock.h
@@ -358,6 +359,7 @@ library
                FileLock.c
                Globals.c
                Hash.c
+               Heap.c
                Hpc.c
                HsFFI.c
                Inlines.c