static void verify_object(struct heap_verify_state* st, value v) {
if (!Is_block(v)) return;
Assert (Hd_val(v));
if (Tag_val(v) == Infix_tag) {
v -= Infix_offset_val(v);
Assert(Tag_val(v) == Closure_tag);
}
intnat* entry = caml_addrmap_insert_pos(&st->seen, v);
if (*entry != ADDRMAP_NOT_PRESENT) return;
*entry = 1;
if (Has_status_hd(Hd_val(v), NOT_MARKABLE)) return;
st->objs++;
// caml_gc_log ("verify_object: v=0x%lx hd=0x%lx tag=%u", v, Hd_val(v), Tag_val(v));
if (!Is_minor(v)) {
Assert(Has_status_hd(Hd_val(v), global.UNMARKED));
}
if (Tag_val(v) == Stack_tag) {
caml_scan_stack(verify_push, st, v);
} else if (Tag_val(v) < No_scan_tag) {
int i;
for (i = 0; i < Wosize_val(v); i++) {
value f = Op_val(v)[i];
if (Is_minor(v) && Is_minor(f)) {
Assert(caml_owner_of_young_block(v) ==
caml_owner_of_young_block(f));
}
if (Is_block(f)) verify_push(st, f, 0);
}
}
}
static void verify_object(value v) {
if (!Is_block(v)) return;
if (Tag_val(v) == Infix_tag) {
v -= Infix_offset_val(v);
Assert(Tag_val(v) == Closure_tag);
}
intnat* entry = caml_addrmap_insert_pos(&verify_seen, v);
if (*entry != ADDRMAP_NOT_PRESENT) return;
*entry = 1;
if (Has_status_hd(Hd_val(v), NOT_MARKABLE)) return;
verify_objs++;
if (!Is_minor(v)) {
Assert(Has_status_hd(Hd_val(v), global.MARKED));
}
if (Tag_val(v) == Stack_tag) {
caml_scan_stack(verify_push, v);
} else if (Tag_val(v) < No_scan_tag) {
int i;
for (i = 0; i < Wosize_val(v); i++) {
value f = Op_val(v)[i];
if (Is_minor(v) && Is_minor(f)) {
Assert(caml_owner_of_young_block(v) ==
caml_owner_of_young_block(f));
}
if (Is_block(f)) verify_push(f, 0);
}
}
}
static void mark_stack_prune ()
{
struct addrmap t = ADDRMAP_INIT;
int count = 0, entry;
addrmap_iterator i;
uintnat mark_stack_count = caml_domain_state->mark_stack_count;
value* mark_stack = caml_domain_state->mark_stack;
/* space used by the computations below */
uintnat table_max = mark_stack_count / 100;
if (table_max < 1000) table_max = 1000;
/* amount of space we want to free up */
int entries_to_free = (uintnat)(mark_stack_count * 0.20);
/* We compress the mark stack by removing all of the objects from a
subset of pools, which are rescanned later. For efficiency, we
want to select those pools which occur most frequently, so that
we need to rescan as few pools as possible. However, we do not
have space to build a complete histogram.
Using ~1% of the mark stack's space, we can find all of the
elements that occur at least 100 times using the Misra-Gries
heavy hitter algorithm (see J. Misra and D. Gries, "Finding
repeated elements", 1982). */
for (entry = 0; entry < mark_stack_count; entry++) {
struct pool* pool = caml_pool_of_shared_block(mark_stack[entry]);
if (!pool) continue;
value p = (value)pool;
if (caml_addrmap_contains(&t, p)) {
/* if it's already present, increase the count */
(*caml_addrmap_insert_pos(&t, p)) ++;
} else if (count < table_max) {
/* if there's space, insert it with count 1 */
*caml_addrmap_insert_pos(&t, p) = 1;
count++;
} else {
/* otherwise, decrease all entries by 1 */
struct addrmap s = ADDRMAP_INIT;
int scount = 0;
for (i = caml_addrmap_iterator(&t);
caml_addrmap_iter_ok(&t, i);
i = caml_addrmap_next(&t, i)) {
value k = caml_addrmap_iter_key(&t, i);
value v = caml_addrmap_iter_value(&t, i);
if (v > 1) {
*caml_addrmap_insert_pos(&s, k) = v - 1;
scount++;
}
}
caml_addrmap_clear(&t);
t = s;
count = scount;
}
}
/* t now contains all pools that occur at least 100 times.
If no pools occur at least 100 times, t is some arbitrary subset of pools.
Next, we get an accurate count of the occurrences of the pools in t */
for (i = caml_addrmap_iterator(&t);
caml_addrmap_iter_ok(&t, i);
i = caml_addrmap_next(&t, i)) {
*caml_addrmap_iter_val_pos(&t, i) = 0;
}
for (entry = 0; entry < mark_stack_count; entry++) {
value p = (value)caml_pool_of_shared_block(mark_stack[entry]);
if (p && caml_addrmap_contains(&t, p))
(*caml_addrmap_insert_pos(&t, p))++;
}
/* Next, find a subset of those pools that covers enough entries */
struct pool_count* pools = caml_stat_alloc(count * sizeof(struct pool_count));
int pos = 0;
for (i = caml_addrmap_iterator(&t);
caml_addrmap_iter_ok(&t, i);
i = caml_addrmap_next(&t, i)) {
struct pool_count* p = &pools[pos++];
p->pool = (struct pool*)caml_addrmap_iter_key(&t, i);
p->occurs = (int)caml_addrmap_iter_value(&t, i);
}
Assert(pos == count);
caml_addrmap_clear(&t);
qsort(pools, count, sizeof(struct pool_count), &pool_count_cmp);
int start = count, total = 0;
while (start > 0 && total < entries_to_free) {
start--;
total += pools[start].occurs;
}
for (i = start; i < count; i++) {
*caml_addrmap_insert_pos(&t, (value)pools[i].pool) = 1;
}
int out = 0;
for (entry = 0; entry < mark_stack_count; entry++) {
value v = mark_stack[entry];
value p = (value)caml_pool_of_shared_block(v);
if (!(p && caml_addrmap_contains(&t, p))) {
mark_stack[out++] = v;
}
}
caml_domain_state->mark_stack_count = out;
caml_gc_log("Mark stack overflow. Postponing %d pools (%.1f%%, leaving %d).",
count-start, 100. * (double)total / (double)mark_stack_count,
(int)caml_domain_state->mark_stack_count);
/* Add the pools to rescan to the global list.
This must be done after the mark stack is filtered, since other
threads race to remove pools from the global list. As soon as
pools_to_rescan_lock is released, we cannot rely on pools being
in the global list. */
caml_plat_lock(&pools_to_rescan_lock);
for (i = start; i < count; i++) {
if (pools_to_rescan_count == pools_to_rescan_len) {
pools_to_rescan_len = pools_to_rescan_len * 2 + 128;
pools_to_rescan =
caml_stat_resize(pools_to_rescan, pools_to_rescan_len * sizeof(struct pool*));
}
pools_to_rescan[pools_to_rescan_count++] = pools[i].pool;
}
caml_plat_unlock(&pools_to_rescan_lock);
}
void caml_empty_minor_heap_domain (struct domain* domain)
{
CAMLnoalloc;
caml_domain_state* domain_state = domain->state;
struct caml_minor_tables *minor_tables = domain_state->minor_tables;
unsigned rewrite_successes = 0;
unsigned rewrite_failures = 0;
char* young_ptr = domain_state->young_ptr;
char* young_end = domain_state->young_end;
uintnat minor_allocated_bytes = young_end - young_ptr;
struct oldify_state st = {0};
value **r;
struct caml_ephe_ref_elt *re;
struct caml_custom_elt *elt;
st.promote_domain = domain;
if (minor_allocated_bytes != 0) {
uintnat prev_alloc_words = domain_state->allocated_words;
#ifdef DEBUG
/* In DEBUG mode, verify that the minor_ref table contains all young-young pointers
from older to younger objects */
{
struct addrmap young_young_ptrs = ADDRMAP_INIT;
mlsize_t i;
value iter;
for (r = minor_tables->minor_ref.base; r < minor_tables->minor_ref.ptr; r++) {
*caml_addrmap_insert_pos(&young_young_ptrs, (value)*r) = 1;
}
for (iter = (value)young_ptr;
iter < (value)young_end;
iter = next_minor_block(domain_state, iter)) {
value hd = Hd_hp(iter);
if (hd != 0) {
value curr = Val_hp(iter);
tag_t tag = Tag_hd (hd);
if (tag < No_scan_tag && tag != Cont_tag) {
// FIXME: should scan Cont_tag
for (i = 0; i < Wosize_hd(hd); i++) {
value* f = Op_val(curr) + i;
if (Is_block(*f) && is_in_interval(*f, young_ptr, young_end) &&
*f < curr) {
CAMLassert(caml_addrmap_contains(&young_young_ptrs, (value)f));
}
}
}
}
}
caml_addrmap_clear(&young_young_ptrs);
}
#endif
caml_gc_log ("Minor collection of domain %d starting", domain->state->id);
caml_ev_begin("minor_gc");
caml_ev_begin("minor_gc/roots");
caml_do_local_roots(&oldify_one, &st, domain, 0);
caml_scan_stack(&oldify_one, &st, domain_state->current_stack);
for (r = minor_tables->major_ref.base; r < minor_tables->major_ref.ptr; r++) {
value x = **r;
oldify_one (&st, x, &x);
}
caml_ev_end("minor_gc/roots");
caml_ev_begin("minor_gc/promote");
oldify_mopup (&st);
caml_ev_end("minor_gc/promote");
caml_ev_begin("minor_gc/ephemerons");
for (re = minor_tables->ephe_ref.base;
re < minor_tables->ephe_ref.ptr; re++) {
CAMLassert (Ephe_domain(re->ephe) == domain);
if (re->offset == CAML_EPHE_DATA_OFFSET) {
/* Data field has already been handled in oldify_mopup. Handle only
* keys here. */
continue;
}
value* key = &Op_val(re->ephe)[re->offset];
if (*key != caml_ephe_none && Is_block(*key) &&
is_in_interval(*key, young_ptr, young_end)) {
resolve_infix_val(key);
if (Hd_val(*key) == 0) { /* value copied to major heap */
*key = Op_val(*key)[0];
} else {
CAMLassert(!ephe_check_alive_data(re,young_ptr,young_end));
*key = caml_ephe_none;
Ephe_data(re->ephe) = caml_ephe_none;
}
}
}
caml_ev_end("minor_gc/ephemerons");
caml_ev_begin("minor_gc/update_minor_tables");
for (r = minor_tables->major_ref.base;
r < minor_tables->major_ref.ptr; r++) {
value v = **r;
if (Is_block (v) && is_in_interval ((value)Hp_val(v), young_ptr, young_end)) {
value vnew;
header_t hd = Hd_val(v);
int offset = 0;
if (Tag_hd(hd) == Infix_tag) {
offset = Infix_offset_hd(hd);
v -= offset;
}
CAMLassert (Hd_val(v) == 0);
vnew = Op_val(v)[0] + offset;
CAMLassert (Is_block(vnew) && !Is_minor(vnew));
CAMLassert (Hd_val(vnew));
if (Tag_hd(hd) == Infix_tag) {
CAMLassert(Tag_val(vnew) == Infix_tag);
v += offset;
}
if (caml_domain_alone()) {
**r = vnew;
++rewrite_successes;
} else {
if (atomic_compare_exchange_strong((atomic_value*)*r, &v, vnew))
++rewrite_successes;
else
++rewrite_failures;
}
}
}
CAMLassert (!caml_domain_alone() || rewrite_failures == 0);
caml_ev_end("minor_gc/update_minor_tables");
caml_ev_begin("minor_gc/finalisers");
caml_final_update_last_minor(domain);
/* Run custom block finalisation of dead minor values */
for (elt = minor_tables->custom.base; elt < minor_tables->custom.ptr; elt++) {
value v = elt->block;
if (Hd_val(v) == 0) {
/* !!caml_adjust_gc_speed(elt->mem, elt->max); */
} else {
/* Block will be freed: call finalisation function, if any */
void (*final_fun)(value) = Custom_ops_val(v)->finalize;
if (final_fun != NULL) final_fun(v);
}
}
caml_final_empty_young(domain);
caml_ev_end("minor_gc/finalisers");
clear_table ((struct generic_table *)&minor_tables->major_ref);
clear_table ((struct generic_table *)&minor_tables->minor_ref);
clear_table ((struct generic_table *)&minor_tables->ephe_ref);
clear_table ((struct generic_table *)&minor_tables->custom);
domain_state->young_ptr = domain_state->young_end;
domain_state->stat_minor_words += Wsize_bsize (minor_allocated_bytes);
domain_state->stat_minor_collections++;
domain_state->stat_promoted_words += domain_state->allocated_words - prev_alloc_words;
caml_ev_end("minor_gc");
caml_gc_log ("Minor collection of domain %d completed: %2.0f%% of %u KB live, rewrite: successes=%u failures=%u",
domain->state->id,
100.0 * (double)st.live_bytes / (double)minor_allocated_bytes,
(unsigned)(minor_allocated_bytes + 512)/1024, rewrite_successes, rewrite_failures);
}
else {
caml_final_empty_young(domain);
caml_gc_log ("Minor collection of domain %d: skipping", domain->state->id);
}
#ifdef DEBUG
{
value *p;
for (p = (value *) domain_state->young_start;
p < (value *) domain_state->young_end; ++p){
*p = Debug_free_minor;
}
}
#endif
}
