Skip to content

Instantly share code, notes, and snippets.

@kayceesrk

kayceesrk/move.diff

Created April 10, 2016 10:58
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save kayceesrk/98c83929a5eafef2c5a67d0b5ed80308 to your computer and use it in GitHub Desktop.
Save kayceesrk/98c83929a5eafef2c5a67d0b5ed80308 to your computer and use it in GitHub Desktop.
Download ZIP
move.diff
Raw
move.diff
diff --git a/boot/ocamlc b/boot/ocamlc
index 6c7ba14..c063309 100755
Binary files a/boot/ocamlc and b/boot/ocamlc differ
diff --git a/boot/ocamldep b/boot/ocamldep
index 29ad003..26935c5 100755
Binary files a/boot/ocamldep and b/boot/ocamldep differ
diff --git a/boot/ocamllex b/boot/ocamllex
index 2e40046..5da3c7e 100755
Binary files a/boot/ocamllex and b/boot/ocamllex differ
diff --git a/byterun/addrmap.c b/byterun/addrmap.c
index f2859dd..0597618 100644
--- a/byterun/addrmap.c
+++ b/byterun/addrmap.c
@@ -6,7 +6,7 @@
static const value INVALID_KEY = (value)0;
-static uintnat pos_initial(struct addrmap* t, value key)
+static uintnat pos_initial(struct addrmap* t, value key)
{
uintnat pos = (uintnat)key;
pos *= 0xcc9e2d51;
@@ -25,7 +25,7 @@ value caml_addrmap_lookup(struct addrmap* t, value key)
{
Assert(Is_block(key));
Assert(t->entries);
-
+
uintnat pos;
for (pos = pos_initial(t, key); ; pos = pos_next(t, pos)) {
Assert(t->entries[pos].key != INVALID_KEY);
@@ -63,8 +63,8 @@ value* caml_addrmap_insert_pos(struct addrmap* t, value key) {
/* first call, initialise table with a small initial size */
addrmap_alloc(t, 256);
}
- for (i = 0, pos = pos_initial(t, key);
- i < MAX_CHAIN;
+ for (i = 0, pos = pos_initial(t, key);
+ i < MAX_CHAIN;
i++, pos = pos_next(t, pos)) {
if (t->entries[pos].key == INVALID_KEY) {
t->entries[pos].key = key;
diff --git a/byterun/domain.c b/byterun/domain.c
index 9924748..fa5d05b 100644
--- a/byterun/domain.c
+++ b/byterun/domain.c
@@ -280,7 +280,6 @@ CAMLprim value caml_domain_spawn(value callback)
int err;
caml_plat_event_init(&p.ev);
-
p.callback = caml_promote(&domain_self->state, callback);
err = pthread_create(&th, 0, domain_thread_func, (void*)&p);
@@ -426,9 +425,6 @@ CAMLexport void caml_enter_blocking_section() {
static atomic_uintnat heaps_marked;
static atomic_uintnat domain_accounted_for[Max_domains];
-extern void caml_empty_minor_heap_domain (struct domain*);
-extern void caml_finish_marking_domain (struct domain*);
-
static void stw_phase () {
int i;
int my_heaps = 0;
@@ -477,8 +473,8 @@ static void stw_phase () {
/* GC some inactive domain that we locked */
caml_gc_log("GCing inactive domain [%02d]", d->state.id);
while (caml_sweep(d->state.shared_heap, 10) <= 0);
- caml_empty_minor_heap_domain(&d->state);
- caml_finish_marking_domain(&d->state);
+ caml_do_sampled_roots(&caml_darken, &d->state);
+ caml_empty_mark_stack();
}
}
diff --git a/byterun/domain.h b/byterun/domain.h
index 5b1a66a..cc6b47b 100644
--- a/byterun/domain.h
+++ b/byterun/domain.h
@@ -3,7 +3,6 @@
#include "mlvalues.h"
#include "domain_state.h"
-#include "memory.h"
struct domain {
int id;
@@ -13,6 +12,7 @@ struct domain {
struct dom_internal* internals;
struct caml_heap_state* shared_heap;
struct caml_remembered_set* remembered_set;
+
struct caml__roots_block** local_roots;
#ifdef NATIVE_CODE
/* FIXME: represent current stack here */
diff --git a/byterun/fiber.c b/byterun/fiber.c
index 72852e7..6e08e13 100644
--- a/byterun/fiber.c
+++ b/byterun/fiber.c
@@ -7,8 +7,6 @@
#include "alloc.h"
#include "platform.h"
#include "fix_code.h"
-#include "minor_gc.h"
-#include "shared_heap.h"
#ifdef NATIVE_CODE
@@ -34,12 +32,6 @@ void caml_scan_dirty_stack(scanning_action f, value stack)
caml_fatal_error("Fibers unimplemented");
}
-void caml_scan_dirty_stack_domain(scanning_action f, value stack,
- struct domain* domain)
-{
- caml_fatal_error("Fibers unimplemented");
-}
-
void caml_clean_stack(value stack)
{
caml_fatal_error("Fibers unimplemented");
@@ -49,8 +41,6 @@ void caml_clean_stack_domain(value stack, struct domain* domain)
{
caml_fatal_error("Fibers unimplemented");
}
-
-
#else
CAMLexport __thread value caml_current_stack;
@@ -67,8 +57,6 @@ static void dirty_stack(value);
static value save_stack ()
{
- Assert (Hd_val(caml_current_stack) &&
- (Is_minor(caml_current_stack) || !is_garbage(caml_current_stack)));
value old_stack = caml_current_stack;
Stack_sp(old_stack) = caml_extern_sp - caml_stack_high;
Assert(caml_stack_threshold == Stack_base(old_stack) + Stack_threshold / sizeof(value));
@@ -80,15 +68,11 @@ static value save_stack ()
static void load_stack(value newstack)
{
- Assert (Hd_val(newstack) &&
- (Is_minor(newstack) || !is_garbage(newstack)));
Assert(Tag_val(newstack) == Stack_tag);
- Assert(Stack_dirty_domain(newstack) == 0 || Stack_dirty_domain(newstack) == caml_domain_self());
caml_stack_threshold = Stack_base(newstack) + Stack_threshold / sizeof(value);
caml_stack_high = Stack_high(newstack);
caml_extern_sp = caml_stack_high + Stack_sp(newstack);
caml_current_stack = newstack;
- caml_scan_stack (forward_pointer, newstack);
}
#define Fiber_stack_wosize ((Stack_threshold / sizeof(value)) *2)
@@ -147,13 +131,12 @@ void caml_init_main_stack()
the effect if necessary.
Reverses the parent pointers to point
- performer -> delegator instead of
+ performer -> delegator instead of
delegator -> performer.
*/
value caml_find_performer(value stack)
{
value parent = caml_current_stack;
- Assert (Hd_val(parent) && (Is_minor(parent) || !is_garbage(parent)));
do {
value delegator = Stack_parent(stack);
Stack_parent(stack) = parent;
@@ -256,19 +239,14 @@ void caml_save_stack_gc()
{
Assert(!stack_is_saved);
save_stack();
- ++stack_is_saved;
+ stack_is_saved = 1;
}
void caml_restore_stack_gc()
{
Assert(stack_is_saved);
load_stack(caml_current_stack);
- --stack_is_saved;
-}
-
-int caml_stack_is_saved (void)
-{
- return stack_is_saved;
+ stack_is_saved = 0;
}
static void dirty_stack(value stack)
@@ -282,7 +260,7 @@ static void dirty_stack(value stack)
Stack_dirty_domain(stack) == caml_domain_self());
if (Stack_dirty_domain(stack) == 0) {
Stack_dirty_domain(stack) = caml_domain_self();
- Ref_table_add(&caml_remembered_set.fiber_ref, (value*)stack);
+ Ref_table_add(&caml_remembered_set.fiber_ref, stack, 0);
}
}
}
@@ -295,15 +273,6 @@ void caml_scan_dirty_stack(scanning_action f, value stack)
}
}
-void caml_scan_dirty_stack_domain(scanning_action f, value stack,
- struct domain* domain)
-{
- Assert (Tag_val(stack) == Stack_tag);
- if (Stack_dirty_domain(stack) == domain) {
- caml_scan_stack(f, stack);
- }
-}
-
void caml_clean_stack(value stack)
{
Assert(Tag_val(stack) == Stack_tag);
@@ -325,6 +294,9 @@ void caml_scan_stack(scanning_action f, value stack)
value *low, *high, *sp;
Assert(Is_block(stack) && Tag_val(stack) == Stack_tag);
+ if (Is_promoted_hd(Hd_val(stack)))
+ Assert(!Is_young(stack)); //FIXME
+
f(Stack_handle_value(stack), &Stack_handle_value(stack));
f(Stack_handle_exception(stack), &Stack_handle_exception(stack));
f(Stack_handle_effect(stack), &Stack_handle_effect(stack));
diff --git a/byterun/fiber.h b/byterun/fiber.h
index cfa480b..5eb7efc 100644
--- a/byterun/fiber.h
+++ b/byterun/fiber.h
@@ -28,15 +28,13 @@ CAMLextern __thread intnat caml_trap_barrier_off;
value caml_find_performer(value stack);
-void caml_scan_stack(scanning_action, value stack);
void caml_scan_dirty_stack(scanning_action, value stack);
-void caml_scan_dirty_stack_domain(scanning_action f, value stack,
- struct domain* domain);
+void caml_scan_stack(scanning_action, value stack);
+void caml_save_stack_gc();
+void caml_restore_stack_gc();
void caml_clean_stack(value stack);
void caml_clean_stack_domain(value stack, struct domain* domain);
-void caml_save_stack_gc();
-void caml_restore_stack_gc();
/* The table of global identifiers */
extern caml_root caml_global_data;
diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index dee267a..b05092e 100644
--- a/byterun/gc_ctrl.c
+++ b/byterun/gc_ctrl.c
@@ -460,8 +460,9 @@ uintnat caml_normalize_heap_increment (uintnat i)
void caml_init_gc ()
{
-/* uintnat major_heap_size =
- Bsize_wsize (caml_normalize_heap_increment (caml_startup_params.heap_size_init)); */
+ uintnat
+major_heap_size =
+ Bsize_wsize (caml_normalize_heap_increment (caml_startup_params.heap_size_init));
caml_max_stack_size = caml_startup_params.max_stack_init;
caml_percent_free = norm_pfree (caml_startup_params.percent_free_init);
diff --git a/byterun/globroots.c b/byterun/globroots.c
index 9b482bc..3f28e50 100644
--- a/byterun/globroots.c
+++ b/byterun/globroots.c
@@ -43,18 +43,18 @@ static caml_plat_mutex roots_mutex;
static value roots_all = Val_unit;
-void caml_init_global_roots()
+void caml_init_global_roots()
{
caml_plat_mutex_init(&roots_mutex);
}
-CAMLexport caml_root caml_create_root(value init)
+CAMLexport caml_root caml_create_root(value init)
{
CAMLparam1(init);
value v = caml_alloc_shr(3, 0);
caml_initialize_field(v, 0, init);
caml_initialize_field(v, 1, Val_int(1));
-
+
caml_plat_lock(&roots_mutex);
caml_initialize_field(v, 2, roots_all);
roots_all = v;
@@ -76,8 +76,6 @@ CAMLexport value caml_read_root(caml_root root)
{
value v = (value)root;
Assert(root);
- Assert(Hd_val(root));
- Assert(Field(v,1) == Val_int(0) || Field(v,1) == Val_int(1));
return Field(v, 0);
}
@@ -94,7 +92,7 @@ static void scan_global_roots(scanning_action f)
caml_plat_lock(&roots_mutex);
r = roots_all;
caml_plat_unlock(&roots_mutex);
-
+
Assert(!Is_minor(r));
newr = r;
f(newr, &newr);
@@ -178,7 +176,7 @@ static void scan_native_globals(scanning_action f)
iter_list(dyn_globals, lnk) {
glob = (value) lnk->data;
for (j = 0; j < Wosize_val(glob); j++){
- f (Op_val(glob)[j], &Op_val(glob)[j]);
+ f (Op_val(glob)[j], &Op_val(glob)[j]);
}
}
}
diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c
index 63e81e9..d2bb850 100644
--- a/byterun/instrtrace.c
+++ b/byterun/instrtrace.c
@@ -96,10 +96,10 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f)
fprintf (f, "%#lx", v);
if (!v)
return;
- if (prog && (v & 1) && ((value)(Pc_val(v))) % sizeof (int) == 0
- && Pc_val(v) >= prog
- && Pc_val(v) < (code_t) ((char *) prog + proglen))
- fprintf (f, "=code@%ld", Pc_val(v) - prog);
+ if (prog && v % sizeof (int) == 0
+ && (code_t) v >= prog
+ && (code_t) v < (code_t) ((char *) prog + proglen))
+ fprintf (f, "=code@%ld", (code_t) v - prog);
else if (Is_long (v))
fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v));
else if (caml_on_current_stack((value*)v))
diff --git a/byterun/intern.c b/byterun/intern.c
index c3453bc..aa7c956 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -210,7 +210,7 @@ static void stack_realloc(struct intern_stack* s, value save) {
}
intern_stack_item* new_vals = caml_stat_alloc(new_len * STACK_NFIELDS * sizeof(value));
-
+
for (i = 0; i < s->sp; i++) {
STACK_VAL(new_vals, i) = STACK_VAL(s->curr_vals, i);
STACK_FIELD(new_vals, i) = STACK_FIELD(s->curr_vals, i);
@@ -226,7 +226,7 @@ static void stack_realloc(struct intern_stack* s, value save) {
}
if (s->curr_vals != s->first_vals) caml_stat_free(s->curr_vals);
-
+
/* register GC root */
s->curr_vals = new_vals;
s->len = new_len;
@@ -333,7 +333,7 @@ static value intern_rec(mlsize_t whsize, mlsize_t num_objects)
/* The un-marshaler loop, the recursion is unrolled */
while (!stack_is_empty(&S)) {
-
+
/* Interpret next item on the stack */
dest = stack_curr_val(&S);
curr_field = stack_curr_field(&S);
@@ -575,7 +575,7 @@ value caml_input_val(struct channel *chan)
/* Fill it in */
res = intern_rec(whsize, num_objects);
/* Free everything */
- /* !!
+ /* !!
caml_stat_free(intern_input);
*/
res = caml_check_urgent_gc(res);
diff --git a/byterun/interp.c b/byterun/interp.c
index 2c30e87..d1a9ef6 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -232,12 +232,12 @@ value caml_interprete(code_t prog, asize_t prog_size)
#ifdef THREADED_CODE
caml_instr_table = (char **) jumptable;
caml_instr_base = Jumptbl_base;
- caml_thread_code(raise_unhandled_code,
+ caml_thread_code(raise_unhandled_code,
sizeof(raise_unhandled_code));
#endif
value raise_unhandled_closure =
caml_alloc_small(1, Closure_tag);
- Init_field(raise_unhandled_closure, 0,
+ Init_field(raise_unhandled_closure, 0,
Val_bytecode(raise_unhandled_code));
raise_unhandled = caml_create_root(raise_unhandled_closure);
caml_global_data = caml_create_root(Val_unit);
@@ -286,7 +286,6 @@ value caml_interprete(code_t prog, asize_t prog_size)
Assert(!Is_foreign(accu));
Assert(!Is_foreign(env));
-
caml_bcodcount++;
if (caml_icount-- == 0) caml_stop_here ();
if (caml_startup_params.trace_flag>1) printf("\n##%ld\n", caml_bcodcount);
@@ -501,7 +500,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
value parent_stack = Stack_parent(caml_current_stack);
value hval = Stack_handle_value(caml_current_stack);
Assert(parent_stack != Val_long(0));
-
+
caml_extern_sp = sp;
value old_stack = caml_switch_stack(parent_stack);
sp = caml_extern_sp;
@@ -687,8 +686,6 @@ value caml_interprete(code_t prog, asize_t prog_size)
Init_field(block, 0, accu);
for (i = 1; i < wosize; i++) Init_field(block, i, *sp++);
} else {
- /* XXX KC: Is setup/restore needed? See comment in caml_alloc_shr in
- * CLOSURE and CLOSUREREC. */
Setup_for_gc;
block = caml_alloc_shr(wosize, tag);
Restore_after_gc;
@@ -760,31 +757,15 @@ value caml_interprete(code_t prog, asize_t prog_size)
Instruct(GETFIELD):
accu = FieldImm(accu, *pc); pc++; Next;
Instruct(GETMUTABLEFIELD0):
- Setup_for_c_call;
- accu = Field(accu, 0);
- Restore_after_c_call;
- Next;
+ accu = Field(accu, 0); Next;
Instruct(GETMUTABLEFIELD1):
- Setup_for_c_call;
- accu = Field(accu, 1);
- Restore_after_c_call;
- Next;
+ accu = Field(accu, 1); Next;
Instruct(GETMUTABLEFIELD2):
- Setup_for_c_call;
- accu = Field(accu, 2);
- Restore_after_c_call;
- Next;
+ accu = Field(accu, 2); Next;
Instruct(GETMUTABLEFIELD3):
- Setup_for_c_call;
- accu = Field(accu, 3);
- Restore_after_c_call;
- Next;
+ accu = Field(accu, 3); Next;
Instruct(GETMUTABLEFIELD):
- Setup_for_c_call;
- accu = Field(accu, *pc);
- Restore_after_c_call;
- pc++;
- Next;
+ accu = Field(accu, *pc); pc++; Next;
Instruct(GETFLOATFIELD): {
double d = Double_field(accu, *pc);
Alloc_small(accu, Double_wosize, Double_tag);
@@ -1091,11 +1072,25 @@ value caml_interprete(code_t prog, asize_t prog_size)
Instruct(ASRINT):
accu = (value)((((intnat) accu - 1) >> Long_val(*sp++)) | 1); Next;
+ Instruct(EQ): {
+ if (Is_long (accu) || Is_long(*sp)) {
+ accu = Val_int((intnat) accu == (intnat) *sp++);
+ Next;
+ }
+ if (Is_promoted_hd(Hd_val(accu)) && Is_young(accu))
+ accu = caml_addrmap_lookup(&caml_remembered_set.promotion, accu);
+ value v2 = *(value*)sp;
+ if (Is_promoted_hd(Hd_val(v2)) && Is_young(v2))
+ v2 = caml_addrmap_lookup(&caml_remembered_set.promotion, v2);
+ accu = Val_int((intnat) accu == (intnat) v2);
+ sp++;
+ Next;
+ }
+
#define Integer_comparison(typ,opname,tst) \
Instruct(opname): \
accu = Val_int((typ) accu tst (typ) *sp++); Next;
- Integer_comparison(intnat,EQ, ==)
Integer_comparison(intnat,NEQ, !=)
Integer_comparison(intnat,LTINT, <)
Integer_comparison(intnat,LEINT, <=)
@@ -1250,7 +1245,7 @@ do_resume:
caml_extern_sp = sp;
caml_switch_stack(accu);
sp = caml_extern_sp;
-
+
caml_trap_sp_off = Long_val(sp[0]);
sp[0] = resume_arg;
accu = resume_fn;
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index c3da4c7..fcb8803 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -81,23 +81,16 @@ static void mark_stack_push(value v) {
if (caml_mark_stack_count >= MARK_STACK_SIZE)
caml_fatal_error("mark stack overflow");
caml_mark_stack[caml_mark_stack_count++] = v;
- // caml_gc_log ("mark_stack_push: 0x%lx count=%d", v, caml_mark_stack_count);
}
static int mark_stack_pop(value* ret) {
- if (caml_mark_stack_count == 0)
+ if (caml_mark_stack_count == 0)
return 0;
*ret = caml_mark_stack[--caml_mark_stack_count];
- // caml_gc_log ("mark_stack_pop: 0x%lx count=%d", *ret, caml_mark_stack_count);
return 1;
}
-#ifdef DEBUG
-#define Is_markable(v) (Is_block(v) && !Is_minor(v) && v != Debug_free_major)
-#else
-#define Is_markable(v) (Is_block(v) && !Is_minor(v) && v != 0)
-#endif
-
+#define Is_markable(v) (Is_block(v) && !Is_minor(v))
static value mark_normalise(value v) {
Assert(Is_markable(v));
@@ -123,16 +116,12 @@ static intnat mark(value initial, intnat budget) {
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 = FieldImm(v, i);
- // caml_gc_log ("mark: v=%p i=%u child=%p",(value*)v,i,(value*)child);
+ value child = Field(v, i);
if (Is_markable(child)) {
child = mark_normalise(child);
if (caml_mark_object(child)) {
@@ -147,7 +136,7 @@ static intnat mark(value initial, intnat budget) {
}
}
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);
@@ -160,7 +149,6 @@ static intnat mark(value initial, intnat budget) {
}
void caml_darken(value v, value* ignored) {
-
/* Assert (Is_markable(v)); */
if (!Is_markable (v)) return; /* foreign stack, at least */
@@ -209,47 +197,22 @@ intnat caml_major_collection_slice(intnat howmuch)
return computed_work;
}
-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;
-}
-
void caml_finish_marking () {
- //caml_gc_log ("caml_finish_marking(0)");
caml_save_stack_gc();
caml_do_local_roots(&caml_darken, caml_domain_self());
caml_scan_global_roots(&caml_darken);
caml_empty_mark_stack();
caml_allocated_words = 0;
caml_restore_stack_gc();
- //caml_gc_log ("caml_finish_marking(1)");
}
-void caml_empty_mark_stack_domain (struct domain* domain)
-{
- value* mark_stack = *domain->mark_stack;
- int* mark_stack_count = domain->mark_stack_count;
+void caml_empty_mark_stack () {
+ value v;
- while (*mark_stack_count) {
- *mark_stack_count = *mark_stack_count - 1;
- mark (mark_stack[*mark_stack_count], 10000000);
- }
-}
+ while (mark_stack_pop(&v)) mark(v, 10000000);
-void caml_finish_marking_domain (struct domain* domain) {
- //caml_gc_log("caml_finish_marking_domain(0): domain=%d", domain->id);
- caml_save_stack_gc();
- caml_do_local_roots(&caml_darken, domain);
- caml_empty_mark_stack_domain(domain);
- /* Previous step might have pushed values into our mark stack. Hence,
- * empty our mark stack */
- caml_empty_mark_stack();
- caml_allocated_words = 0;
- caml_restore_stack_gc();
- //caml_gc_log("caml_finish_marking_domain(1): domain=%d", domain->id);
+ if (stat_blocks_marked)
+ caml_gc_log("Finished marking major heap. Marked %u blocks", (unsigned)stat_blocks_marked);
+ stat_blocks_marked = 0;
}
+
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 14d0c59..76cb177 100644
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -3,8 +3,11 @@
extern __thread value* caml_mark_stack;
extern __thread int caml_mark_stack_count;
+
extern __thread uintnat caml_allocated_words;
+
+
intnat caml_major_collection_slice (intnat);
void caml_finish_marking (void);
void caml_init_major_gc(void);
@@ -12,4 +15,4 @@ void caml_darken(value, value* ignored);
void caml_mark_root(value, value*);
void caml_empty_mark_stack(void);
-#endif /* CAML_MAJOR_GC_H */
+#endif
diff --git a/byterun/memory.c b/byterun/memory.c
index c1f804c..801e8da 100644
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -10,27 +10,29 @@
#include "roots.h"
#include "alloc.h"
-static void write_barrier(value obj, int field, value val)
+static void shared_heap_write_barrier(value obj, int field, value val)
{
- Assert (Is_block(obj));
+ Assert (Is_block(obj) && !Is_young(obj));
if (Is_block(val)) {
- // caml_gc_log ("write_barrier: obj=%p field=%d val=%p",
- // (value*)obj, field, (value*)val);
- if (!Is_young(obj)) {
- if (Is_young(val)) {
- /* Add to remembered set */
- Ref_table_add(&caml_remembered_set.major_ref, Op_val(obj) + field);
- } else {
- caml_darken(val, 0);
- }
- } else if (Is_young(val) && val < obj) {
- /* Both obj and val are young and val is more recent than obj. */
- Ref_table_add(&caml_remembered_set.minor_ref, Op_val(obj) + field);
+ if (Is_young(val)) {
+ /* Add to remembered set */
+ Ref_table_add(&caml_remembered_set.ref, obj, field);
+ } else {
+ /*
+ FIXME: should have an is_marking check
+ don't want to do this all the time
+
+ unconditionally mark new value
+ */
+
+ caml_darken(val, 0);
}
}
}
+static void promoted_write(value obj, int field, value val);
+
CAMLexport void caml_modify_field (value obj, int field, value val)
{
Assert (Is_block(obj));
@@ -40,8 +42,12 @@ CAMLexport void caml_modify_field (value obj, int field, value val)
Assert(field >= 0 && field < Wosize_val(obj));
- write_barrier(obj, field, val);
- Op_val(obj)[field] = val;
+ if (Is_promoted_hd(Hd_val(obj))) {
+ promoted_write(obj, field, val);
+ } else {
+ if (!Is_young(obj)) shared_heap_write_barrier(obj, field, val);
+ Op_val(obj)[field] = val;
+ }
}
CAMLexport void caml_initialize_field (value obj, int field, value val)
@@ -51,25 +57,30 @@ CAMLexport void caml_initialize_field (value obj, int field, value val)
caml_modify_field(obj, field, val);
}
+static int promoted_cas(value obj, int field, value oldval, value newval);
+
CAMLexport int caml_atomic_cas_field (value obj, int field, value oldval, value newval)
{
- value* p = &Op_val(obj)[field];
- if (Is_young(obj)) {
- /* non-atomic CAS since only this thread can access the object */
- if (*p == oldval) {
- *p = newval;
- write_barrier(obj, field, newval);
- return 1;
- } else {
- return 0;
- }
+ if (Is_promoted_hd(Hd_val(obj))) {
+ return promoted_cas(obj, field, oldval, newval);
} else {
- /* need a real CAS */
- if (__sync_bool_compare_and_swap(p, oldval, newval)) {
- write_barrier(obj, field, newval);
- return 1;
+ value* p = &Op_val(obj)[field];
+ if (Is_young(obj)) {
+ /* non-atomic CAS since only this thread can access the object */
+ if (*p == oldval) {
+ *p = newval;
+ return 1;
+ } else {
+ return 0;
+ }
} else {
- return 0;
+ /* need a real CAS */
+ if (__sync_bool_compare_and_swap(p, oldval, newval)) {
+ shared_heap_write_barrier(obj, field, newval);
+ return 1;
+ } else {
+ return 0;
+ }
}
}
}
@@ -145,12 +156,11 @@ struct read_fault_req {
};
static void send_read_fault(struct read_fault_req*);
-
static void handle_read_fault(struct domain* target, void* reqp) {
struct read_fault_req* req = reqp;
value v = Op_val(req->obj)[req->field];
if (Is_minor(v) && caml_owner_of_young_block(v) == target) {
- // caml_gc_log("Handling read fault for domain [%02d]", target->id);
+ caml_gc_log("Handling read fault for domain [%02d]", target->id);
req->ret = caml_promote(target, v);
Assert (!Is_minor(req->ret));
/* Update the field so that future requests don't fault. We must
@@ -163,7 +173,7 @@ static void handle_read_fault(struct domain* target, void* reqp) {
into the read barrier. This always terminates: in the worst
case, all domains get tied up servicing one fault and then
there are no more left running to win the race */
- // caml_gc_log("Stale read fault for domain [%02d]", target->id);
+ caml_gc_log("Stale read fault for domain [%02d]", target->id);
send_read_fault(req);
}
}
@@ -172,12 +182,12 @@ static void send_read_fault(struct read_fault_req* req)
{
value v = Op_val(req->obj)[req->field];
if (Is_minor(v)) {
- // caml_gc_log("Read fault to domain [%02d]", caml_owner_of_young_block(v)->id);
+ caml_gc_log("Read fault to domain [%02d]", caml_owner_of_young_block(v)->id);
caml_domain_rpc(caml_owner_of_young_block(v), &handle_read_fault, req);
Assert(!Is_minor(req->ret));
- // caml_gc_log("Read fault returned (%p)", (void*)req->ret);
+ caml_gc_log("Read fault returned (%p)", (void*)req->ret);
} else {
- // caml_gc_log("Stale read fault: already promoted");
+ caml_gc_log("Stale read fault: already promoted");
req->ret = v;
}
}
@@ -187,6 +197,13 @@ CAMLexport value caml_read_barrier(value obj, int field)
value v = Op_val(obj)[field];
if (Is_foreign(v)) {
struct read_fault_req req = {obj, field, Val_unit};
+ if (Is_young(obj)) {
+ /* We can trigger a read fault on a young object only if this is
+ the young copy of a promoted object. We should fault on the
+ promoted version, instead of the young one */
+ Assert(Is_promoted_hd(Hd_val(obj)));
+ req.obj = caml_addrmap_lookup(&caml_remembered_set.promotion, obj);
+ }
send_read_fault(&req);
return req.ret;
} else {
@@ -200,6 +217,39 @@ struct write_fault_req {
value val;
};
+static void handle_write_fault(struct domain* target, void* reqp) {
+ struct write_fault_req* req = reqp;
+ if (Is_promoted_hd(Hd_val(req->obj)) &&
+ caml_owner_of_shared_block(req->obj) == target) {
+ caml_gc_log("Handling write fault for domain [%02d] on %p(%d)", target->id, (value*)req->obj, req->field);
+ value local =
+ caml_addrmap_lookup(&target->remembered_set->promotion_rev, req->obj);
+ Op_val(local)[req->field] = req->val;
+ Op_val(req->obj)[req->field] = req->val;
+ } else {
+ caml_gc_log("Stale write fault for domain [%02d]", target->id);
+ /* Race condition: this shared block is now owned by someone else */
+ caml_modify_field(req->obj, req->field, req->val);
+ }
+}
+
+static void promoted_write(value obj, int field, value val)
+{
+ if (Is_young(obj)) {
+ value promoted = caml_addrmap_lookup(&caml_remembered_set.promotion, obj);
+ Op_val(promoted)[field] = val;
+ Op_val(obj)[field] = val;
+ shared_heap_write_barrier(promoted, field, val);
+ } else {
+ struct domain* owner = caml_owner_of_shared_block(obj);
+ struct write_fault_req req = {obj, field, val};
+ caml_gc_log("Write fault to domain [%02d]", owner->id);
+ caml_domain_rpc(owner, &handle_write_fault, &req);
+ shared_heap_write_barrier(obj, field, val);
+ }
+}
+
+
struct cas_fault_req {
value obj;
int field;
@@ -208,6 +258,51 @@ struct cas_fault_req {
int success;
};
+static int do_promoted_cas(value local, value promoted, int field, value oldval, value newval) {
+ value* p = &Op_val(local)[field];
+ if (*p == oldval) {
+ *p = newval;
+ Op_val(promoted)[field] = newval;
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+static void handle_cas_fault(struct domain* target, void* reqp) {
+ struct cas_fault_req* req = reqp;
+ if (Is_promoted_hd(Hd_val(req->obj)) &&
+ caml_owner_of_shared_block(req->obj) == target) {
+ caml_gc_log("Handling CAS fault for domain [%02d]", target->id);
+ value local =
+ caml_addrmap_lookup(&target->remembered_set->promotion_rev,
+ req->obj);
+ req->success = do_promoted_cas(local, req->obj, req->field, req->oldval, req->newval);
+ } else {
+ caml_gc_log("Stale CAS fault for domain [%02d]", target->id);
+ req->success = caml_atomic_cas_field(req->obj, req->field, req->oldval, req->newval);
+ }
+}
+
+static int promoted_cas(value obj, int field, value oldval, value newval)
+{
+ if (Is_young(obj)) {
+ value promoted = caml_addrmap_lookup(&caml_remembered_set.promotion, obj);
+ int success = do_promoted_cas(obj, promoted, field, oldval, newval);
+ if (success)
+ shared_heap_write_barrier(promoted, field, newval);
+ return success;
+ } else {
+ struct domain* owner = caml_owner_of_shared_block(obj);
+ struct cas_fault_req req = {obj, field, oldval, newval, 0};
+ caml_gc_log("CAS fault to domain [%02d]", owner->id);
+ caml_domain_rpc(owner, &handle_cas_fault, &req);
+ if (req.success)
+ shared_heap_write_barrier(obj, field, newval);
+ return req.success;
+ }
+}
+
#define BVAR_EMPTY 0x10000
#define BVAR_OWNER_MASK 0x0ffff
@@ -235,8 +330,8 @@ static void handle_bvar_transfer(struct domain* self, void *reqp)
int owner = stat & BVAR_OWNER_MASK;
if (owner == self->id) {
- // caml_gc_log("Handling bvar transfer [%02d] -> [%02d]", owner, req->new_owner);
- caml_modify_field (bv, 0, caml_promote(self, Op_val(bv)[0]));
+ caml_gc_log("Handling bvar transfer [%02d] -> [%02d]", owner, req->new_owner);
+ Op_val(bv)[0] = caml_promote(self, Op_val(bv)[0]);
Op_val(bv)[1] = Val_long((stat & ~BVAR_OWNER_MASK) | req->new_owner);
} else {
/* Race: by the time we handled the RPC, this bvar was
@@ -244,8 +339,8 @@ static void handle_bvar_transfer(struct domain* self, void *reqp)
request before returning: this guarantees progress
since in the worst case all domains are tied up
and there's nobody left to win the race */
- // caml_gc_log("Stale bvar transfer [%02d] -> [%02d] ([%02d] got there first)",
- // self->id, req->new_owner, owner);
+ caml_gc_log("Stale bvar transfer [%02d] -> [%02d] ([%02d] got there first)",
+ self->id, req->new_owner, owner);
caml_domain_rpc(caml_domain_of_id(owner), &handle_bvar_transfer, req);
}
}
@@ -261,7 +356,7 @@ static intnat bvar_status(value bv)
/* Otherwise, need to transfer */
struct bvar_transfer_req req = {bv, caml_domain_self()->id};
- // caml_gc_log("Transferring bvar from domain [%02d]", owner);
+ caml_gc_log("Transferring bvar from domain [%02d]", owner);
caml_domain_rpc(caml_domain_of_id(owner), &handle_bvar_transfer, &req);
/* We may not have ownership at this point: we might have just
@@ -272,6 +367,11 @@ static intnat bvar_status(value bv)
CAMLprim value caml_bvar_take(value bv)
{
+ /* bvar operations need to operate on the promoted copy */
+ if (Is_young(bv) && Is_promoted_hd(Hd_val(bv))) {
+ bv = caml_addrmap_lookup(&caml_remembered_set.promotion, bv);
+ }
+
intnat stat = bvar_status(bv);
if (stat & BVAR_EMPTY) caml_raise_not_found();
CAMLassert(stat == caml_domain_self()->id);
@@ -285,11 +385,16 @@ CAMLprim value caml_bvar_take(value bv)
CAMLprim value caml_bvar_put(value bv, value v)
{
+ /* bvar operations need to operate on the promoted copy */
+ if (Is_young(bv) && Is_promoted_hd(Hd_val(bv))) {
+ bv = caml_addrmap_lookup(&caml_remembered_set.promotion, bv);
+ }
+
intnat stat = bvar_status(bv);
if (!(stat & BVAR_EMPTY)) caml_invalid_argument("Put to a full bvar");
CAMLassert(stat == (caml_domain_self()->id | BVAR_EMPTY));
- write_barrier(bv, 0, v);
+ if (!Is_young(bv)) shared_heap_write_barrier(bv, 0, v);
Op_val(bv)[0] = v;
Op_val(bv)[1] = Val_long(caml_domain_self()->id);
@@ -298,15 +403,10 @@ CAMLprim value caml_bvar_put(value bv, value v)
CAMLprim value caml_bvar_is_empty(value bv)
{
- return Val_int((Long_val(Op_val(bv)[1]) & BVAR_EMPTY) != 0);
-}
-
-#ifdef DEBUG
-int is_minor (value v) {
- return Is_minor(v);
-}
+ /* bvar operations need to operate on the promoted copy */
+ if (Is_young(bv) && Is_promoted_hd(Hd_val(bv))) {
+ bv = caml_addrmap_lookup(&caml_remembered_set.promotion, bv);
+ }
-header_t hd_val(value v) {
- return Hd_val(v);
+ return Val_int((Long_val(Op_val(bv)[1]) & BVAR_EMPTY) != 0);
}
-#endif
diff --git a/byterun/memory.h b/byterun/memory.h
index 4b0d13f..a0dd4ee 100644
--- a/byterun/memory.h
+++ b/byterun/memory.h
@@ -28,7 +28,6 @@
/* </private> */
#include "misc.h"
#include "mlvalues.h"
-#include "alloc.h"
#ifdef __cplusplus
extern "C" {
@@ -57,7 +56,16 @@ color_t caml_allocation_color (void *hp);
/* <private> */
-// caml_gc_log ("Alloc_small: v=%p sz=%lu", (value*)result, (value)wosize);
+
+/* FIXME */
+/* There are two GC bits in the object header, with the following
+ possible values:
+ 00: new object, not forwarded
+ 11: forwarded by a fault promotion */
+
+#define Is_promoted_hd(hd) (((hd) & (3 << 8)) == (3 << 8))
+#define Promotedhd_hd(hd) ((hd) | (3 << 8))
+
#ifdef DEBUG
#define DEBUG_clear(result, wosize) do{ \
@@ -295,7 +303,7 @@ CAMLextern __thread struct caml__roots_block *caml_local_roots; /* defined in r
#define CAMLreturn(result) CAMLreturnT(value, result)
#define CAMLnoreturn ((void) caml__frame)
-
+
/* modify a field */
#define Store_field(block, offset, val) caml_modify_field(block, offset, val)
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index cfbeec4..8953641 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -12,7 +12,6 @@
/***********************************************************************/
#include <string.h>
-
#include "config.h"
#include "fail.h"
#include "finalise.h"
@@ -42,11 +41,14 @@ static __thread unsigned long minor_gc_counter = 0;
void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
{
+ struct caml_ref_entry *new_table;
+
tbl->size = sz;
tbl->reserve = rsv;
+ new_table = (struct caml_ref_entry*) caml_stat_alloc ((tbl->size + tbl->reserve)
+ * sizeof (struct caml_ref_entry));
if (tbl->base != NULL) caml_stat_free (tbl->base);
- tbl->base = (value**) caml_stat_alloc ((tbl->size + tbl->reserve)
- * sizeof (value*));
+ tbl->base = new_table;
tbl->ptr = tbl->base;
tbl->threshold = tbl->base + tbl->size;
tbl->limit = tbl->threshold;
@@ -74,19 +76,151 @@ void caml_set_minor_heap_size (asize_t size)
caml_reallocate_minor_heap(size);
- reset_table (&caml_remembered_set.major_ref);
- reset_table (&caml_remembered_set.minor_ref);
+ reset_table (&caml_remembered_set.ref);
+}
+
+
+/* used to communicate with promote_stack_elem */
+__thread struct domain* promote_domain;
+static void promote_stack_elem(value v, value* p)
+{
+ *p = caml_promote(promote_domain, v);
+}
+
+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;
+}
+
+
+struct promotion_stack_entry {
+ value local;
+ value global;
+ int field;
+};
+struct promotion_stack {
+ int stack_len, sp;
+ struct promotion_stack_entry* stack;
+};
+
+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->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->remembered_set->promotion, curr, promoted);
+ caml_addrmap_insert(&domain->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;
+}
+
+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->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 __thread value oldify_todo_list = 0;
static __thread uintnat stat_live_bytes = 0;
-/* Promotion input and output variables. */
-static __thread struct domain* promote_domain = 0;
-static __thread value oldest_promoted = 0;
-
static value alloc_shared(mlsize_t wosize, tag_t tag)
{
void* mem = caml_shared_try_alloc(caml_domain_self()->shared_heap, wosize, tag, 0 /* not promotion */);
@@ -100,125 +234,108 @@ static value alloc_shared(mlsize_t wosize, tag_t tag)
/* 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 (value v, value *p, int promote_stack)
+static void caml_oldify_one (value v, value *p)
{
value result;
header_t hd;
mlsize_t sz, i;
tag_t tag;
- struct caml_domain_state* domain_state =
- promote_domain ? promote_domain->state : caml_domain_state;
- char* young_ptr = domain_state->young_ptr;
- char* young_end = domain_state->young_end;
- Assert (domain_state->young_start <= domain_state->young_ptr &&
- domain_state->young_ptr <= domain_state->young_end);
tail_call:
- if (Is_block (v) && young_ptr <= Hp_val(v) && Hp_val(v) < young_end) {
+ if (Is_block (v) && Is_young (v)){
+ Assert (Hp_val (v) >= caml_domain_state->young_ptr);
hd = Hd_val (v);
stat_live_bytes += Bhsize_hd(hd);
- if (hd == 0){ /* If already forwarded */
+ if (Is_promoted_hd (hd)) {
+ *p = caml_addrmap_lookup(&caml_remembered_set.promotion, v);
+ } else if (hd == 0){ /* If already forwarded */
*p = Op_val(v)[0]; /* then forward pointer is first field. */
- } else {
- if (((value)Hp_val(v)) > oldest_promoted) {
- oldest_promoted = (value)Hp_val(v);
- }
+ }else{
tag = Tag_hd (hd);
if (tag < Infix_tag){
value field0;
- if (tag == Stack_tag && !promote_stack) {
- /* Stacks are not promoted unless explicitly requested. */
- Ref_table_add(&promote_domain->remembered_set->major_ref, p);
+ sz = Wosize_hd (hd);
+ result = alloc_shared (sz, tag);
+ *p = result;
+ if (tag == Stack_tag) {
+ memcpy((void*)result, (void*)v, sizeof(value) * sz);
+ Hd_val (v) = 0;
+ Op_val(v)[0] = result;
+ Op_val(v)[1] = oldify_todo_list;
+ oldify_todo_list = v;
} else {
- sz = Wosize_hd (hd);
- result = alloc_shared (sz, tag);
- // caml_gc_log ("promoting object %p (referred from %p) tag=%d size=%lu to %p", (value*)v, p, tag, sz, (value*)result);
- *p = result;
- if (tag == Stack_tag) {
- memcpy((void*)result, (void*)v, sizeof(value) * sz);
- Hd_val (v) = 0;
- Op_val(v)[0] = result;
- Op_val(v)[1] = oldify_todo_list;
- oldify_todo_list = v;
- } else {
- field0 = Op_val(v)[0];
- Hd_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] = oldify_todo_list; /* Add this block */
- oldify_todo_list = v; /* to the "to do" list. */
- }else{
- Assert (sz == 1);
- p = Op_val(result);
- v = field0;
- goto tail_call;
- }
+ field0 = Op_val(v)[0];
+ Hd_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] = oldify_todo_list; /* Add this block */
+ oldify_todo_list = v; /* to the "to do" list. */
+ }else{
+ Assert (sz == 1);
+ p = Op_val(result);
+ v = field0;
+ goto tail_call;
}
}
- } else if (tag >= No_scan_tag) {
+ }else if (tag >= No_scan_tag){
sz = Wosize_hd (hd);
result = alloc_shared(sz, tag);
for (i = 0; i < sz; i++) Op_val (result)[i] = Op_val(v)[i];
Hd_val (v) = 0; /* Set forward flag */
Op_val (v)[0] = result; /* and forward pointer. */
- // caml_gc_log ("promoting object %p (referred from %p) tag=%d size=%lu to %p", (value*)v, p, tag, sz, (value*)result);
*p = result;
- } else if (tag == Infix_tag) {
+ }else if (tag == Infix_tag){
mlsize_t offset = Infix_offset_hd (hd);
- oldify_one (v - offset, p, promote_stack); /* Cannot recurse deeper than 1. */
+ caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */
*p += offset;
- } else {
- Assert (tag == Forward_tag);
-
+ } else{
value f = Forward_val (v);
tag_t ft = 0;
+ int vv = 1;
- if (Is_block (f)) {
- ft = Tag_val (Hd_val (f) == 0 ? Op_val (f)[0] : f);
+ Assert (tag == Forward_tag);
+ if (Is_block (f)){
+ if (Is_young (f)){
+ vv = 1;
+ ft = Tag_val (Hd_val (f) == 0 ? Op_val (f)[0] : f);
+ }else{
+ vv = 1;
+ if (vv){
+ ft = Tag_val (f);
+ }
+ }
}
-
- if (ft == Forward_tag || ft == Lazy_tag || ft == Double_tag) {
+ if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
/* Do not short-circuit the pointer. Copy as a normal block. */
Assert (Wosize_hd (hd) == 1);
result = alloc_shared (1, Forward_tag);
- // caml_gc_log ("promoting object %p (referred from %p) tag=%d size=%lu to %p",
- // (value*)v, p, tag, (value)1, (value*)result);
*p = result;
Hd_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 {
+ }else{
v = f; /* Follow the forwarding */
goto tail_call; /* then oldify. */
}
}
}
- } else {
- /* XXX KC: Does this operation race with other domain's oldifying operation */
+ }else{
*p = v;
}
}
-static void caml_oldify_one (value v, value* p) {
- oldify_one (v, p, 1);
-}
-
-/* Finish the work that was put off by [oldify_one].
- Note that [oldify_one] itself is called by oldify_mopup, so we
+/* Finish the work that was put off by [caml_oldify_one].
+ Note that [caml_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 (int promote_stack)
+static void caml_oldify_mopup (void)
{
value v, new_v, f;
mlsize_t i;
- struct caml_domain_state* domain_state =
- promote_domain ? promote_domain->state : caml_domain_state;
- char* young_ptr = domain_state->young_ptr;
- char* young_end = domain_state->young_end;
while (oldify_todo_list != 0){
v = oldify_todo_list; /* Get the head. */
@@ -226,284 +343,113 @@ static void oldify_mopup (int promote_stack)
new_v = Op_val (v)[0]; /* Follow forward pointer. */
if (Tag_val(new_v) == Stack_tag) {
oldify_todo_list = Op_val (v)[1]; /* Remove from list (stack) */
- //caml_gc_log ("oldify_mopup: caml_scan_stack start old=%p new=%p",
- // (value*)v, (value*)new_v);
caml_scan_stack(caml_oldify_one, new_v);
- //caml_gc_log ("oldify_mopup: caml_scan_stack end old=%p new=%p",
- // (value*)v, (value*)new_v);
} else {
oldify_todo_list = Op_val (new_v)[1]; /* Remove from list (non-stack) */
f = Op_val (new_v)[0];
- if (Is_block (f) && young_ptr <= Hp_val(v)
- && Hp_val(v) < young_end) {
- oldify_one (f, Op_val (new_v), promote_stack);
+ if (Is_block (f) && Is_young (f)){
+ caml_oldify_one (f, Op_val (new_v));
}
for (i = 1; i < Wosize_val (new_v); i++){
f = Op_val (v)[i];
- if (Is_block (f) && young_ptr <= Hp_val(v)
- && Hp_val(v) < young_end) {
- oldify_one (f, Op_val (new_v) + i, promote_stack);
- } else {
+ if (Is_block (f) && Is_young (f)){
+ caml_oldify_one (f, Op_val (new_v) + i);
+ }else{
Op_val (new_v)[i] = f;
}
}
}
-
- Assert (Wosize_val(new_v));
}
}
-static void caml_oldify_mopup (void) {
- oldify_mopup (1);
-}
-
-//*****************************************************************************
-
-void forward_pointer (value v, value *p) {
- header_t hd;
- mlsize_t offset;
- value fwd;
- struct caml_domain_state* domain_state =
- promote_domain ? promote_domain->state : caml_domain_state;
- char* young_ptr = domain_state->young_ptr;
- char* young_end = domain_state->young_end;
-
- if (Is_block (v) && young_ptr <= Hp_val(v) && Hp_val(v) < young_end) {
- hd = Hd_val(v);
- if (hd == 0) {
- // caml_gc_log ("forward_pointer: p=%p old=%p new=%p", p, (value*)v, (value*)Op_val(v)[0]);
- *p = Op_val(v)[0];
- Assert (Is_block(*p) && !Is_minor(*p));
- } else if (Tag_hd(hd) == Infix_tag) {
- offset = Infix_offset_hd(hd);
- fwd = 0;
- forward_pointer (v - offset, &fwd);
- if (fwd) *p = fwd + offset;
- }
- }
-}
-
-CAMLexport value caml_promote(struct domain* domain, value root)
+static void unpin_promoted_object(value local, value promoted)
{
- value **r;
- value iter, f;
- header_t hd;
- mlsize_t sz, i;
- tag_t tag;
- int saved_stack = 0;
- struct caml_domain_state *domain_state = domain->state;
- value young_ptr = (value)domain_state->young_ptr;
- value young_end = (value)domain_state->young_end;
-
- /* Integers are already shared */
- if (Is_long(root))
- return root;
-
- tag = Tag_val(root);
- /* Non-stack objects which are in the major heap are already shared. */
- if (tag != Stack_tag && !Is_minor(root))
- return root;
-
- if (!caml_stack_is_saved()) {
- saved_stack = 1;
- caml_save_stack_gc();
- }
-
- Assert(!oldify_todo_list);
- oldest_promoted = (value)domain_state->young_start;
- // caml_gc_log ("caml_promote: root=%p tag=%u young_start=%p young_ptr=0x%lx young_end=0x%lx owner=%d",
- // (value*)root, tag, domain_state->young_start, young_ptr, young_end, domain->id);
- promote_domain = domain;
-
- if (tag != Stack_tag) {
- Assert(caml_owner_of_young_block(root) == domain);
-
- /* For non-stack objects, don't promote referenced stacks. They are
- * promoted only when explicitly requested. */
- oldify_one (root, &root, 0);
- } else {
- /* The object is a stack */
- if (Is_minor(root)) {
- oldify_one (root, &root, 1);
- } else {
- /* Though the stack is in the major heap, it can contain objects in the
- * minor heap. They must be promoted. */
- caml_scan_dirty_stack_domain(caml_oldify_one, root, domain);
- }
- }
-
- oldify_mopup (0);
-
- // caml_gc_log ("caml_promote: new root=0x%lx oldest_promoted=0x%lx",
- // root, oldest_promoted);
-
- Assert (!Is_minor(root));
- /* XXX KC: We might checking for rpc's just before a stw_phase of a major
- * collection? Is this necessary? */
- caml_darken(root, 0);
-
- if (tag == Stack_tag) {
- /* Since we've promoted the objects on the stack, the stack is now clean. */
- caml_clean_stack_domain(root, domain);
- }
-
- /* Scan local roots */
- caml_do_local_roots (forward_pointer, domain);
-
- /* Scan current stack */
- caml_scan_stack (forward_pointer, *(domain->current_stack));
-
- /* Scan major to young pointers. */
- for (r = domain->remembered_set->major_ref.base; r < domain->remembered_set->major_ref.ptr; r++) {
- value old_p = **r;
- if (Is_block(old_p) && young_ptr <= old_p && old_p < young_end) {
- value new_p = old_p;
- forward_pointer (new_p, &new_p);
- if (old_p != new_p)
- __sync_bool_compare_and_swap (*r,old_p,new_p);
- //caml_gc_log ("forward: old_p=%p new_p=%p **r=%p",(value*)old_p, (value*)new_p,(value*)**r);
- }
- }
-
- /* Scan young to young pointers */
- for (r = domain->remembered_set->minor_ref.base; r < domain->remembered_set->minor_ref.ptr; r++) {
- forward_pointer (**r, *r);
- }
-
- /* Scan newer objects */
- iter = young_ptr;
- Assert(oldest_promoted < young_end);
- while (iter <= oldest_promoted) {
- hd = Hd_hp(iter);
- iter = Val_hp(iter);
- if (hd == 0) {
- /* Fowarded object. */
- mlsize_t wsz = Wosize_val(Op_val(iter)[0]);
- Assert (wsz <= Max_young_wosize);
- sz = Bsize_wsize(wsz);
- } else {
- tag = Tag_hd (hd);
- Assert (tag != Infix_tag);
- sz = Bosize_hd (hd);
- Assert (Wosize_hd(hd) <= Max_young_wosize);
- //caml_gc_log ("Scan: iter=%p sz=%lu tag=%u", (value*)iter, Wsize_bsize(sz), tag);
- if (tag < No_scan_tag && tag != Stack_tag) { /* Stacks will be scanned lazily, so skip. */
- for (i = 0; i < Wsize_bsize(sz); i++) {
- f = Op_val(iter)[i];
- if (Is_block(f)) {
- forward_pointer (f,((value*)iter) + i);
- }
- }
- }
- }
- iter += sz;
- }
-
- if (saved_stack)
- caml_restore_stack_gc();
-
- promote_domain = 0;
- return root;
+ Assert (caml_addrmap_lookup(&caml_remembered_set.promotion, local) == promoted);
+ Assert (caml_addrmap_lookup(&caml_remembered_set.promotion_rev, promoted) == local);
+ caml_shared_unpin(promoted);
+ caml_darken(promoted, 0);
}
-//*****************************************************************************
-
-/* Make sure the minor heap is empty by performing a minor collection
- if needed.
-*/
-
-void caml_empty_minor_heap_domain (struct domain* domain)
+/* Make sure the minor heap is empty by performing a minor collection if
+ * needed. */
+void caml_empty_minor_heap (void)
{
- struct caml_domain_state* domain_state = domain->state;
+ uintnat minor_allocated_bytes = caml_domain_state->young_end - caml_domain_state->young_ptr;
unsigned rewritten = 0;
- int saved_stack = 0;
- value young_ptr = (value)domain_state->young_ptr;
- value young_end = (value)domain_state->young_end;
- uintnat minor_allocated_bytes = young_end - young_ptr;
- value **r;
-
- if (!caml_stack_is_saved()) {
- saved_stack = 1;
- caml_save_stack_gc();
- }
+ struct caml_ref_entry *r;
- promote_domain = domain;
+ caml_save_stack_gc();
stat_live_bytes = 0;
- if (minor_allocated_bytes != 0) {
- caml_gc_log ("Minor collection of domain %d starting", domain->id);
- caml_do_local_roots(&caml_oldify_one, domain);
+ if (minor_allocated_bytes != 0){
+ caml_gc_log ("Minor collection starting");
+ caml_do_local_roots(&caml_oldify_one, caml_domain_self());
- for (r = domain->remembered_set->fiber_ref.base; r < domain->remembered_set->fiber_ref.ptr; r++) {
- caml_scan_dirty_stack_domain (&caml_oldify_one, (value)*r, domain);
+ for (r = caml_remembered_set.ref.base; r < caml_remembered_set.ref.ptr; r++){
+ value x;
+ caml_oldify_one (Op_val(r->obj)[r->field], &x);
}
- for (r = domain->remembered_set->major_ref.base; r < domain->remembered_set->major_ref.ptr; r++) {
- value x = **r;
- caml_oldify_one (x, &x);
+ for (r = caml_remembered_set.fiber_ref.base; r < caml_remembered_set.fiber_ref.ptr; r++) {
+ caml_scan_dirty_stack(&caml_oldify_one, r->obj);
}
caml_oldify_mopup ();
- for (r = domain->remembered_set->major_ref.base; r < domain->remembered_set->major_ref.ptr; r++){
- value v = **r;
- if (Is_block (v) &&
- (char*)young_ptr <= Hp_val(v) &&
- Hp_val(v) < (char*)young_end) {
- Assert (Hp_val (v) >= domain_state->young_ptr);
+ for (r = caml_remembered_set.ref.base; r < caml_remembered_set.ref.ptr; r++){
+ value v = Op_val(r->obj)[r->field];
+ if (Is_block(v) && Is_young(v)) {
+ Assert (Hp_val (v) >= caml_domain_state->young_ptr);
value vnew;
header_t hd = Hd_val(v);
- int offset = 0;
- if (Tag_hd(hd) == Infix_tag) {
- offset = Infix_offset_hd(hd);
- v -= offset;
+ // FIXME: call oldify_one here?
+ if (Is_promoted_hd(hd)) {
+ vnew = caml_addrmap_lookup(&caml_remembered_set.promotion, v);
+ } else {
+ int offset = 0;
+ if (Tag_hd(hd) == Infix_tag) {
+ offset = Infix_offset_hd(hd);
+ v -= offset;
+ }
+ Assert (Hd_val (v) == 0);
+ vnew = Op_val(v)[0] + offset;
}
- Assert (Hd_val(v) == 0);
- vnew = Op_val(v)[0] + offset;
- Assert (Is_block(vnew) && !Is_minor(vnew));
- Assert (Hd_val(vnew));
+ Assert(Is_block(vnew) && !Is_young(vnew));
+ Assert(Hd_val(vnew));
if (Tag_hd(hd) == Infix_tag) { Assert(Tag_val(vnew) == Infix_tag); }
- if (__sync_bool_compare_and_swap (*r,v,vnew)) ++rewritten;
- caml_darken(vnew,0);
+ rewritten += caml_atomic_cas_field(r->obj, r->field, v, vnew);
}
- //XXX KC: Could I move the darkening into the conditional above as
- //caml_darken(vnew,0)?
- //caml_darken (**r,*r);
}
- clear_table (&(domain->remembered_set->major_ref));
- clear_table (&(domain->remembered_set->minor_ref));
+ caml_addrmap_iter(&caml_remembered_set.promotion, unpin_promoted_object);
- domain_state->young_ptr = domain_state->young_end;
+ if (caml_domain_state->young_ptr < caml_domain_state->young_start)
+ caml_domain_state->young_ptr = caml_domain_state->young_start;
caml_stat_minor_words += Wsize_bsize (minor_allocated_bytes);
-
- caml_gc_log ("Minor collection of domain %d completed: %u of %u kb live, %u pointers rewritten",
- domain->id, (unsigned)stat_live_bytes/1024, (unsigned)minor_allocated_bytes/1024, rewritten);
- }
- else {
- caml_gc_log ("Minor collection of domain %d: skipping", domain->id);
- }
-
- for (r = domain->remembered_set->fiber_ref.base; r < domain->remembered_set->fiber_ref.ptr; r++) {
- caml_scan_dirty_stack_domain (&caml_darken, (value)*r, domain);
- caml_clean_stack_domain ((value)*r, domain);
+ caml_domain_state->young_ptr = caml_domain_state->young_end;
+ clear_table (&caml_remembered_set.ref);
+ caml_addrmap_clear(&caml_remembered_set.promotion);
+ caml_addrmap_clear(&caml_remembered_set.promotion_rev);
+ caml_gc_log ("Minor collection completed: %u of %u kb live, %u pointers rewritten",
+ (unsigned)stat_live_bytes/1024, (unsigned)minor_allocated_bytes/1024, rewritten);
}
- clear_table (&(domain->remembered_set->fiber_ref));
- if (saved_stack) {
- caml_restore_stack_gc();
+ for (r = caml_remembered_set.fiber_ref.base; r < caml_remembered_set.fiber_ref.ptr; r++) {
+ caml_scan_dirty_stack(&caml_darken, r->obj);
+ caml_clean_stack(r->obj);
}
+ clear_table (&caml_remembered_set.fiber_ref);
- promote_domain = 0;
+ caml_restore_stack_gc();
#ifdef DEBUG
{
value *p;
- for (p = (value *) domain_state->young_start;
- p < (value *) domain_state->young_end; ++p){
+ for (p = (value *) caml_domain_state->young_start;
+ p < (value *) caml_domain_state->young_end; ++p){
*p = Debug_free_minor;
}
++ minor_gc_counter;
@@ -511,11 +457,6 @@ void caml_empty_minor_heap_domain (struct domain* domain)
#endif
}
-void caml_empty_minor_heap ()
-{
- caml_empty_minor_heap_domain (caml_domain_self());
-}
-
/* Do a minor collection and a slice of major collection, call finalisation
functions, etc.
Leave the minor heap empty.
@@ -561,11 +502,11 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl)
asize_t cur_ptr = tbl->ptr - tbl->base;
tbl->size *= 2;
- sz = (tbl->size + tbl->reserve) * sizeof (value*);
+ sz = (tbl->size + tbl->reserve) * sizeof (struct caml_ref_entry);
caml_gc_log ("Growing ref_table to %"
ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
(intnat) sz/1024);
- tbl->base = (value**) caml_stat_resize ((char *) tbl->base, sz);
+ tbl->base = (struct caml_ref_entry*) caml_stat_resize ((char *) tbl->base, sz);
if (tbl->base == NULL){
caml_fatal_error ("Fatal error: ref_table overflow\n");
}
diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h
index d414825..0117d25 100644
--- a/byterun/minor_gc.h
+++ b/byterun/minor_gc.h
@@ -20,31 +20,35 @@
extern __thread asize_t caml_minor_heap_size;
+struct caml_ref_entry {
+ value obj;
+ intnat field;
+};
+
struct caml_ref_table {
- value **base;
- value **end;
- value **threshold;
- value **ptr;
- value **limit;
+ struct caml_ref_entry *base;
+ struct caml_ref_entry *end;
+ struct caml_ref_entry *threshold;
+ struct caml_ref_entry *ptr;
+ struct caml_ref_entry *limit;
asize_t size;
asize_t reserve;
};
struct caml_remembered_set {
- struct caml_ref_table major_ref, minor_ref, fiber_ref;
+ struct caml_ref_table ref, fiber_ref;
+ struct addrmap promotion, promotion_rev;
};
CAMLextern __thread struct caml_remembered_set caml_remembered_set;
extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
extern void caml_empty_minor_heap (void);
CAMLextern void caml_minor_collection (void);
-CAMLextern void forward_pointer (value v, value* p);
CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */
extern void caml_realloc_ref_table (struct caml_ref_table *);
extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t);
struct domain;
CAMLextern value caml_promote(struct domain*, value root);
-int caml_stack_is_saved (void);
#define Oldify(p) do{ \
value __oldify__v__ = *p; \
@@ -53,13 +57,16 @@ int caml_stack_is_saved (void);
} \
}while(0)
-#define Ref_table_add(ref_table, x) do { \
+#define Ref_table_add(ref_table, x, f) do { \
struct caml_ref_table* ref = (ref_table); \
if (ref->ptr >= ref->limit) { \
CAMLassert (ref->ptr == ref->limit); \
caml_realloc_ref_table (ref); \
} \
- *ref->ptr++ = (x); \
+ ref->ptr->obj = (x); \
+ ref->ptr->field = (f); \
+ ref->ptr++; \
} while (0)
+
#endif /* CAML_MINOR_GC_H */
diff --git a/byterun/misc.c b/byterun/misc.c
index 4c86dcf..1bd171a 100644
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -14,9 +14,6 @@
#include <stdio.h>
#include <string.h>
#include <stdarg.h>
-#include <execinfo.h>
-#include <stdlib.h>
-
#include "config.h"
#include "misc.h"
#include "memory.h"
@@ -25,30 +22,10 @@
#if defined(DEBUG) || defined(NATIVE_CODE)
-void print_trace (void)
-{
- void *array[10];
- size_t size;
- char **strings;
- size_t i;
-
- size = backtrace (array, 10);
- strings = backtrace_symbols (array, size);
-
- caml_gc_log ("Obtained %zd stack frames.", size);
-
- for (i = 0; i < size; i++)
- caml_gc_log ("%s", strings[i]);
-
- free (strings);
-}
-
int caml_failed_assert (char * expr, char * file, int line)
{
- struct domain* self = caml_domain_self ();
- fprintf (stderr, "[%02d] file %s; line %d ### Assertion failed: %s\n",
- self ? self->id : -1, file, line, expr);
- print_trace ();
+ fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n",
+ file, line, expr);
fflush (stderr);
abort();
return 1; /* not reached */
@@ -68,7 +45,6 @@ void caml_gc_log (char *msg, ...)
sprintf(fmtbuf, "[%02d] %s\n", self ? self->id : -1, msg);
vfprintf(stderr, fmtbuf, args);
}
- fflush(stderr);
va_end (args);
}
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index c52f414..17ab5c0 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -204,26 +204,12 @@ CAMLextern __thread struct caml_domain_state* caml_domain_state;
CAMLextern value caml_read_barrier(value, int);
static inline value Field(value x, int i) {
- Assert (Hd_val(x));
value v = (((value*)x))[i];
- Assert (v != Debug_free_major);
//if (Is_young(v)) Assert(young_ptr < (char*)v);
return Is_foreign(v) ? caml_read_barrier(x, i) : v;
-}
-
-/*
-static inline value FieldImm(value x, int i) {
- Assert (!Is_foreign(x));
- Assert (Hd_val(x));
- value v = (((value*)x))[i];
- Assert (v != Debug_free_major);
- Assert (v != Debug_free_minor);
- //if (Is_young(v)) Assert(young_ptr < (char*)v);
- return v;
-} */
-
-#define FieldImm(x, i) (((value *)(x)) [i])
-//#define Field(x, i) (((value *)(x)) [i] + 0)
+ }
+ #define FieldImm(x, i) (((value *)(x)) [i] + 0)
+ //#define Field(x, i) (((value *)(x)) [i] + 0)
/* initialise a field of an object just allocated on the minor heap */
#define Init_field(block, offset, val) (Op_val(block)[offset] = val)
diff --git a/byterun/obj.c b/byterun/obj.c
index fbff019..588bb35 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -110,7 +110,7 @@ CAMLprim value caml_obj_compare_and_swap (value v, value f, value oldv, value ne
/* caml_promote_to(obj, upto) promotes obj to be as least as shared as upto */
CAMLprim value caml_obj_promote_to (value obj, value upto)
{
- if (Is_block(upto) && Is_minor(upto)) {
+ if (Is_block(upto) && Is_minor(upto) && !Is_promoted_hd(Hd_val(upto))) {
/* upto is local, obj is already as shared as upto is */
return obj;
} else {
diff --git a/byterun/roots.c b/byterun/roots.c
index 51a3622..732ba49 100644
--- a/byterun/roots.c
+++ b/byterun/roots.c
@@ -64,3 +64,60 @@ CAMLexport void caml_do_local_roots (scanning_action f, struct domain* domain)
}
}
}
+
+void caml_do_sampled_roots(scanning_action f, struct domain* domain)
+{
+ /* look for roots on the minor heap */
+ value* p = (value*)(domain->state->young_ptr);
+ value* end = (value*)(domain->state->young_end);
+ while (p < end) {
+ value v = Val_hp(p);
+ Assert (Is_block(v) && Wosize_val(v) <= Max_young_wosize);
+ if (Tag_val(v) == Stack_tag) {
+ caml_scan_stack(f, v);
+ } else if (Tag_val(v) < No_scan_tag) {
+ int i;
+ value* fields = Op_val(v);
+ for (i = 0; i < Wosize_val(v); i++) {
+ if (Is_block(fields[i]) && !Is_minor(fields[i])) f(fields[i], &fields[i]);
+ }
+ }
+ p += Whsize_wosize(Wosize_val(v));
+ }
+ Assert(p == end);
+
+ /* look for gray values in the mark stack */
+ value* mark_stack = *domain->mark_stack;
+ value* mark_stack_end = *domain->mark_stack + *domain->mark_stack_count;
+ for (p = mark_stack; p < mark_stack_end; p++) {
+ value v = *p;
+ Assert (Is_block(v));
+ f(v, p);
+ if (Tag_val(v) == Stack_tag) {
+ caml_scan_stack(f, v);
+ } else if (Tag_val(v) < No_scan_tag) {
+ int i;
+ value* fields = Op_val(v);
+ Assert(Tag_val(v) != Infix_tag); /* Infix_tag can't appear on mark stack */
+ for (i = 0; i < Wosize_val(v); i++) {
+ if (Is_block(fields[i]) && !Is_minor(fields[i])) f(fields[i], &fields[i]);
+ }
+ }
+ }
+ /* these values need no longer be grayed by the target domain */
+ *domain->mark_stack_count = 0;
+
+ /* treat the remembered sets as roots */
+ struct caml_ref_entry* r;
+ for (r = domain->remembered_set->ref.base; r < domain->remembered_set->ref.ptr; r++) {
+ f(r->obj, 0);
+ }
+ for (r = domain->remembered_set->fiber_ref.base; r < domain->remembered_set->fiber_ref.ptr; r++) {
+ f(r->obj, 0);
+ caml_scan_stack(f, r->obj);
+ }
+
+
+ /* look for local C and stack roots */
+ caml_do_local_roots(f, domain);
+}
diff --git a/byterun/shared_heap.c b/byterun/shared_heap.c
index 8c28c76..749de62 100644
--- a/byterun/shared_heap.c
+++ b/byterun/shared_heap.c
@@ -33,10 +33,6 @@ static header_t With_status_hd(header_t hd, status s) {
return (hd & ~(3 << 8)) | s;
}
-int is_garbage (value parent) {
- header_t hd = Hd_val(parent);
- return Has_status_hd(hd, global.GARBAGE);
-}
typedef struct pool {
struct pool* next;
@@ -89,6 +85,8 @@ struct caml_heap_state* caml_init_shared_heap() {
caml_plat_mutex_init(&pool_freelist.lock);
}
+ Assert(NOT_MARKABLE == Promotedhd_hd(0));
+
heap = caml_stat_alloc(sizeof(struct caml_heap_state));
heap->free_pools = 0;
heap->num_free_pools = 0;
@@ -121,7 +119,7 @@ static pool* pool_acquire(struct caml_heap_state* local) {
} else {
caml_plat_lock(&pool_freelist.lock);
if (!pool_freelist.free) {
- void* mem = caml_mem_map(Bsize_wsize(POOL_WSIZE) * POOLS_PER_ALLOCATION,
+ void* mem = caml_mem_map(Bsize_wsize(POOL_WSIZE) * POOLS_PER_ALLOCATION,
Bsize_wsize(POOL_WSIZE), 0 /* allocate */);
int i;
if (mem) {
@@ -159,6 +157,7 @@ static void pool_release(struct caml_heap_state* local, pool* pool) {
}
}
+
/* Allocating an object from a pool */
static intnat pool_sweep(struct caml_heap_state* local, pool**, sizeclass sz);
@@ -170,7 +169,7 @@ static pool* pool_find(struct caml_heap_state* local, sizeclass sz) {
if (r) return r;
/* Otherwise, try to sweep until we find one */
- while (!local->avail_pools[sz] &&
+ while (!local->avail_pools[sz] &&
pool_sweep(local, &local->unswept_avail_pools[sz], sz));
while (!local->avail_pools[sz] &&
pool_sweep(local, &local->unswept_full_pools[sz], sz));
@@ -284,7 +283,7 @@ static intnat pool_sweep(struct caml_heap_state* local, pool** plist, sizeclass
value* end = (value*)a + POOL_WSIZE;
mlsize_t wh = wsize_sizeclass[sz];
int all_free = 1, all_used = 1;
-
+
while (p + wh <= end) {
header_t hd = (header_t)*p;
if (hd == 0) {
@@ -363,6 +362,8 @@ uintnat caml_heap_size(struct caml_heap_state* local) {
local->large_bytes_allocated;
}
+
+
int caml_mark_object(value p) {
Assert (Is_block(p));
header_t h = Hd_val(p);
@@ -373,7 +374,6 @@ int caml_mark_object(value p) {
Assert (h && !Has_status_hd(h, global.GARBAGE));
if (Has_status_hd(h, global.UNMARKED)) {
Hd_val(p) = With_status_hd(h, global.MARKED);
- // caml_gc_log ("caml_mark_object: %p hd=%p", (value*)p, (value*)Hd_val(p));
return 1;
} else {
return 0;
@@ -428,21 +428,17 @@ static __thread intnat verify_objs = 0;
static __thread struct addrmap verify_seen = ADDRMAP_INIT;
static void verify_push(value v, value* p) {
- if (!Is_block(v)) return;
-
- // caml_gc_log ("verify_push: 0x%lx", v);
if (verify_sp == verify_stack_len) {
verify_stack_len = verify_stack_len * 2 + 100;
verify_stack = caml_stat_resize(verify_stack,
sizeof(value*) * verify_stack_len);
- }
+ }
verify_stack[verify_sp++] = v;
}
static void verify_object(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);
@@ -455,7 +451,6 @@ static void verify_object(value v) {
if (Has_status_hd(Hd_val(v), NOT_MARKABLE)) return;
verify_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.MARKED));
}
@@ -477,13 +472,11 @@ static void verify_object(value v) {
static void verify_heap() {
caml_save_stack_gc();
- // caml_gc_log("verify_heap: caml_do_local_roots");
+
caml_do_local_roots(&verify_push, caml_domain_self());
- // caml_gc_log("verify_heap: caml_scan_global_roots");
caml_scan_global_roots(&verify_push);
- // caml_gc_log("verify_heap: verify_stack");
while (verify_sp) verify_object(verify_stack[--verify_sp]);
- // caml_gc_log("Verify: %lu objs", verify_objs);
+ caml_gc_log("Verify: %lu objs", verify_objs);
caml_addrmap_clear(&verify_seen);
verify_objs = 0;
@@ -505,11 +498,11 @@ static void verify_pool(pool* a, sizeclass sz, struct mem_stats* s) {
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];
-
+
while (p + wh <= end) {
header_t hd = (header_t)*p;
Assert(hd == 0 || !Has_status_hd(hd, global.GARBAGE));
@@ -562,9 +555,7 @@ static void verify_swept (struct caml_heap_state* local) {
void caml_cycle_heap_stw() {
struct global_heap_state oldg = global;
struct global_heap_state newg;
-#ifdef DEBUG
- verify_heap();
-#endif
+ //verify_heap();
newg.UNMARKED = oldg.MARKED;
newg.GARBAGE = oldg.UNMARKED;
newg.MARKED = oldg.GARBAGE; /* should be empty because garbage was swept */
diff --git a/byterun/shared_heap.h b/byterun/shared_heap.h
index b76a698..c77c027 100644
--- a/byterun/shared_heap.h
+++ b/byterun/shared_heap.h
@@ -22,10 +22,8 @@ intnat caml_sweep(struct caml_heap_state*, intnat);
/* must be called during STW */
void caml_cycle_heap_stw(void);
-/* must be called on each domain
+/* must be called on each domain
(after caml_cycle_heap_stw) */
void caml_cycle_heap(struct caml_heap_state*);
-int is_garbage (value);
-
#endif /* CAML_SHARED_HEAP_H */
diff --git a/nodup-notes.md b/nodup-notes.md
deleted file mode 100644
index 764d26a..0000000
--- a/nodup-notes.md
+++ /dev/null
@@ -1,35 +0,0 @@
-What to scan eagerly
---------------------
-1. Current stack
-2. Registers (native code)
-3. Major2Minor remembered set. Do not include remembered stacks.
-4. All the younger young objects. Optimization: Is there a way to safely scan
- only part of this young minor heap?
-5. Minor2Minor remembered set. Only when the field to be scanned older than
- promoted field. The fields that are younger will be covered by 4 without the
- proposed optimization.
-6. Local roots.
-
-What to scan lazily
--------------------
-On context switch, scan the target (when target != current) stack if the stack
-is on the minor heap. If the stack is on the major heap, scan only when the
-stack is dirty.
-
-When to populate Minor2Minor remembered set
--------------------------------------------
-During an assignment Op_val(o)[f] = v, if o and v are in young gen, and v was
-more recently allocated than o.
-
-\forall o,f,v. is_young(o) && is_young(v) && o > v => minor2minor(o,f)
-
-Memory barriers
----------------
-* Read barrier now only generates read faults.
-* Write barrier only for remembered sets.
-
-Questions
----------
-
-* What is the significance of `Assert(NOT_MARKABLE == Promotedhd_hd(0));`
-* Do I need to scan all of the new parts of the heap?
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment