#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; clos = R1; RET_N(clos); } // Taken from stg_unpackClosurezh in rts/PrimOps.cmm slurpClosurezh { /* args: R1 = closure to analyze */ W_ clos, len; clos = UNTAG(R1); W_ info; info = %GET_STD_INFO(clos); (len) = foreign "C" gtc_heap_view_closureSize(clos "ptr") [R1]; W_ data_arr_sz; data_arr_sz = SIZEOF_StgArrWords + WDS(len); ALLOC_PRIM (data_arr_sz, R1_PTR, slurpClosurezh); W_ data_arr; data_arr = Hp - data_arr_sz + WDS(1); SET_HDR(data_arr, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(data_arr) = WDS(len); W_ p; p = 0; for: if(p < len) { // W_[BYTE_ARR_CTS(data_arr) + WDS(p)] = StgClosure_payload(clos, p); W_[BYTE_ARR_CTS(data_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") []; RET_NPP(info, data_arr, ptrArray); } reallyUnsafePtrEqualityUpToTag { W_ clos1; W_ clos2; clos1 = UNTAG(R1); clos2 = UNTAG(R2); RET_N(clos1 == clos2); } #endif