CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
{
header_t *hp;
value *new_block;
if (wosize > Max_wosize) caml_raise_out_of_memory ();
hp = caml_fl_allocate (wosize);
if (hp == NULL){
new_block = expand_heap (wosize);
if (new_block == NULL) {
if (caml_in_minor_collection)
caml_fatal_error ("Fatal error: out of memory.\n");
else
caml_raise_out_of_memory ();
}
caml_fl_add_blocks ((value) new_block);
hp = caml_fl_allocate (wosize);
}
Assert (Is_in_heap (Val_hp (hp)));
/* Inline expansion of caml_allocation_color. */
if (caml_gc_phase == Phase_mark
|| (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
Hd_hp (hp) = Make_header (wosize, tag, Caml_black);
}else{
Assert (caml_gc_phase == Phase_idle
|| (caml_gc_phase == Phase_sweep
&& (addr)hp < (addr)caml_gc_sweep_hp));
Hd_hp (hp) = Make_header (wosize, tag, Caml_white);
}
Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp)));
caml_allocated_words += Whsize_wosize (wosize);
if (caml_allocated_words > caml_minor_heap_wsz){
caml_urge_major_slice ();
}
#ifdef DEBUG
{
uintnat i;
for (i = 0; i < wosize; i++){
Field (Val_hp (hp), i) = Debug_uninit_major;
}
}
#endif
return Val_hp (hp);
}
void ocamlpool_enter(void)
{
assert_out_of_section();
static int ocamlpool_initialized = 0;
if (ocamlpool_initialized == 0)
{
ocamlpool_initialized = 1;
caml_register_global_root(&ocamlpool_root);
}
if (ocamlpool_root != Val_unit)
ocamlpool_color = caml_allocation_color((void*)ocamlpool_root);
ocamlpool_in_section = 1;
ocamlpool_sane_young_ptr = caml_young_ptr;
assert_in_section();
}
static void ocamlpool_chunk_alloc(void)
{
ocamlpool_assert(ocamlpool_next_chunk_size > 1);
void *block = caml_alloc_for_heap(ocamlpool_next_chunk_size * WORD_SIZE);
abort_unless(block != NULL);
size_t chunk_size = Chunk_size(block);
ocamlpool_assert(IS_WORD_ALIGNED(chunk_size));
ocamlpool_color = caml_allocation_color(block);
ocamlpool_allocated_chunks_counter += 1;
size_t words = (chunk_size / WORD_SIZE);
ocamlpool_root = (value)((value*)block + 1);
/* Make it look like a well-formed string */
OCAMLPOOL_SET_HEADER(ocamlpool_root, words - 1, String_tag, ocamlpool_color);
caml_add_to_heap(block);
caml_allocated_words += words;
}
value netsys_copy_value(value flags, value orig)
{
int code;
int cflags;
intnat start_offset, bytelen;
mlsize_t wosize;
char *dest, *dest_end, *extra_block, *extra_block_end;
int color;
struct named_custom_ops bigarray_ops;
struct named_custom_ops int32_ops;
struct named_custom_ops int64_ops;
struct named_custom_ops nativeint_ops;
CAMLparam2(orig,flags);
CAMLlocal1(block);
/* First test on trivial cases: */
if (Is_long(orig) || Wosize_val(orig) == 0) {
CAMLreturn(orig);
};
code = prep_stat_tab();
if (code != 0) goto exit;
code = prep_stat_queue();
if (code != 0) goto exit;
cflags = caml_convert_flag_list(flags, init_value_flags);
/* fprintf (stderr, "counting\n"); */
/* Count only! */
code = netsys_init_value_1(stat_tab, stat_queue, NULL, NULL, orig,
(cflags & 1) ? 1 : 0, /* enable_bigarrays */
(cflags & 2) ? 1 : 0, /* enable_customs */
1, /* enable_atoms */
1, /* simulate */
NULL, NULL, 0, &start_offset, &bytelen);
if (code != 0) goto exit;
/* fprintf (stderr, "done counting bytelen=%ld\n", bytelen); */
/* set up the custom ops. We always set this, because we assume that
the values in [orig] are not trustworthy
*/
bigarray_ops.name = "_bigarray";
bigarray_ops.ops =
Custom_ops_val(alloc_bigarray_dims(CAML_BA_UINT8 | BIGARRAY_C_LAYOUT,
1, NULL, 1));
bigarray_ops.next = &int32_ops;
int32_ops.name = "_i";
int32_ops.ops = Custom_ops_val(caml_copy_int32(0));
int32_ops.next = &int64_ops;
int64_ops.name = "_j";
int64_ops.ops = Custom_ops_val(caml_copy_int64(0));
int64_ops.next = &nativeint_ops;
nativeint_ops.name = "_n";
nativeint_ops.ops = Custom_ops_val(caml_copy_nativeint(0));
nativeint_ops.next = NULL;
/* alloc */
extra_block = NULL;
extra_block_end = NULL;
/* shamelessly copied from intern.c */
wosize = Wosize_bhsize(bytelen);
/* fprintf (stderr, "wosize=%ld\n", wosize); */
if (wosize > Max_wosize) {
/* Round desired size up to next page */
asize_t request = ((bytelen + Page_size - 1) >> Page_log) << Page_log;
extra_block = caml_alloc_for_heap(request);
if (extra_block == NULL) caml_raise_out_of_memory();
extra_block_end = extra_block + request;
color = caml_allocation_color(extra_block);
dest = extra_block;
dest_end = dest + bytelen;
block = Val_hp(extra_block);
} else {
