Initial work on GHC 7.7 compatibility
[ghc-heap-view.git] / cbits / HeapViewPrim.cmm
1 #include "Cmm.h"
2
3 #if GHC_7_7
4
5 aToWordzh (P_ clos)
6 {
7         return (clos);
8 }
9
10 slurpClosurezh ( P_ closure )
11 {
12     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
13     info  = %GET_STD_INFO(UNTAG(closure));
14
15     ptrs  = TO_W_(%INFO_PTRS(info));
16     nptrs = TO_W_(%INFO_NPTRS(info));
17
18     W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
19     nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
20     ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
21     ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
22
23     ALLOC_PRIM_P (ptrs_arr_sz + nptrs_arr_sz, stg_unpackClosurezh, closure);
24
25     W_ clos;
26     clos = UNTAG(closure);
27
28     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
29     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
30
31     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, CCCS);
32     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
33     StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
34
35     p = 0;
36 for:
37     if(p < ptrs) {
38          W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
39          p = p + 1;
40          goto for;
41     }
42     /* We can leave the card table uninitialised, since the array is
43        allocated in the nursery.  The GC will fill it in if/when the array
44        is promoted. */
45
46     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS);
47     StgArrWords_bytes(nptrs_arr) = WDS(nptrs);
48     p = 0;
49 for2:
50     if(p < nptrs) {
51          W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
52          p = p + 1;
53          goto for2;
54     }
55     return (info, ptrs_arr, nptrs_arr);
56 }
57
58
59 reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)
60 {
61     clos1 = UNTAG(clos1);
62     clos2 = UNTAG(clos2);
63     return (clos1 == clos2);
64 }
65
66 #else
67 aToWordzh
68 {
69         W_ clos;
70         clos = R1;
71         RET_N(clos);
72 }
73
74 // Taken from stg_unpackClosurezh in rts/PrimOps.cmm
75 slurpClosurezh
76 {
77 /* args: R1 = closure to analyze */
78
79     W_ clos, len;
80     clos = UNTAG(R1);
81
82     W_ info;
83     info = %GET_STD_INFO(clos);
84
85     (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") [R1];
86
87     W_ data_arr_sz;
88     data_arr_sz = SIZEOF_StgArrWords  + WDS(len);
89
90     ALLOC_PRIM (data_arr_sz, R1_PTR, slurpClosurezh);
91
92     W_ data_arr;
93     data_arr = Hp - data_arr_sz + WDS(1);
94
95     SET_HDR(data_arr, stg_ARR_WORDS_info, CCCS);
96     StgArrWords_bytes(data_arr) = WDS(len);
97     W_ p;
98     p = 0;
99 for:
100     if(p < len) {
101          // W_[BYTE_ARR_CTS(data_arr) + WDS(p)] = StgClosure_payload(clos, p);
102          W_[BYTE_ARR_CTS(data_arr) + WDS(p)] = W_[clos + WDS(p)];
103          p = p + 1;
104          goto for;
105     }
106
107     W_ ptrArray;
108
109     ("ptr" ptrArray) = foreign "C" gtc_heap_view_closurePtrs(MyCapability() "ptr", clos "ptr") [];
110
111     RET_NPP(info, data_arr, ptrArray);
112 }
113
114 reallyUnsafePtrEqualityUpToTag
115 {
116     W_ clos1;
117     W_ clos2;
118     clos1 = UNTAG(R1);
119     clos2 = UNTAG(R2);
120     RET_N(clos1 == clos2);
121 }
122 #endif