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 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);
}
}
}
int caml_mark_object(value p) {
Assert (Is_block(p));
header_t h = Hd_val(p);
/* An object should have one of these statuses:
- UNMARKED: this object has not yet been traced
- MARKED: this object has already been traced or is being traced
- NOT_MARKABLE: this object should be ignored by the GC */
Assert (h && !Has_status_hd(h, global.GARBAGE));
if (Has_status_hd(h, global.UNMARKED)) {
Hd_val(p) = With_status_hd(h, global.MARKED);
return 1;
} else {
return 0;
}
}
static void verify_pool(pool* a, sizeclass sz, struct mem_stats* s) {
value* v;
for (v = a->next_obj; v; v = (value*)v[1]) {
Assert(*v == 0);
}
value* p = (value*)((char*)a + POOL_HEADER_SZ);
value* end = (value*)a + POOL_WSIZE;
mlsize_t wh = wsize_sizeclass[sz];
s->overhead += Wsize_bsize(POOL_HEADER_SZ);
while (p + wh <= end) {
header_t hd = (header_t)*p;
Assert(hd == 0 || !Has_status_hd(hd, global.GARBAGE));
if (hd) {
s->live += Whsize_hd(hd);
s->overhead += wh - Whsize_hd(hd);
s->live_blocks++;
} else {
s->free += wh;
}
p += wh;
}
Assert(end - p == wastage_sizeclass[sz]);
s->overhead += end - p;
s->alloced += POOL_WSIZE;
}
static void verify_large(large_alloc* a, struct mem_stats* s) {
for (; a; a = a->next) {
header_t hd = *(header_t*)((char*)a + LARGE_ALLOC_HEADER_SZ);
Assert (!Has_status_hd(hd, global.GARBAGE));
s->alloced += Wsize_bsize(LARGE_ALLOC_HEADER_SZ) + Whsize_hd(hd);
s->overhead += Wsize_bsize(LARGE_ALLOC_HEADER_SZ);
}
}
void caml_redarken_pool(struct pool* r, scanning_action f, void* fdata) {
mlsize_t wh = wsize_sizeclass[r->sz];
value* p = (value*)((char*)r + POOL_HEADER_SZ);
value* end = (value*)((char*)r + Bsize_wsize(POOL_WSIZE));
while (p + wh <= end) {
header_t hd = p[0];
if (hd != 0 && Has_status_hd(hd, global.MARKED)) {
f(fdata, Val_hp(p), 0);
}
p += wh;
}
}
static intnat large_alloc_sweep(struct caml_heap_state* local) {
large_alloc* a = local->unswept_large;
if (!a) return 0;
local->unswept_large = a->next;
header_t hd = *(header_t*)((char*)a + LARGE_ALLOC_HEADER_SZ);
if (Has_status_hd(hd, global.GARBAGE)) {
local->large_bytes_allocated -= Bhsize_hd(hd);
free(a);
} else {
a->next = local->swept_large;
local->swept_large = a;
}
return Whsize_hd(hd);
}
static intnat pool_sweep(struct caml_heap_state* local, pool** plist, sizeclass sz) {
pool* a = *plist;
if (!a) return 0;
*plist = a->next;
value* p = (value*)((char*)a + POOL_HEADER_SZ);
value* end = (value*)a + POOL_WSIZE;
mlsize_t wh = wsize_sizeclass[sz];
int all_free = 1, all_used = 1;
struct heap_stats* s = &local->stats;
while (p + wh <= end) {
header_t hd = (header_t)*p;
if (hd == 0) {
/* already on freelist */
all_used = 0;
} else if (Has_status_hd(hd, global.GARBAGE)) {
Assert(Whsize_hd(hd) <= wh);
/* add to freelist */
p[0] = 0;
p[1] = (value)a->next_obj;
Assert(Is_block((value)p));
a->next_obj = p;
all_used = 0;
/* update stats */
s->pool_live_blocks--;
s->pool_live_words -= Whsize_hd(hd);
s->pool_frag_words -= (wh - Whsize_hd(hd));
} else {
/* still live */
all_free = 0;
}
p += wh;
}
if (all_free) {
pool_release(local, a, sz);
} else {
pool** list = all_used ? &local->full_pools[sz] : &local->avail_pools[sz];
a->next = *list;
*list = a;
}
return POOL_WSIZE;
}
int is_garbage(value v) {
return Has_status_hd(Hd_val(v), global.GARBAGE);
}
void caml_shared_unpin(value v) {
Assert (Is_block(v) && !Is_minor(v));
Assert (caml_owner_of_shared_block(v) == caml_domain_self());
Assert (Has_status_hd(Hd_val(v), NOT_MARKABLE));
Hd_val(v) = With_status_hd(Hd_val(v), global.UNMARKED);
}
