Disable the BCO disassembler
[ghc-heap-view.git] / cbits / HeapViewPrim.cmm
1 #include "Cmm.h"
2
3 aToWordzh (P_ clos)
4 {
5         return (clos);
6 }
7
8 slurpClosurezh ( P_ closure )
9 {
10     W_ info, ptrs, nptrs, p, ptrs_arr, dat_arr;
11     info  = %GET_STD_INFO(UNTAG(closure));
12
13     ptrs  = TO_W_(%INFO_PTRS(info));
14     nptrs = TO_W_(%INFO_NPTRS(info));
15
16     W_ clos;
17     clos = UNTAG(closure);
18
19     W_ len;
20     (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr");
21
22     W_ ptrs_arr_sz, ptrs_arr_cards, dat_arr_sz;
23     dat_arr_sz = SIZEOF_StgArrBytes + WDS(len);
24
25     ALLOC_PRIM_P (dat_arr_sz, slurpClosurezh, closure);
26
27     dat_arr = Hp - dat_arr_sz + WDS(1);
28
29
30     SET_HDR(dat_arr, stg_ARR_WORDS_info, CCCS);
31     StgArrBytes_bytes(dat_arr) = WDS(len);
32     p = 0;
33 for:
34     if(p < len) {
35          W_[BYTE_ARR_CTS(dat_arr) + WDS(p)] = W_[clos + WDS(p)];
36          p = p + 1;
37          goto for;
38     }
39
40     W_ ptrArray;
41
42     ("ptr" ptrArray) = foreign "C" gtc_heap_view_closurePtrs(MyCapability() "ptr", clos "ptr");
43
44     return (info, dat_arr, ptrArray);
45 }
46
47
48 reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)
49 {
50     clos1 = UNTAG(clos1);
51     clos2 = UNTAG(clos2);
52     return (clos1 == clos2);
53 }