void caml_empty_mark_stack () {
value v;
while (mark_stack_pop(&v)) mark(v, 10000000);
if (stat_blocks_marked)
caml_gc_log("Finished marking major heap. Marked %u blocks", (unsigned)stat_blocks_marked);
stat_blocks_marked = 0;
}
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;
}
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);
if (Tag_hd (hd_v) == Stack_tag) {
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 = Field(v, i);
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;
}
intnat caml_major_collection_slice(intnat howmuch)
{
intnat computed_work = howmuch ? howmuch : default_slice_budget();
intnat budget = computed_work;
intnat sweep_work, mark_work;
uintnat blocks_marked_before = stat_blocks_marked;
value v;
caml_save_stack_gc();
sweep_work = budget;
budget = caml_sweep(caml_domain_self()->shared_heap, budget);
sweep_work -= budget;
if (gc_phase == Phase_idle) {
caml_do_local_roots(&caml_darken, caml_domain_self());
caml_scan_global_roots(&caml_darken);
gc_phase = Phase_marking;
}
mark_work = budget;
if (mark_stack_pop(&v))
budget = mark(v, budget);
mark_work -= budget;
caml_gc_log("Major slice: %lu alloc, %ld work, %ld sweep, %ld mark (%lu blocks)",
(unsigned long)caml_domain_state->allocated_words,
(long)computed_work, (long)sweep_work, (long)mark_work,
(unsigned long)(stat_blocks_marked - blocks_marked_before));
caml_domain_state->allocated_words = 0;
caml_restore_stack_gc();
if (budget > 0) {
caml_trigger_stw_gc();
caml_handle_gc_interrupt();
}
return computed_work;
}
