C++ Is_in_heap函数代码示例

static void check_block (char *hp)
{
    mlsize_t i;
    value v = Val_hp (hp);
    value f;

    check_head (v);
    switch (Tag_hp (hp)) {
    case Abstract_tag:
        break;
    case String_tag:
        break;
    case Double_tag:
        Assert (Wosize_val (v) == Double_wosize);
        break;
    case Double_array_tag:
        Assert (Wosize_val (v) % Double_wosize == 0);
        break;
    case Custom_tag:
        Assert (!Is_in_heap (Custom_ops_val (v)));
        break;

    case Infix_tag:
        Assert (0);
        break;

    default:
        Assert (Tag_hp (hp) < No_scan_tag);
        for (i = 0; i < Wosize_hp (hp); i++) {
            f = Field (v, i);
            if (Is_block (f) && Is_in_heap (f)) check_head (f);
        }
    }
}

CAMLprim value caml_weak_blit (value ars, value ofs,
                               value ard, value ofd, value len)
{
  mlsize_t offset_s = Long_val (ofs) + 1;
  mlsize_t offset_d = Long_val (ofd) + 1;
  mlsize_t length = Long_val (len);
  long i;
                                                   Assert (Is_in_heap (ars));
                                                   Assert (Is_in_heap (ard));
  if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
    caml_invalid_argument ("Weak.blit");
  }
  if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
    caml_invalid_argument ("Weak.blit");
  }
  if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){
    for (i = 0; i < length; i++){
      value v = Field (ars, offset_s + i);
      if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
          && Is_white_val (v)){
        Field (ars, offset_s + i) = caml_weak_none;
      }
    }
  }
  if (offset_d < offset_s){
    for (i = 0; i < length; i++){
      do_set (ard, offset_d + i, Field (ars, offset_s + i));
    }
  }else{
    for (i = length - 1; i >= 0; i--){
      do_set (ard, offset_d + i,  Field (ars, offset_s + i));
    }
  }
  return Val_unit;
}

static long compare_val(value v1, value v2)
{
  tag_t t1, t2;

 tailcall:
  if (v1 == v2) return 0;
  if (Is_long(v1) || Is_long(v2)) return Long_val(v1) - Long_val(v2);
  /* If one of the objects is outside the heap (but is not an atom),
     use address comparison. */
  if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap((addr)v1)) ||
      (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap((addr)v2)))
    return v1 - v2;
  t1 = Tag_val(v1);
  t2 = Tag_val(v2);
  if (t1 != t2) return (long)t1 - (long)t2;
  switch(t1) {
  case String_tag: {
    mlsize_t len1, len2, len;
    unsigned char * p1, * p2;
    len1 = string_length(v1);
    len2 = string_length(v2);
    for (len = (len1 <= len2 ? len1 : len2),
         p1 = (unsigned char *) String_val(v1),
         p2 = (unsigned char *) String_val(v2);
         len > 0;
         len--, p1++, p2++)
      if (*p1 != *p2) return (long)*p1 - (long)*p2;
    return len1 - len2;
  }
  case Double_tag: {
    double d1 = Double_val(v1);
    double d2 = Double_val(v2);
    if (d1 == d2) return 0; else if (d1 < d2) return -1; else return 1;
  }
  case Abstract_tag:
  case Final_tag:
    invalid_argument("equal: abstract value");
  case Closure_tag:
    invalid_argument("equal: functional value");
  default: {
    mlsize_t sz1 = Wosize_val(v1);
    mlsize_t sz2 = Wosize_val(v2);
    value * p1, * p2;
    long res;
    if (sz1 != sz2) return sz1 - sz2;
    for(p1 = Op_val(v1), p2 = Op_val(v2);
        sz1 > 1;
        sz1--, p1++, p2++) {
      res = compare_val(*p1, *p2);
      if (res != 0) return res;
    }
    v1 = *p1;
    v2 = *p2;
    goto tailcall;
  }
  }
}

static void fl_check (void)
{
  char *cur, *prev;
  int prev_found = 0, flp_found = 0, merge_found = 0;
  uintnat size_found = 0;
  int sz = 0;

  prev = Fl_head;
  cur = Next (prev);
  while (cur != NULL){
    size_found += Whsize_bp (cur);
    Assert (Is_in_heap (cur));
    if (cur == fl_prev) prev_found = 1;
    if (policy == Policy_first_fit && Wosize_bp (cur) > sz){
      sz = Wosize_bp (cur);
      if (flp_found < flp_size){
        Assert (Next (flp[flp_found]) == cur);
        ++ flp_found;
      }else{
        Assert (beyond == NULL || cur >= Next (beyond));
      }
    }
    if (cur == caml_fl_merge) merge_found = 1;
    prev = cur;
    cur = Next (prev);
  }
  if (policy == Policy_next_fit) Assert (prev_found || fl_prev == Fl_head);
  if (policy == Policy_first_fit) Assert (flp_found == flp_size);
  Assert (merge_found || caml_fl_merge == Fl_head);
  Assert (size_found == caml_fl_cur_size);
}

