/* [size] is a number of bytes */
CAMLexport value caml_alloc_custom(struct custom_operations * ops,
uintnat size,
mlsize_t mem,
mlsize_t max)
{
mlsize_t wosize;
value result;
wosize = 1 + (size + sizeof(value) - 1) / sizeof(value);
if (wosize <= Max_young_wosize) {
result = caml_alloc_small(wosize, Custom_tag);
Custom_ops_val(result) = ops;
if (ops->finalize != NULL) {
/* Remembered that the block has a finalizer */
if (caml_finalize_table.ptr >= caml_finalize_table.limit){
CAMLassert (caml_finalize_table.ptr == caml_finalize_table.limit);
caml_realloc_ref_table (&caml_finalize_table);
}
*caml_finalize_table.ptr++ = (value *)result;
}
} else {
result = caml_alloc_shr(wosize, Custom_tag);
Custom_ops_val(result) = ops;
caml_adjust_gc_speed(mem, max);
result = caml_check_urgent_gc(result);
}
return result;
}
value expr_allocate()
{
#define wosize ( 2 + (sizeof(expr) + sizeof(value) - 1) / sizeof(value) )
value ret;
if( wosize < Max_young_wosize )
ret = caml_alloc_small( wosize, Custom_tag );
else
ret = caml_alloc_shr( wosize, Custom_tag );
Field( ret, 0 ) = (value)&expr_ops;
return ret;
}
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);
}
CAMLprim value caml_weak_create (value len)
{
mlsize_t size, i;
value res;
size = Long_val (len) + 1;
if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create");
res = caml_alloc_shr (size, Abstract_tag);
for (i = 1; i < size; i++) Field (res, i) = caml_weak_none;
Field (res, 0) = caml_weak_list_head;
caml_weak_list_head = res;
return res;
}
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;
caml_plat_unlock(&roots_mutex);
CAMLreturnT(caml_root, (caml_root)v);
}
static value netsys_alloc_string_shr(mlsize_t len)
{
/* Always allocate in major heap */
value result;
mlsize_t offset_index;
mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
result = caml_alloc_shr (wosize, String_tag);
result = caml_check_urgent_gc (result);
Field (result, wosize - 1) = 0;
offset_index = Bsize_wsize (wosize) - 1;
Byte (result, offset_index) = offset_index - len;
return result;
}
CAMLexport value caml_alloc_string (mlsize_t len)
{
value result;
mlsize_t offset_index;
mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
if (wosize <= Max_young_wosize) {
Alloc_small (result, wosize, String_tag);
}else{
result = caml_alloc_shr (wosize, String_tag);
result = caml_check_urgent_gc (result);
}
Field (result, wosize - 1) = 0;
offset_index = Bsize_wsize (wosize) - 1;
Byte (result, offset_index) = offset_index - len;
return result;
}
value caml_alloc_main_stack (uintnat init_size)
{
CAMLparam0();
CAMLlocal1(stack);
/* Create a stack for the main program.
The GC is not initialised yet, so we use caml_alloc_shr
which cannot trigger it */
stack = caml_alloc_shr(init_size, Stack_tag);
Stack_dirty(stack) = Val_long(0);
Stack_handle_value(stack) = Val_long(0);
Stack_handle_exception(stack) = Val_long(0);
Stack_handle_effect(stack) = Val_long(0);
Stack_parent(stack) = Val_unit;
Stack_sp(stack) = 0;
CAMLreturn(stack);
}
CAMLexport value caml_alloc_custom(struct custom_operations * ops,
uintnat size,
mlsize_t mem,
mlsize_t max)
{
mlsize_t wosize;
value result;
wosize = 1 + (size + sizeof(value) - 1) / sizeof(value);
if (ops->finalize == NULL && wosize <= Max_young_wosize) {
result = caml_alloc_small(wosize, Custom_tag);
Custom_ops_val(result) = ops;
} else {
result = caml_alloc_shr(wosize, Custom_tag);
Custom_ops_val(result) = ops;
caml_adjust_gc_speed(mem, max);
result = caml_check_urgent_gc(result);
}
return result;
}
CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
{
value result;
mlsize_t i;
Assert (tag < 256);
Assert (tag != Infix_tag);
if (wosize == 0){
result = Atom (tag);
}else if (wosize <= Max_young_wosize){
Alloc_small (result, wosize, tag);
if (tag < No_scan_tag){
for (i = 0; i < wosize; i++) Field (result, i) = 0;
}
}else{
result = caml_alloc_shr (wosize, tag);
if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize));
result = caml_check_urgent_gc (result);
}
return result;
}
CAMLprim value caml_realloc_global(value size)
{
mlsize_t requested_size, actual_size, i;
value new_global_data;
requested_size = Long_val(size);
actual_size = Wosize_val(caml_global_data);
if (requested_size >= actual_size) {
requested_size = (requested_size + 0x100) & 0xFFFFFF00;
caml_gc_message (0x08, "Growing global data to %lu entries\n",
requested_size);
new_global_data = caml_alloc_shr(requested_size, 0);
for (i = 0; i < actual_size; i++)
caml_initialize(&Field(new_global_data, i), Field(caml_global_data, i));
for (i = actual_size; i < requested_size; i++){
Field (new_global_data, i) = Val_long (0);
}
caml_global_data = new_global_data;
}
return Val_unit;
}
CAMLprim value caml_realloc_global(value size)
{
mlsize_t requested_size, actual_size, i;
value old_global_data = caml_read_root(caml_global_data);
value new_global_data;
requested_size = Long_val(size);
actual_size = Wosize_val(old_global_data);
if (requested_size >= actual_size) {
requested_size = (requested_size + 0x100) & 0xFFFFFF00;
caml_gc_log ("Growing global data to %u entries",
(unsigned)requested_size);
new_global_data = caml_alloc_shr(requested_size, 0);
for (i = 0; i < actual_size; i++)
caml_initialize_field(new_global_data, i, Field(old_global_data, i));
for (i = actual_size; i < requested_size; i++){
caml_initialize_field(new_global_data, i, Val_long(0));
}
caml_modify_root(caml_global_data, new_global_data);
}
return Val_unit;
}
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;
}
}
