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