static intnat mark(value initial, intnat budget) {
value next = initial;
int found_next = 1;
while (budget > 0 && found_next) {
value v = next;
header_t hd_v;
found_next = 0;
Assert(Is_markable(v));
Assert(v == mark_normalise(v));
stat_blocks_marked++;
/* mark the current object */
hd_v = Hd_val(v);
// caml_gc_log ("mark: v=0x%lx hd=0x%lx tag=%d sz=%lu",
// v, hd_v, Tag_val(v), Wosize_val(v));
if (Tag_hd (hd_v) == Stack_tag) {
// caml_gc_log ("mark: stack=%p", (value*)v);
caml_scan_stack(&caml_darken, v);
} else if (Tag_hd (hd_v) < No_scan_tag) {
int i;
for (i = 0; i < Wosize_hd(hd_v); i++) {
value child = Op_val(v)[i];
// caml_gc_log ("mark: v=%p i=%u child=%p",(value*)v,i,(value*)child);
/* FIXME: this is wrong, as Debug_tag(N) is a valid value.
However, it's a useful debugging aid for now */
Assert(!Is_debug_tag(child));
if (Is_markable(child)) {
child = mark_normalise(child);
if (caml_mark_object(child)) {
if (!found_next) {
next = child;
found_next = 1;
} else {
mark_stack_push(child);
}
}
}
}
}
budget -= Whsize_hd(hd_v);
/* if we haven't found any markable children, pop an object to mark */
if (!found_next) {
found_next = mark_stack_pop(&next);
}
}
if (found_next) {
mark_stack_push(next);
}
return budget;
}
/* Finish the work that was put off by [oldify_one].
Note that [oldify_one] itself is called by oldify_mopup, so we
have to be careful to remove the first entry from the list before
oldifying its fields. */
static void oldify_mopup (struct oldify_state* st)
{
value v, new_v, f;
mlsize_t i;
caml_domain_state* domain_state =
st->promote_domain ? st->promote_domain->state : Caml_state;
struct caml_ephe_ref_table ephe_ref_table = domain_state->minor_tables->ephe_ref;
struct caml_ephe_ref_elt *re;
char* young_ptr = domain_state->young_ptr;
char* young_end = domain_state->young_end;
int redo = 0;
while (st->todo_list != 0) {
v = st->todo_list; /* Get the head. */
CAMLassert (Hd_val (v) == 0); /* It must be forwarded. */
new_v = Op_val (v)[0]; /* Follow forward pointer. */
st->todo_list = Op_val (new_v)[1]; /* Remove from list. */
f = Op_val (new_v)[0];
CAMLassert (!Is_debug_tag(f));
if (Is_block (f) &&
is_in_interval((value)Hp_val(v), young_ptr, young_end)) {
oldify_one (st, f, Op_val (new_v));
}
for (i = 1; i < Wosize_val (new_v); i++){
f = Op_val (v)[i];
CAMLassert (!Is_debug_tag(f));
if (Is_block (f) &&
is_in_interval((value)Hp_val(v), young_ptr, young_end)) {
oldify_one (st, f, Op_val (new_v) + i);
} else {
Op_val (new_v)[i] = f;
}
}
CAMLassert (Wosize_val(new_v));
}
/* Oldify the data in the minor heap of alive ephemeron
During minor collection keys outside the minor heap are considered alive */
for (re = ephe_ref_table.base;
re < ephe_ref_table.ptr; re++) {
/* look only at ephemeron with data in the minor heap */
if (re->offset == CAML_EPHE_DATA_OFFSET) {
value *data = &Ephe_data(re->ephe);
if (*data != caml_ephe_none && Is_block(*data) &&
is_in_interval(*data, young_ptr, young_end)) {
resolve_infix_val(data);
if (Hd_val(*data) == 0) { /* Value copied to major heap */
*data = Op_val(*data)[0];
} else {
if (ephe_check_alive_data(re, young_ptr, young_end)) {
oldify_one(st, *data, data);
redo = 1; /* oldify_todo_list can still be 0 */
}
}
}
}
}
if (redo) oldify_mopup (st);
}
/* Note that the tests on the tag depend on the fact that Infix_tag,
Forward_tag, and No_scan_tag are contiguous. */
static void oldify_one (void* st_v, value v, value *p)
{
struct oldify_state* st = st_v;
value result;
header_t hd;
mlsize_t sz, i;
mlsize_t infix_offset;
tag_t tag;
caml_domain_state* domain_state =
st->promote_domain ? st->promote_domain->state : Caml_state;
char* young_ptr = domain_state->young_ptr;
char* young_end = domain_state->young_end;
CAMLassert (domain_state->young_start <= domain_state->young_ptr &&
domain_state->young_ptr <= domain_state->young_end);
tail_call:
if (!(Is_block(v) && is_in_interval((value)Hp_val(v), young_ptr, young_end))) {
/* not a minor block */
*p = v;
return;
}
infix_offset = 0;
do {
hd = Hd_val (v);
if (hd == 0) {
/* already forwarded, forward pointer is first field. */
*p = Op_val(v)[0] + infix_offset;
return;
}
tag = Tag_hd (hd);
if (tag == Infix_tag) {
/* Infix header, retry with the real block */
CAMLassert (infix_offset == 0);
infix_offset = Infix_offset_hd (hd);
CAMLassert(infix_offset > 0);
v -= infix_offset;
}
} while (tag == Infix_tag);
if (((value)Hp_val(v)) > st->oldest_promoted) {
st->oldest_promoted = (value)Hp_val(v);
}
if (tag == Cont_tag) {
struct stack_info* stk = Ptr_val(Op_val(v)[0]);
CAMLassert(Wosize_hd(hd) == 1 && infix_offset == 0);
result = alloc_shared(1, Cont_tag);
*p = result;
Op_val(result)[0] = Val_ptr(stk);
*Hp_val (v) = 0;
Op_val(v)[0] = result;
if (stk != NULL)
caml_scan_stack(&oldify_one, st, stk);
} else if (tag < Infix_tag) {
value field0;
sz = Wosize_hd (hd);
st->live_bytes += Bhsize_hd(hd);
result = alloc_shared (sz, tag);
*p = result + infix_offset;
field0 = Op_val(v)[0];
CAMLassert (!Is_debug_tag(field0));
*Hp_val (v) = 0; /* Set forward flag */
Op_val(v)[0] = result; /* and forward pointer. */
if (sz > 1){
Op_val (result)[0] = field0;
Op_val (result)[1] = st->todo_list; /* Add this block */
st->todo_list = v; /* to the "to do" list. */
}else{
CAMLassert (sz == 1);
p = Op_val(result);
v = field0;
goto tail_call;
}
} else if (tag >= No_scan_tag) {
sz = Wosize_hd (hd);
st->live_bytes += Bhsize_hd(hd);
result = alloc_shared(sz, tag);
for (i = 0; i < sz; i++) {
value curr = Op_val(v)[i];
Op_val (result)[i] = curr;
}
*Hp_val (v) = 0; /* Set forward flag */
Op_val (v)[0] = result; /* and forward pointer. */
CAMLassert (infix_offset == 0);
*p = result;
} else {
CAMLassert (tag == Forward_tag);
CAMLassert (infix_offset == 0);
value f = Forward_val (v);
tag_t ft = 0;
if (Is_block (f)) {
ft = Tag_val (Hd_val (f) == 0 ? Op_val (f)[0] : f);
}
if (ft == Forward_tag || ft == Lazy_tag || ft == Double_tag) {
/* Do not short-circuit the pointer. Copy as a normal block. */
CAMLassert (Wosize_hd (hd) == 1);
st->live_bytes += Bhsize_hd(hd);
result = alloc_shared (1, Forward_tag);
*p = result;
*Hp_val (v) = 0; /* Set (GC) forward flag */
Op_val (v)[0] = result; /* and forward pointer. */
p = Op_val (result);
v = f;
goto tail_call;
} else {
v = f; /* Follow the forwarding */
goto tail_call; /* then oldify. */
}
}
}