/* [caml_fl_allocate] does not set the header of the newly allocated block.
   The calling function must do it before any GC function gets called.
   [caml_fl_allocate] returns a head pointer.
*/
char *caml_fl_allocate (mlsize_t wo_sz)
{
  char *cur, *prev;
                                  Assert (sizeof (char *) == sizeof (value));
                                  Assert (fl_prev != NULL);
                                  Assert (wo_sz >= 1);
    /* Search from [fl_prev] to the end of the list. */
  prev = fl_prev;
  cur = Next (prev);
  while (cur != NULL){                             Assert (Is_in_heap (cur));
    if (Wosize_bp (cur) >= wo_sz){
      return allocate_block (Whsize_wosize (wo_sz), prev, cur);
    }
    prev = cur;
    cur = Next (prev);
  }
  fl_last = prev;
    /* Search from the start of the list to [fl_prev]. */
  prev = Fl_head;
  cur = Next (prev);
  while (prev != fl_prev){
    if (Wosize_bp (cur) >= wo_sz){
      return allocate_block (Whsize_wosize (wo_sz), prev, cur);
    }
    prev = cur;
    cur = Next (prev);
  }
    /* No suitable block was found. */
  return NULL;
}

/* [allocate_block] is called by [caml_fl_allocate].  Given a suitable free
   block and the desired size, it allocates a new block from the free
   block.  There are three cases:
   0. The free block has the desired size.  Detach the block from the
      free-list and return it.
   1. The free block is 1 word longer than the desired size.  Detach
      the block from the free list.  The remaining word cannot be linked:
      turn it into an empty block (header only), and return the rest.
   2. The free block is big enough.  Split it in two and return the right
      block.
   In all cases, the allocated block is right-justified in the free block:
   it is located in the high-address words of the free block.  This way,
   the linking of the free-list does not change in case 2.
*/
static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur)
{
  header_t h = Hd_bp (cur);
                                             Assert (Whsize_hd (h) >= wh_sz);
  if (Wosize_hd (h) < wh_sz + 1){                        /* Cases 0 and 1. */
    caml_fl_cur_size -= Whsize_hd (h);
    Next (prev) = Next (cur);
                    Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL);
    if (caml_fl_merge == cur) caml_fl_merge = prev;
#ifdef DEBUG
    fl_last = NULL;
#endif
      /* In case 1, the following creates the empty block correctly.
         In case 0, it gives an invalid header to the block.  The function
         calling [caml_fl_allocate] will overwrite it. */
    Hd_op (cur) = Make_header (0, 0, Caml_white);
    if (policy == Policy_first_fit){
      if (flpi + 1 < flp_size && flp[flpi + 1] == cur){
        flp[flpi + 1] = prev;
      }else if (flpi == flp_size - 1){
        beyond = (prev == Fl_head) ? NULL : prev;
        -- flp_size;
      }
    }
  }else{                                                        /* Case 2. */
    caml_fl_cur_size -= wh_sz;
    Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue);
  }
  if (policy == Policy_next_fit) fl_prev = prev;
  return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
}

CAMLprim value caml_weak_check (value ar, value n)
{
  mlsize_t offset = Long_val (n) + 1;
                                                   Assert (Is_in_heap (ar));
  if (offset < 1 || offset >= Wosize_val (ar)){
    caml_invalid_argument ("Weak.get");
  }
  return Val_bool (Field (ar, offset) != caml_weak_none);
}

static int sml_equal_aux(value v1, value v2)
{
  mlsize_t i;
  value * p1, * p2;

 again:
  if (v1 == v2) return 1;
  if (IS_LONG(v1) || IS_LONG(v2)) return 0;
  if (!Is_in_heap(v1) && !Is_young(v1)) return 0;
  if (!Is_in_heap(v2) && !Is_young(v2)) return 0;
  if (Tag_val(v1) != Tag_val(v2)) return 0;
  switch(Tag_val(v1)) {
  case String_tag:
  {
	  // Fast string comparison
	  size_t len = string_length(v1);
	  if  (len != string_length(v2)) {
		  return 0;
	  }

	  return (strncmp((char *) String_val(v1),
			  (char *) String_val(v2),
			  len) == 0) ? 1 : 0;
  }
  case Double_tag:
    return (Double_val(v1) == Double_val(v2));
  case Reference_tag:  /* Different reference cells are not equal! */
  case Abstract_tag:
  case Final_tag:
    return 0;
  case Closure_tag:
    invalid_argument("sml_equal: functional value");
  default:
    i = Wosize_val(v1);
    if (i != Wosize_val(v2)) return 0;
    for(p1 = Op_val(v1), p2 = Op_val(v2);
        i > 1;
        i--, p1++, p2++)
      if (!sml_equal_aux(*p1, *p2)) return 0;
    v1 = *p1;
    v2 = *p2;                   /* Tail-call */
    goto again;
  }
}

