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); } } }
struct pool* caml_pool_of_shared_block(value v) { Assert (Is_block(v) && !Is_minor(v)); mlsize_t whsize = Whsize_wosize(Wosize_val(v)); if (whsize > 0 && whsize <= SIZECLASS_MAX) { return (pool*)((uintnat)v &~(POOL_WSIZE * sizeof(value) - 1)); } else { return 0; } }
static value caml_promote_one(struct promotion_stack* stk, struct domain* domain, value curr) { header_t curr_block_hd; int infix_offset = 0; if (Is_long(curr) || !Is_minor(curr)) return curr; /* needs no promotion */ Assert(caml_owner_of_young_block(curr) == domain); curr_block_hd = Hd_val(curr); if (Tag_hd(curr_block_hd) == Infix_tag) { infix_offset = Infix_offset_val(curr); curr -= infix_offset; curr_block_hd = Hd_val(curr); } if (Is_promoted_hd(curr_block_hd)) { /* already promoted */ return caml_addrmap_lookup(&domain->state->remembered_set->promotion, curr) + infix_offset; } else if (curr_block_hd == 0) { /* promoted by minor GC */ return Op_val(curr)[0] + infix_offset; } /* otherwise, must promote */ void* mem = caml_shared_try_alloc(domain->shared_heap, Wosize_hd(curr_block_hd), Tag_hd(curr_block_hd), 1); if (!mem) caml_fatal_error("allocation failure during promotion"); value promoted = Val_hp(mem); Hd_val(curr) = Promotedhd_hd(curr_block_hd); caml_addrmap_insert(&domain->state->remembered_set->promotion, curr, promoted); caml_addrmap_insert(&domain->state->remembered_set->promotion_rev, promoted, curr); if (Tag_hd(curr_block_hd) >= No_scan_tag) { int i; for (i = 0; i < Wosize_hd(curr_block_hd); i++) Op_val(promoted)[i] = Op_val(curr)[i]; } else { /* push to stack */ if (stk->sp == stk->stack_len) { stk->stack_len = 2 * (stk->stack_len + 10); stk->stack = caml_stat_resize(stk->stack, sizeof(struct promotion_stack_entry) * stk->stack_len); } stk->stack[stk->sp].local = curr; stk->stack[stk->sp].global = promoted; stk->stack[stk->sp].field = 0; stk->sp++; } return promoted + infix_offset; }
static void scan_global_roots(scanning_action f) { value r, newr; caml_plat_lock(&roots_mutex); r = roots_all; caml_plat_unlock(&roots_mutex); Assert(!Is_minor(r)); newr = r; f(newr, &newr); Assert(r == newr); /* GC should not move r, it is not young */ }
struct domain* caml_owner_of_shared_block(value v) { Assert (Is_block(v) && !Is_minor(v)); mlsize_t whsize = Whsize_wosize(Wosize_val(v)); Assert (whsize > 0); /* not an atom */ if (whsize <= SIZECLASS_MAX) { /* FIXME: ORD: if we see the object, we must see the owner */ pool* p = (pool*)((uintnat)v &~(POOL_WSIZE * sizeof(value) - 1)); return p->owner; } else { large_alloc* a = (large_alloc*)(Hp_val(v) - LARGE_ALLOC_HEADER_SZ); return a->owner; } }
CAMLexport const value* caml_named_value(char const *name) { struct named_value * nv; caml_root ret = NULL; caml_plat_lock(&named_value_lock); for (nv = named_value_table[hash_value_name(name)]; nv != NULL; nv = nv->next) { if (strcmp(name, nv->name) == 0){ ret = nv->val; break; } } caml_plat_unlock(&named_value_lock); /* *ret should never be a minor object, since caml_create_root promotes */ CAMLassert (!(ret && Is_minor(caml_read_root(ret)))); return Op_val(ret); }
CAMLexport value caml_promote(struct domain* domain, value root) { struct promotion_stack stk = {0}; if (Is_long(root)) /* Integers are already shared */ return root; if (Tag_val(root) == Stack_tag) /* Stacks are handled specially */ return promote_stack(domain, root); if (!Is_minor(root)) /* This value is already shared */ return root; Assert(caml_owner_of_young_block(root) == domain); value ret = caml_promote_one(&stk, domain, root); while (stk.sp > 0) { struct promotion_stack_entry* curr = &stk.stack[stk.sp - 1]; value local = curr->local; value global = curr->global; int field = curr->field; Assert(field < Wosize_val(local)); curr->field++; if (curr->field == Wosize_val(local)) stk.sp--; value x = Op_val(local)[field]; if (Is_block(x) && Tag_val(x) == Stack_tag) { /* stacks are not promoted unless explicitly requested */ Ref_table_add(&domain->state->remembered_set->ref, global, field); } else { x = caml_promote_one(&stk, domain, x); } Op_val(local)[field] = Op_val(global)[field] = x; } caml_stat_free(stk.stack); return ret; }
static value promote_stack(struct domain* domain, value stack) { caml_gc_log("Promoting stack"); Assert(Tag_val(stack) == Stack_tag); if (Is_minor(stack)) { /* First, promote the actual stack object */ Assert(caml_owner_of_young_block(stack) == domain); /* Stacks are only referenced via fibers, so we don't bother using the promotion_table */ void* new_stack = caml_shared_try_alloc(domain->shared_heap, Wosize_val(stack), Stack_tag, 0); if (!new_stack) caml_fatal_error("allocation failure during stack promotion"); memcpy(Op_hp(new_stack), (void*)stack, Wosize_val(stack) * sizeof(value)); stack = Val_hp(new_stack); } /* Promote each object on the stack. */ promote_domain = domain; caml_scan_stack(&promote_stack_elem, stack); /* Since we've promoted the objects on the stack, the stack is now clean. */ caml_clean_stack_domain(stack, domain); return stack; }
void forward_pointer (void* state, value v, value *p) { header_t hd; mlsize_t offset; value fwd; struct domain* promote_domain = state; caml_domain_state* domain_state = promote_domain ? promote_domain->state : Caml_state; char* young_ptr = domain_state->young_ptr; char* young_end = domain_state->young_end; if (Is_block (v) && is_in_interval((value)Hp_val(v), young_ptr, young_end)) { hd = Hd_val(v); if (hd == 0) { *p = Op_val(v)[0]; CAMLassert (Is_block(*p) && !Is_minor(*p)); } else if (Tag_hd(hd) == Infix_tag) { offset = Infix_offset_hd(hd); fwd = 0; forward_pointer (state, v - offset, &fwd); if (fwd) *p = fwd + offset; } } }
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 }
CAMLexport value caml_promote(struct domain* domain, value root) { value **r; value iter, f; mlsize_t i; caml_domain_state* domain_state = domain->state; struct caml_minor_tables *minor_tables = domain_state->minor_tables; char* young_ptr = domain_state->young_ptr; char* young_end = domain_state->young_end; float percent_to_scan; uintnat prev_alloc_words = domain_state->allocated_words; struct oldify_state st = {0}; struct caml_ephe_ref_elt *re; /* Integers are already shared */ if (Is_long(root)) return root; /* Objects which are in the major heap are already shared. */ if (!Is_minor(root)) return root; st.oldest_promoted = (value)domain_state->young_start; st.promote_domain = domain; CAMLassert(caml_owner_of_young_block(root) == domain); oldify_one (&st, root, &root); oldify_mopup (&st); CAMLassert (!Is_minor(root)); /* FIXME: surely a newly-allocated root is already darkened? */ caml_darken(0, root, 0); percent_to_scan = st.oldest_promoted <= (value)young_ptr ? 0.0 : (((float)(st.oldest_promoted - (value)young_ptr)) * 100.0 / ((value)young_end - (value)domain_state->young_start)); if (percent_to_scan > Percent_to_promote_with_GC) { caml_gc_log("caml_promote: forcing minor GC. %%_minor_to_scan=%f", percent_to_scan); // ??? caml_empty_minor_heap_domain (domain); } else { caml_do_local_roots (&forward_pointer, st.promote_domain, domain, 1); caml_scan_stack (&forward_pointer, st.promote_domain, domain_state->current_stack); /* Scan major to young pointers. */ for (r = minor_tables->major_ref.base; r < minor_tables->major_ref.ptr; r++) { value old_p = **r; if (Is_block(old_p) && is_in_interval(old_p,young_ptr,young_end)) { value new_p = old_p; forward_pointer (st.promote_domain, new_p, &new_p); if (old_p != new_p) { if (caml_domain_alone()) **r = new_p; else atomic_compare_exchange_strong((atomic_value*)*r, &old_p, new_p); } } } /* Scan ephemeron ref table */ for (re = minor_tables->ephe_ref.base; re < minor_tables->ephe_ref.ptr; re++) { value* key = &Op_val(re->ephe)[re->offset]; if (Is_block(*key) && is_in_interval(*key,young_ptr,young_end)) { forward_pointer (st.promote_domain, *key, key); } } /* Scan young to young pointers */ for (r = minor_tables->minor_ref.base; r < minor_tables->minor_ref.ptr; r++) { forward_pointer (st.promote_domain, **r, *r); } /* Scan newer objects */ for (iter = (value)young_ptr; iter <= st.oldest_promoted; iter = next_minor_block(domain_state, iter)) { value hd = Hd_hp(iter); value curr = Val_hp(iter); if (hd != 0) { tag_t tag = Tag_hd (hd); if (tag == Cont_tag) { struct stack_info* stk = Ptr_val(Op_val(curr)[0]); if (stk != NULL) caml_scan_stack(&forward_pointer, st.promote_domain, stk); } else if (tag < No_scan_tag) { for (i = 0; i < Wosize_hd (hd); i++) { f = Op_val(curr)[i]; if (Is_block(f)) { forward_pointer (st.promote_domain, f,((value*)curr) + i); } } } } } } domain_state->stat_promoted_words += domain_state->allocated_words - prev_alloc_words; return root; }
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); }