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 {