/* [caml_initialize] never calls the GC, so you may call it while an block is
   unfinished (i.e. just after a call to [caml_alloc_shr].) */
void caml_initialize (value *fp, value val)
{
  *fp = val;
  if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){
    if (caml_ref_table.ptr >= caml_ref_table.limit){
      caml_realloc_ref_table (&caml_ref_table);
    }
    *caml_ref_table.ptr++ = fp;
  }
}

CAMLexport void caml_remove_generational_global_root_r(CAML_R, value *r)
{
  value v = *r;
  if (Is_block(v)) {
    if (Is_young(v))
      caml_delete_global_root_r(ctx, &caml_global_roots_young, r);
    else if (Is_in_heap(v))
      caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
  }
}

/* [initialize] never calls the GC, so you may call it while an object is
   unfinished (i.e. just after a call to [alloc_shr].) */
void initialize (value * fp, value val)
{
  *fp = val;
  Assert (Is_in_heap (fp));
  if (Is_block (val) && Is_young (val)){
    *ref_table_ptr++ = fp;
    if (ref_table_ptr >= ref_table_limit){
      realloc_ref_table ();
    }
  }
}

/* PR#6084 workaround: define it as a weak symbol */
CAMLexport CAMLweakdef void caml_initialize (value *fp, value val)
{
  CAMLassert(Is_in_heap(fp));
  *fp = val;
  if (Is_block (val) && Is_young (val)) {
    if (caml_ref_table.ptr >= caml_ref_table.limit){
      caml_realloc_ref_table (&caml_ref_table);
    }
    *caml_ref_table.ptr++ = fp;
  }
}

CAMLexport void caml_register_generational_global_root_r(CAML_R, value *r)
{
  value v = *r;
  Assert (((intnat) r & 3) == 0);  /* compact.c demands this (for now) */
  if (Is_block(v)) {
    if (Is_young(v))
      caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
    else if (Is_in_heap(v))
      caml_insert_global_root_r(ctx, &caml_global_roots_old, r);
  }
}

CAMLprim value caml_get_current_callstack(value max_frames_value) {
  CAMLparam1(max_frames_value);
  CAMLlocal1(trace);

  /* we use `intnat` here because, were it only `int`, passing `max_int`
     from the OCaml side would overflow on 64bits machines. */
  intnat max_frames = Long_val(max_frames_value);
  intnat trace_size;

  /* first compute the size of the trace */
  {
    uintnat pc = caml_last_return_address;
    /* note that [caml_bottom_of_stack] always points to the most recent
     * frame, independently of the [Stack_grows_upwards] setting */
    char * sp = caml_bottom_of_stack;
    char * limitsp = caml_top_of_stack;

    trace_size = 0;
    while (1) {
      frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
      if (descr == NULL) break;
      if (trace_size >= max_frames) break;
      ++trace_size;

#ifndef Stack_grows_upwards
      if (sp > limitsp) break;
#else
      if (sp < limitsp) break;
#endif
    }
  }

  trace = caml_alloc((mlsize_t) trace_size, Abstract_tag);

  /* then collect the trace */
  {
    uintnat pc = caml_last_return_address;
    char * sp = caml_bottom_of_stack;
    intnat trace_pos;

    for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
      frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
      Assert(descr != NULL);
      /* The assignment below is safe without [caml_initialize], even
         if the trace is large and allocated on the old heap, because
         we assign values that are outside the OCaml heap. */
      Assert(!(Is_block((value) descr) && Is_in_heap((value) descr)));
      Field(trace, trace_pos) = (value) descr;
    }
  }

  CAMLreturn(trace);
}

CAMLprim value caml_weak_get (value ar, value n)
{
  CAMLparam2 (ar, n);
  mlsize_t offset = Long_val (n) + 1;
  CAMLlocal2 (res, elt);
                                                   Assert (Is_in_heap (ar));
  if (offset < 1 || offset >= Wosize_val (ar)){
    caml_invalid_argument ("Weak.get");
  }
  if (Field (ar, offset) == caml_weak_none){
    res = None_val;
  }else{
    elt = Field (ar, offset);
    if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){
      caml_darken (elt, NULL);
    }
    res = caml_alloc_small (1, Some_tag);
    Field (res, 0) = elt;
  }
  CAMLreturn (res);
}