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

1 files changed, 31 insertions, 57 deletions

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);
 }
 
 /* -----------------------------------------------------------------------------