Add more sanity checking
[ghc-heap-view.git] / cbits / HeapViewPrim.cmm
index 2193801..474a7eb 100644 (file)
@@ -1,5 +1,60 @@
 #include "Cmm.h"
 
+#if GHC_7_7
+
+aToWordzh (P_ clos)
+{
+       return (clos);
+}
+
+slurpClosurezh ( P_ closure )
+{
+    W_ info, ptrs, nptrs, p, ptrs_arr, dat_arr;
+    info  = %GET_STD_INFO(UNTAG(closure));
+
+    ptrs  = TO_W_(%INFO_PTRS(info));
+    nptrs = TO_W_(%INFO_NPTRS(info));
+
+    W_ clos;
+    clos = UNTAG(closure);
+
+    W_ len;
+    (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr");
+
+    W_ ptrs_arr_sz, ptrs_arr_cards, dat_arr_sz;
+    dat_arr_sz = SIZEOF_StgArrWords + WDS(len);
+
+    ALLOC_PRIM_P (dat_arr_sz, slurpClosurezh, closure);
+
+    dat_arr = Hp - dat_arr_sz + WDS(1);
+
+
+    SET_HDR(dat_arr, stg_ARR_WORDS_info, CCCS);
+    StgArrWords_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 for;
+    }
+
+    W_ ptrArray;
+
+    ("ptr" ptrArray) = foreign "C" gtc_heap_view_closurePtrs(MyCapability() "ptr", clos "ptr");
+
+    return (info, dat_arr, ptrArray);
+}
+
+
+reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)
+{
+    clos1 = UNTAG(clos1);
+    clos2 = UNTAG(clos2);
+    return (clos1 == clos2);
+}
+
+#else
 aToWordzh
 {
        W_ clos;
@@ -7,10 +62,10 @@ aToWordzh
        RET_N(clos);
 }
 
+// Taken from stg_unpackClosurezh in rts/PrimOps.cmm
 slurpClosurezh
 {
 /* args: R1 = closure to analyze */
-// TODO: Consider the absence of ptrs or nonptrs as a special case ?
 
     W_ clos, len;
     clos = UNTAG(R1);
@@ -18,7 +73,7 @@ slurpClosurezh
     W_ info;
     info = %GET_STD_INFO(clos);
 
-    (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") [];
+    (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") [R1];
 
     W_ data_arr_sz;
     data_arr_sz = SIZEOF_StgArrWords  + WDS(len);
@@ -47,9 +102,12 @@ for:
     RET_NPP(info, data_arr, ptrArray);
 }
 
-untag
+reallyUnsafePtrEqualityUpToTag
 {
-    W_ clos;
-    clos = UNTAG(R1);
-    RET_N(clos);
+    W_ clos1;
+    W_ clos2;
+    clos1 = UNTAG(R1);
+    clos2 = UNTAG(R2);
+    RET_N(clos1 == clos2);
 }
+#endif