/* 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. */
void caml_oldify_mopup (void)
{
value v, new_v, f;
mlsize_t i;
while (oldify_todo_list != 0){
v = oldify_todo_list; /* Get the head. */
Assert (Hd_val (v) == 0); /* It must be forwarded. */
new_v = Field (v, 0); /* Follow forward pointer. */
oldify_todo_list = Field (new_v, 1); /* Remove from list. */
f = Field (new_v, 0);
if (Is_block (f) && Is_young (f)){
caml_oldify_one (f, &Field (new_v, 0));
}
for (i = 1; i < Wosize_val (new_v); i++){
f = Field (v, i);
if (Is_block (f) && Is_young (f)){
caml_oldify_one (f, &Field (new_v, i));
}else{
Field (new_v, i) = f;
}
}
}
}
/* 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 caml_oldify_mopup (void)
{
value v, new_v, f;
mlsize_t i;
while (oldify_todo_list != 0){
v = oldify_todo_list; /* Get the head. */
Assert (Hd_val (v) == 0); /* It must be forwarded. */
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_scan_stack(caml_oldify_one, 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) && 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) && Is_young (f)){
caml_oldify_one (f, Op_val (new_v) + i);
}else{
Op_val (new_v)[i] = f;
}
}
}
}
}
static long compare_val(value v1, value v2)
{
tag_t t1, t2;
tailcall:
if (v1 == v2) return 0;
if (Is_long(v1) || Is_long(v2)) return Long_val(v1) - Long_val(v2);
/* If one of the objects is outside the heap (but is not an atom),
use address comparison. */
if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap((addr)v1)) ||
(!Is_atom(v2) && !Is_young(v2) && !Is_in_heap((addr)v2)))
return v1 - v2;
t1 = Tag_val(v1);
t2 = Tag_val(v2);
if (t1 != t2) return (long)t1 - (long)t2;
switch(t1) {
case String_tag: {
mlsize_t len1, len2, len;
unsigned char * p1, * p2;
len1 = string_length(v1);
len2 = string_length(v2);
for (len = (len1 <= len2 ? len1 : len2),
p1 = (unsigned char *) String_val(v1),
p2 = (unsigned char *) String_val(v2);
len > 0;
len--, p1++, p2++)
if (*p1 != *p2) return (long)*p1 - (long)*p2;
return len1 - len2;
}
case Double_tag: {
double d1 = Double_val(v1);
double d2 = Double_val(v2);
if (d1 == d2) return 0; else if (d1 < d2) return -1; else return 1;
}
case Abstract_tag:
case Final_tag:
invalid_argument("equal: abstract value");
case Closure_tag:
invalid_argument("equal: functional value");
default: {
mlsize_t sz1 = Wosize_val(v1);
mlsize_t sz2 = Wosize_val(v2);
value * p1, * p2;
long res;
if (sz1 != sz2) return sz1 - sz2;
for(p1 = Op_val(v1), p2 = Op_val(v2);
sz1 > 1;
sz1--, p1++, p2++) {
res = compare_val(*p1, *p2);
if (res != 0) return res;
}
v1 = *p1;
v2 = *p2;
goto tailcall;
}
}
}
void caml_modify (value *fp, value val)
{
value _old_ = *(fp);
*(fp) = (val);
if (Is_in_heap (fp)){
if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL);
if (Is_block (val) && Is_young (val)
&& ! (Is_block (_old_) && Is_young (_old_))){
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = (fp);
}
}
}
static void do_set (value ar, mlsize_t offset, value v)
{
if (Is_block (v) && Is_young (v)){
/* modified version of Modify */
value old = Field (ar, offset);
Field (ar, offset) = v;
if (!(Is_block (old) && Is_young (old))){
if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){
CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit);
caml_realloc_ref_table (&caml_weak_ref_table);
}
*caml_weak_ref_table.ptr++ = &Field (ar, offset);
}
}else{
Field (ar, offset) = v;
}
}
static void dirty_stack(value stack)
{
if(Is_young(stack) || Stack_dirty(stack) == Val_long(1))
return;
Stack_dirty(stack) = Val_long(1);
caml_remember_stack (stack);
}
static int sml_equal_aux(value v1, value v2)
{
mlsize_t i;
value * p1, * p2;
again:
if (v1 == v2) return 1;
if (IS_LONG(v1) || IS_LONG(v2)) return 0;
if (!Is_in_heap(v1) && !Is_young(v1)) return 0;
if (!Is_in_heap(v2) && !Is_young(v2)) return 0;
if (Tag_val(v1) != Tag_val(v2)) return 0;
switch(Tag_val(v1)) {
case String_tag:
{
// Fast string comparison
size_t len = string_length(v1);
if (len != string_length(v2)) {
return 0;
}
return (strncmp((char *) String_val(v1),
(char *) String_val(v2),
len) == 0) ? 1 : 0;
}
case Double_tag:
return (Double_val(v1) == Double_val(v2));
case Reference_tag: /* Different reference cells are not equal! */
case Abstract_tag:
case Final_tag:
return 0;
case Closure_tag:
invalid_argument("sml_equal: functional value");
default:
i = Wosize_val(v1);
if (i != Wosize_val(v2)) return 0;
for(p1 = Op_val(v1), p2 = Op_val(v2);
i > 1;
i--, p1++, p2++)
if (!sml_equal_aux(*p1, *p2)) return 0;
v1 = *p1;
v2 = *p2; /* Tail-call */
goto again;
}
}
CAMLexport void caml_remove_generational_global_root_r(CAML_R, value *r)
{
value v = *r;
if (Is_block(v)) {
if (Is_young(v))
caml_delete_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(v))
caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
}
}
void modify (value *fp, value val)
{
value old = *(fp);
*(fp) = val;
if (Is_in_heap (fp)) {
if (gc_phase == Phase_mark) {
darken(old);
}
if (IS_BLOCK(val) && Is_young (val)
&& ! (IS_BLOCK(old) && Is_young (old))) {
*ref_table_ptr++ = (fp);
if (ref_table_ptr >= ref_table_limit) {
assert (ref_table_ptr == ref_table_limit);
realloc_ref_table();
}
}
}
}
/* [caml_initialize] never calls the GC, so you may call it while an block is
unfinished (i.e. just after a call to [caml_alloc_shr].) */
void caml_initialize (value *fp, value val)
{
*fp = val;
if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
}
}
CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
{
/* The write barrier implemented by [caml_modify] checks for the
following two conditions and takes appropriate action:
1- a pointer from the major heap to the minor heap is created
--> add [fp] to the remembered set
2- a pointer from the major heap to the major heap is overwritten,
while the GC is in the marking phase
--> call [caml_darken] on the overwritten pointer so that the
major GC treats it as an additional root.
*/
value old;
if (Is_young((value)fp)) {
/* The modified object resides in the minor heap.
Conditions 1 and 2 cannot occur. */
*fp = val;
} else {
/* The modified object resides in the major heap. */
CAMLassert(Is_in_heap(fp));
old = *fp;
*fp = val;
if (Is_block(old)) {
/* If [old] is a pointer within the minor heap, we already
have a major->minor pointer and [fp] is already in the
remembered set. Conditions 1 and 2 cannot occur. */
if (Is_young(old)) return;
/* Here, [old] can be a pointer within the major heap.
Check for condition 2. */
if (caml_gc_phase == Phase_mark) caml_darken(old, NULL);
}
/* Check for condition 1. */
if (Is_block(val) && Is_young(val)) {
/* Add [fp] to remembered set */
if (caml_ref_table.ptr >= caml_ref_table.limit){
CAMLassert (caml_ref_table.ptr == caml_ref_table.limit);
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
}
}
}
/* [initialize] never calls the GC, so you may call it while an object is
unfinished (i.e. just after a call to [alloc_shr].) */
void initialize (value * fp, value val)
{
*fp = val;
Assert (Is_in_heap (fp));
if (Is_block (val) && Is_young (val)){
*ref_table_ptr++ = fp;
if (ref_table_ptr >= ref_table_limit){
realloc_ref_table ();
}
}
}
CAMLexport void caml_register_generational_global_root_r(CAML_R, value *r)
{
value v = *r;
Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */
if (Is_block(v)) {
if (Is_young(v))
caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(v))
caml_insert_global_root_r(ctx, &caml_global_roots_old, r);
}
}
/* PR#6084 workaround: define it as a weak symbol */
CAMLexport CAMLweakdef void caml_initialize (value *fp, value val)
{
CAMLassert(Is_in_heap(fp));
*fp = val;
if (Is_block (val) && Is_young (val)) {
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
}
}
CAMLexport void caml_modify_generational_global_root_r(CAML_R, value *r, value newval)
{
value oldval = *r;
/* It is OK to have a root in roots_young that suddenly points to
the old generation -- the next minor GC will take care of that.
What needs corrective action is a root in roots_old that suddenly
points to the young generation. */
if (Is_block(newval) && Is_young(newval) &&
Is_block(oldval) && Is_in_heap(oldval)) {
caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
}
/* PR#4704 */
else if (!Is_block(oldval) && Is_block(newval)) {
/* The previous value in the root was unboxed but now it is boxed.
The root won't appear in any of the root lists thus far (by virtue
of the operation of [caml_register_generational_global_root]), so we
need to make sure it gets in, or else it will never be scanned. */
if (Is_young(newval))
caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(newval))
caml_insert_global_root_r(ctx, &caml_global_roots_old, r);
}
else if (Is_block(oldval) && !Is_block(newval)) {
/* The previous value in the root was boxed but now it is unboxed, so
the root should be removed. If [oldval] is young, this will happen
anyway at the next minor collection, but it is safer to delete it
here. */
if (Is_young(oldval))
caml_delete_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(oldval))
caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
}
/* end PR#4704 */
*r = newval;
}
/* Make sure the minor heap is empty by performing a minor collection
if needed.
*/
void caml_empty_minor_heap (void)
{
value **r;
uintnat prev_alloc_words;
if (caml_young_ptr != caml_young_end) {
if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) ();
prev_alloc_words = caml_allocated_words;
caml_in_minor_collection = 1;
caml_gc_message (0x02, "<", 0);
caml_oldify_local_roots();
for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++) {
caml_oldify_one (**r, *r);
}
caml_oldify_mopup ();
for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++) {
if (Is_block (**r) && Is_young (**r)) {
if (Hd_val (**r) == 0) {
**r = Field (**r, 0);
} else {
**r = caml_weak_none;
}
}
}
if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start;
caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr);
caml_young_ptr = caml_young_end;
caml_young_limit = caml_young_start;
clear_table (&caml_ref_table);
clear_table (&caml_weak_ref_table);
caml_gc_message (0x02, ">", 0);
caml_in_minor_collection = 0;
caml_stat_promoted_words += caml_allocated_words - prev_alloc_words;
++ caml_stat_minor_collections;
caml_final_empty_young ();
if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) ();
} else {
caml_final_empty_young ();
}
#ifdef DEBUG
{
value *p;
for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p) {
*p = Debug_free_minor;
}
++ minor_gc_counter;
}
#endif
}
static void oldify (value *p, value v)
{
value result;
mlsize_t i;
tail_call:
if (IS_BLOCK(v) && Is_young (v)){
assert (Hp_val (v) < young_ptr);
if (Is_blue_val (v)){ /* Already forwarded ? */
*p = Field (v, 0); /* Then the forward pointer is the first field. */
}else if (Tag_val (v) >= No_scan_tag){
result = alloc_shr (Wosize_val (v), Tag_val (v));
bcopy (Bp_val (v), Bp_val (result), Bosize_val (v));
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
*p = result;
}else{
/* We can do recursive calls before all the fields are filled, because
we will not be calling the major GC. */
value field0 = Field (v, 0);
mlsize_t sz = Wosize_val (v);
result = alloc_shr (sz, Tag_val (v));
*p = result;
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
if (sz == 1){
p = &Field (result, 0);
v = field0;
goto tail_call;
}else{
oldify (&Field (result, 0), field0);
for (i = 1; i < sz - 1; i++){
oldify (&Field (result, i), Field (v, i));
}
p = &Field (result, i);
v = Field (v, i);
goto tail_call;
}
}
}else{
*p = v;
}
}
CAMLprim value caml_make_vect(value len, value init)
{
CAMLparam2 (len, init);
CAMLlocal1 (res);
mlsize_t size, wsize, i;
double d;
size = Long_val(len);
if (size == 0) {
res = Atom(0);
}
else if (Is_block(init)
&& Is_in_value_area(init)
&& Tag_val(init) == Double_tag) {
d = Double_val(init);
wsize = size * Double_wosize;
if (wsize > Max_wosize) caml_invalid_argument("Array.make");
res = caml_alloc(wsize, Double_array_tag);
for (i = 0; i < size; i++) {
Store_double_field(res, i, d);
}
} else {
if (size > Max_wosize) caml_invalid_argument("Array.make");
if (size < Max_young_wosize) {
res = caml_alloc_small(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
}
else if (Is_block(init) && Is_young(init)) {
caml_minor_collection();
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
res = caml_check_urgent_gc (res);
}
else {
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init);
res = caml_check_urgent_gc (res);
}
}
CAMLreturn (res);
}
static void hash_aux(value obj)
{
unsigned char * p;
mlsize_t i, j;
tag_t tag;
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) return;
again:
if (Is_long(obj)) {
hash_univ_count--;
Combine(Long_val(obj));
return;
}
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
Assert (Is_block (obj));
if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) {
tag = Tag_val(obj);
switch (tag) {
case String_tag:
hash_univ_count--;
i = caml_string_length(obj);
for (p = &Byte_u(obj, 0); i > 0; i--, p++)
Combine_small(*p);
break;
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Double_array_tag:
hash_univ_count--;
for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, j), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
}
break;
case Abstract_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Infix_tag:
hash_aux(obj - Infix_offset_val(obj));
break;
case Forward_tag:
obj = Forward_val (obj);
goto again;
case Object_tag:
hash_univ_count--;
Combine(Oid_val(obj));
break;
case Custom_tag:
/* If no hashing function provided, do nothing */
if (Custom_ops_val(obj)->hash != NULL) {
hash_univ_count--;
Combine(Custom_ops_val(obj)->hash(obj));
}
break;
default:
hash_univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(Field(obj, i));
}
break;
}
return;
}
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((intnat) obj);
}
static void extern_rec(value v)
{
tailcall:
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8(CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64(CODE_INT64, n);
#endif
} else
writecode32(CODE_INT32, n);
return;
}
if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f) && (Is_young (f) || Is_in_heap (f))
&& (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag
|| Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
goto tailcall;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32(CODE_BLOCK32, hd);
}
return;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8(CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16(CODE_SHARED16, d);
} else {
writecode32(CODE_SHARED32, d);
}
return;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location(v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location(v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location(v);
break;
}
case Abstract_tag:
extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
extern_record_location(v);
break;
}
default: {
value field0;
mlsize_t i;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location(v);
if (sz == 1) {
v = field0;
} else {
extern_rec(field0);
for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
v = Field(v, i);
}
goto tailcall;
}
}
}
void caml_oldify_one (value v, value *p)
{
value result;
header_t hd;
mlsize_t sz, i;
tag_t tag;
tail_call:
if (Is_block (v) && Is_young (v)){
if (Hp_val(v) < caml_young_ptr)
printf("%lx, %lx\n", Hp_val(v), caml_young_ptr);
Assert (Hp_val (v) >= caml_young_ptr);
hd = Hd_val (v);
if (hd == 0){ /* If already forwarded */
*p = Field (v, 0); /* then forward pointer is first field. */
}else{
tag = Tag_hd (hd);
if (tag < Infix_tag){
value field0;
sz = Wosize_hd (hd);
result = caml_alloc_shr (sz, tag);
*p = result;
field0 = Field (v, 0);
Hd_val (v) = 0; /* Set forward flag */
Field (v, 0) = result; /* and forward pointer. */
if (sz > 1){
Field (result, 0) = field0;
Field (result, 1) = oldify_todo_list; /* Add this block */
oldify_todo_list = v; /* to the "to do" list. */
}else{
Assert (sz == 1);
p = &Field (result, 0);
v = field0;
goto tail_call;
}
}else if (tag >= No_scan_tag){
sz = Wosize_hd (hd);
result = caml_alloc_shr (sz, tag);
for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
Hd_val (v) = 0; /* Set forward flag */
Field (v, 0) = result; /* and forward pointer. */
*p = result;
}else if (tag == Infix_tag){
mlsize_t offset = Infix_offset_hd (hd);
caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */
*p += offset;
}else{
value f = Forward_val (v);
tag_t ft = 0;
int vv = 1;
Assert (tag == Forward_tag);
if (Is_block (f)){
vv = Is_in_value_area(f);
if (vv) {
ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
}
}
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 = caml_alloc_shr (1, Forward_tag);
*p = result;
Hd_val (v) = 0; /* Set (GC) forward flag */
Field (v, 0) = result; /* and forward pointer. */
p = &Field (result, 0);
v = f;
goto tail_call;
}else{
v = f; /* Follow the forwarding */
goto tail_call; /* then oldify. */
}
}
}
}else{
*p = v;
}
}
static void hash_aux(value obj)
{
unsigned char * p;
mlsize_t i;
tag_t tag;
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) {
if (safe) {
fatal_error("hash: count limit exceeded\n");
} else {
return;
}
}
if (IS_LONG(obj)) {
hash_univ_count--;
Combine(VAL_TO_LONG(obj));
return;
}
/* Atoms are not in the heap, but it's better to hash their tag
than to do nothing. */
if (Is_atom(obj)) {
tag = Tag_val(obj);
hash_univ_count--;
Combine_small(tag);
return;
}
/* Pointers into the heap are well-structured blocks.
We can inspect the block contents. */
if (Is_in_heap(obj) || Is_young(obj)) {
tag = Tag_val(obj);
switch (tag) {
case String_tag:
hash_univ_count--;
{
mlsize_t len = string_length(obj);
i = len <= 128 ? len : 128;
// Hash on 128 first characters
for (p = &Byte_u(obj, 0); i > 0; i--, p++) {
Combine_small(*p);
}
// Hash on logarithmically many additional characters beyond 128
for (i = 1; i+127 < len; i *= 2) {
Combine_small(Byte_u(obj, 127+i));
}
break;
}
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
hash_univ_count--;
#ifdef WORDS_BIGENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Abstract_tag:
case Final_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Reference_tag:
/* We can't hash on the heap address itself, since the reference block
* may be moved (from the young generation to the old one).
* But, we may follow the pointer. On cyclic structures this will
* terminate because the hash_univ_count gets decremented.
*/
/* Poor idea to hash on the pointed-to structure, even so: it may change,
* and hence the hash value of the value changes, although the ref
* doesn't.
*
* This breaks most hash table implementations. sestoft 2000-02-20.
*/
if (safe) {
fatal_error("hash: ref encountered\n");
}
Combine_small(tag);
hash_univ_count--;
break;
default:
hash_univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(Field(obj, i));
}
break;
}
return;
}
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((long) obj);
}
static int value_is_young(value obj)
{
return (Is_block(obj) && Is_young(obj));
}
static void caml_oldify_one (value v, value *p)
{
value result;
header_t hd;
mlsize_t sz, i;
tag_t tag;
tail_call:
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 (Is_promoted_hd (hd)) {
*p = caml_addrmap_lookup(&caml_domain_state->remembered_set->promotion, v);
} else if (hd == 0){ /* If already forwarded */
*p = Op_val(v)[0]; /* then forward pointer is first field. */
}else{
tag = Tag_hd (hd);
if (tag < Infix_tag){
value field0;
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 {
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){
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. */
*p = result;
}else if (tag == Infix_tag){
mlsize_t offset = Infix_offset_hd (hd);
caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */
*p += offset;
} else{
value f = Forward_val (v);
tag_t ft = 0;
int vv = 1;
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 (!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);
*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{
v = f; /* Follow the forwarding */
goto tail_call; /* then oldify. */
}
}
}
}else{
*p = v;
}
}
/* Make sure the minor heap is empty by performing a minor collection if
* needed. */
void caml_empty_minor_heap (void)
{
uintnat minor_allocated_bytes = caml_domain_state->young_end - caml_domain_state->young_ptr;
unsigned rewritten = 0;
struct caml_ref_entry *r;
caml_save_stack_gc();
stat_live_bytes = 0;
if (minor_allocated_bytes != 0){
caml_gc_log ("Minor collection starting");
caml_do_local_roots(&caml_oldify_one, caml_domain_self());
for (r = caml_domain_state->remembered_set->ref.base; r < caml_domain_state->remembered_set->ref.ptr; r++){
value x;
caml_oldify_one (Op_val(r->obj)[r->field], &x);
}
for (r = caml_domain_state->remembered_set->fiber_ref.base; r < caml_domain_state->remembered_set->fiber_ref.ptr; r++) {
caml_scan_dirty_stack(&caml_oldify_one, r->obj);
}
caml_oldify_mopup ();
for (r = caml_domain_state->remembered_set->ref.base; r < caml_domain_state->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);
// FIXME: call oldify_one here?
if (Is_promoted_hd(hd)) {
vnew = caml_addrmap_lookup(&caml_domain_state->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(Is_block(vnew) && !Is_young(vnew));
Assert(Hd_val(vnew));
if (Tag_hd(hd) == Infix_tag) { Assert(Tag_val(vnew) == Infix_tag); }
rewritten += caml_atomic_cas_field(r->obj, r->field, v, vnew);
}
}
caml_addrmap_iter(&caml_domain_state->remembered_set->promotion, unpin_promoted_object);
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_domain_state->young_ptr = caml_domain_state->young_end;
clear_table (&caml_domain_state->remembered_set->ref);
caml_addrmap_clear(&caml_domain_state->remembered_set->promotion);
caml_addrmap_clear(&caml_domain_state->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);
}
for (r = caml_domain_state->remembered_set->fiber_ref.base; r < caml_domain_state->remembered_set->fiber_ref.ptr; r++) {
caml_scan_dirty_stack(&caml_darken, r->obj);
caml_clean_stack(r->obj);
}
clear_table (&caml_domain_state->remembered_set->fiber_ref);
caml_restore_stack_gc();
#ifdef DEBUG
{
value *p;
for (p = (value *) caml_domain_state->young_start;
p < (value *) caml_domain_state->young_end; ++p){
*p = Debug_free_minor;
}
++ minor_gc_counter;
}
#endif
}
