value* caml_shared_try_alloc(struct caml_heap_state* local, mlsize_t wosize,
tag_t tag, int pinned)
{
mlsize_t whsize = Whsize_wosize(wosize);
value* p;
uintnat colour;
Assert (wosize > 0);
Assert (tag != Infix_tag);
if (whsize <= SIZECLASS_MAX) {
sizeclass sz = sizeclass_wsize[whsize];
Assert(wsize_sizeclass[sz] >= whsize);
p = pool_allocate(local, sz);
if (!p) return 0;
struct heap_stats* s = &local->stats;
s->pool_live_blocks++;
s->pool_live_words += whsize;
s->pool_frag_words += wsize_sizeclass[sz] - whsize;
} else {
p = large_allocate(local, Bsize_wsize(whsize));
if (!p) return 0;
}
colour = pinned ? NOT_MARKABLE : global.MARKED;
Hd_hp (p) = Make_header(wosize, tag, colour);
#ifdef DEBUG
{
int i;
for (i = 0; i < wosize; i++) {
Op_val(Val_hp(p))[i] = Debug_free_major;
}
}
#endif
return p;
}
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);
}
/* Allocate more memory from malloc for the heap.
Return a blue block of at least the requested size.
The blue block is chained to a sequence of blue blocks (through their
field 0); the last block of the chain is pointed by field 1 of the
first. There may be a fragment after the last block.
The caller must insert the blocks into the free list.
[request] is a number of words and must be less than or equal
to [Max_wosize].
Return NULL when out of memory.
*/
static value *expand_heap (mlsize_t request)
{
/* these point to headers, but we do arithmetic on them, hence [value *]. */
value *mem, *hp, *prev;
asize_t over_request, malloc_request, remain;
Assert (request <= Max_wosize);
over_request = Whsize_wosize (request + request / 100 * caml_percent_free);
malloc_request = caml_round_heap_chunk_wsz (over_request);
mem = (value *) caml_alloc_for_heap (Bsize_wsize (malloc_request));
if (mem == NULL){
caml_gc_message (0x04, "No room for growing heap\n", 0);
return NULL;
}
remain = malloc_request;
prev = hp = mem;
/* FIXME find a way to do this with a call to caml_make_free_blocks */
while (Wosize_whsize (remain) > Max_wosize){
Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue);
#ifdef DEBUG
caml_set_fields (Val_hp (hp), 0, Debug_free_major);
#endif
hp += Whsize_wosize (Max_wosize);
remain -= Whsize_wosize (Max_wosize);
Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp);
prev = hp;
}
if (remain > 1){
Hd_hp (hp) = Make_header (Wosize_whsize (remain), 0, Caml_blue);
#ifdef DEBUG
caml_set_fields (Val_hp (hp), 0, Debug_free_major);
#endif
Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp);
Field (Val_hp (hp), 0) = (value) NULL;
}else{
Field (Val_hp (prev), 0) = (value) NULL;
if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white);
}
Assert (Wosize_hp (mem) >= request);
if (caml_add_to_heap ((char *) mem) != 0){
caml_free_for_heap ((char *) mem);
return NULL;
}
return Op_hp (mem);
}
/* Allocate more memory from malloc for the heap.
Return a blue block of at least the requested size.
The blue block is chained to a sequence of blue blocks (through their
field 0); the last block of the chain is pointed by field 1 of the
first. There may be a fragment after the last block.
The caller must insert the blocks into the free list.
The request must be less than or equal to Max_wosize.
Return NULL when out of memory.
*/
static char *expand_heap (mlsize_t request)
{
char *mem, *hp, *prev;
asize_t over_request, malloc_request, remain;
Assert (request <= Max_wosize);
over_request = request + request / 100 * caml_percent_free;
malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request));
mem = caml_alloc_for_heap (malloc_request);
if (mem == NULL){
caml_gc_message (0x04, "No room for growing heap\n", 0);
return NULL;
}
remain = malloc_request;
prev = hp = mem;
/* FIXME find a way to do this with a call to caml_make_free_blocks */
while (Wosize_bhsize (remain) > Max_wosize){
Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue);
#ifdef DEBUG
caml_set_fields (Bp_hp (hp), 0, Debug_free_major);
#endif
hp += Bhsize_wosize (Max_wosize);
remain -= Bhsize_wosize (Max_wosize);
Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp);
prev = hp;
}
if (remain > 1){
Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue);
#ifdef DEBUG
caml_set_fields (Bp_hp (hp), 0, Debug_free_major);
#endif
Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp);
Field (Op_hp (hp), 0) = (value) NULL;
}else{
Field (Op_hp (prev), 0) = (value) NULL;
if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white);
}
Assert (Wosize_hp (mem) >= request);
if (caml_add_to_heap (mem) != 0){
caml_free_for_heap (mem);
return NULL;
}
return Bp_hp (mem);
}
CAMLexport void * caml_stat_alloc (asize_t sz)
{
void* result = malloc (sizeof(value) + sz);
if (result == NULL)
caml_raise_out_of_memory();
Hd_hp(result) = Make_header(STAT_ALLOC_MAGIC, Abstract_tag, NOT_MARKABLE);
#ifdef DEBUG
memset ((void*)Val_hp(result), Debug_uninit_stat, sz);
#endif
return (void*)Val_hp(result);
}
EXTERN value alloc_shr (mlsize_t wosize, tag_t tag)
{
char *hp, *new_block;
hp = fl_allocate (wosize);
if (hp == NULL){
new_block = expand_heap (wosize);
if (new_block == NULL) raise_out_of_memory ();
fl_add_block (new_block);
hp = fl_allocate (wosize);
if (hp == NULL) fatal_error ("alloc_shr: expand heap failed\n");
}
Assert (Is_in_heap (Val_hp (hp)));
if (gc_phase == Phase_mark || (addr)hp >= (addr)gc_sweep_hp){
Hd_hp (hp) = Make_header (wosize, tag, Black);
}else{
Hd_hp (hp) = Make_header (wosize, tag, White);
}
allocated_words += Whsize_wosize (wosize);
if (allocated_words > Wsize_bsize (minor_heap_size)) force_minor_gc ();
return Val_hp (hp);
}
static value next_minor_block(caml_domain_state* domain_state, value curr_hp)
{
mlsize_t wsz;
header_t hd;
value curr_val;
CAMLassert ((value)domain_state->young_ptr <= curr_hp);
CAMLassert (curr_hp < (value)domain_state->young_end);
hd = Hd_hp(curr_hp);
curr_val = Val_hp(curr_hp);
if (hd == 0) {
/* Forwarded object, find the promoted version */
curr_val = Op_val(curr_val)[0];
}
CAMLassert (Is_block(curr_val) && Hd_val(curr_val) != 0 && Tag_val(curr_val) != Infix_tag);
wsz = Wosize_val(curr_val);
CAMLassert (wsz <= Max_young_wosize);
return curr_hp + Bsize_wsize(Whsize_wosize(wsz));
}
/* Allocate more memory from malloc for the heap.
Return a blue block of at least the requested size (in words).
The caller must insert the block into the free list.
The request must be less than or equal to Max_wosize.
Return NULL when out of memory.
*/
static char *expand_heap (mlsize_t request)
{
char *mem;
asize_t malloc_request;
malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (request));
mem = caml_alloc_for_heap (malloc_request);
if (mem == NULL){
caml_gc_message (0x04, "No room for growing heap\n", 0);
return NULL;
}
Assert (Wosize_bhsize (malloc_request) >= request);
Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Caml_blue);
if (caml_add_to_heap (mem) != 0){
caml_free_for_heap (mem);
return NULL;
}
return Bp_hp (mem);
}
value* caml_shared_try_alloc(struct caml_heap_state* local, mlsize_t wosize, tag_t tag, int pinned) {
mlsize_t whsize = Whsize_wosize(wosize);
value* p;
Assert (wosize > 0);
Assert (tag != Infix_tag);
if (whsize <= SIZECLASS_MAX) {
p = pool_allocate(local, sizeclass_wsize[whsize]);
} else {
p = large_allocate(local, Bsize_wsize(whsize));
}
if (!p) return 0;
Hd_hp (p) = Make_header(wosize, tag, pinned ? NOT_MARKABLE : global.UNMARKED);
#ifdef DEBUG
{
int i;
for (i = 0; i < wosize; i++) {
Op_val(Val_hp(p))[i] = Debug_free_major;
}
}
#endif
return p;
}
/* Check the heap structure (if compiled in debug mode) and
gather statistics; return the stats if [returnstats] is true,
otherwise return [Val_unit].
*/
static value heap_stats (int returnstats)
{
CAMLparam0 ();
intnat live_words = 0, live_blocks = 0,
free_words = 0, free_blocks = 0, largest_free = 0,
fragments = 0, heap_chunks = 0;
char *chunk = caml_heap_start, *chunk_end;
header_t *cur_hp;
#ifdef DEBUG
header_t *prev_hp;
#endif
header_t cur_hd;
#ifdef DEBUG
caml_gc_message (-1, "### OCaml runtime: heap check ###\n", 0);
#endif
while (chunk != NULL){
++ heap_chunks;
chunk_end = chunk + Chunk_size (chunk);
#ifdef DEBUG
prev_hp = NULL;
#endif
cur_hp = (header_t *) chunk;
while (cur_hp < (header_t *) chunk_end){
cur_hd = Hd_hp (cur_hp);
Assert (Next (cur_hp) <= (header_t *) chunk_end);
switch (Color_hd (cur_hd)){
case Caml_white:
if (Wosize_hd (cur_hd) == 0){
++ fragments;
Assert (prev_hp == NULL
|| Color_hp (prev_hp) != Caml_blue
|| cur_hp == (header_t *) caml_gc_sweep_hp);
}else{
if (caml_gc_phase == Phase_sweep
&& cur_hp >= (header_t *) caml_gc_sweep_hp){
++ free_blocks;
free_words += Whsize_hd (cur_hd);
if (Whsize_hd (cur_hd) > largest_free){
largest_free = Whsize_hd (cur_hd);
}
}else{
++ live_blocks;
live_words += Whsize_hd (cur_hd);
#ifdef DEBUG
check_block (cur_hp);
#endif
}
}
break;
case Caml_gray: case Caml_black:
Assert (Wosize_hd (cur_hd) > 0);
++ live_blocks;
live_words += Whsize_hd (cur_hd);
#ifdef DEBUG
check_block (cur_hp);
#endif
break;
case Caml_blue:
Assert (Wosize_hd (cur_hd) > 0);
++ free_blocks;
free_words += Whsize_hd (cur_hd);
if (Whsize_hd (cur_hd) > largest_free){
largest_free = Whsize_hd (cur_hd);
}
/* not true any more with big heap chunks
Assert (prev_hp == NULL
|| (Color_hp (prev_hp) != Caml_blue && Wosize_hp (prev_hp) > 0)
|| cur_hp == caml_gc_sweep_hp);
Assert (Next (cur_hp) == chunk_end
|| (Color_hp (Next (cur_hp)) != Caml_blue
&& Wosize_hp (Next (cur_hp)) > 0)
|| (Whsize_hd (cur_hd) + Wosize_hp (Next (cur_hp)) > Max_wosize)
|| Next (cur_hp) == caml_gc_sweep_hp);
*/
break;
}
#ifdef DEBUG
prev_hp = cur_hp;
#endif
cur_hp = Next (cur_hp);
} Assert (cur_hp == (header_t *) chunk_end);
chunk = Chunk_next (chunk);
}
Assert (heap_chunks == caml_stat_heap_chunks);
Assert (live_words + free_words + fragments == caml_stat_heap_wsz);
if (returnstats){
CAMLlocal1 (res);
/* get a copy of these before allocating anything... */
double minwords = caml_stat_minor_words
+ (double) (caml_young_alloc_end - caml_young_ptr);
double prowords = caml_stat_promoted_words;
double majwords = caml_stat_major_words + (double) caml_allocated_words;
intnat mincoll = caml_stat_minor_collections;
intnat majcoll = caml_stat_major_collections;
intnat heap_words = caml_stat_heap_wsz;
intnat cpct = caml_stat_compactions;
intnat top_heap_words = caml_stat_top_heap_wsz;
res = caml_alloc_tuple (16);
Store_field (res, 0, caml_copy_double (minwords));
Store_field (res, 1, caml_copy_double (prowords));
Store_field (res, 2, caml_copy_double (majwords));
Store_field (res, 3, Val_long (mincoll));
Store_field (res, 4, Val_long (majcoll));
Store_field (res, 5, Val_long (heap_words));
Store_field (res, 6, Val_long (heap_chunks));
Store_field (res, 7, Val_long (live_words));
Store_field (res, 8, Val_long (live_blocks));
Store_field (res, 9, Val_long (free_words));
Store_field (res, 10, Val_long (free_blocks));
Store_field (res, 11, Val_long (largest_free));
Store_field (res, 12, Val_long (fragments));
Store_field (res, 13, Val_long (cpct));
Store_field (res, 14, Val_long (top_heap_words));
Store_field (res, 15, Val_long (caml_stack_usage()));
CAMLreturn (res);
}else{
CAMLreturn (Val_unit);
}
}
static void do_compaction_r (CAML_R)
{
char *ch, *chend;
Assert (caml_gc_phase == Phase_idle);
caml_gc_message (0x10, "Compacting heap...\n", 0);
#ifdef DEBUG
caml_heap_check_r (ctx);
#endif
/* First pass: encode all noninfix headers. */
{
ch = caml_heap_start;
while (ch != NULL){
header_t *p = (header_t *) ch;
chend = ch + Chunk_size (ch);
while ((char *) p < chend){
header_t hd = Hd_hp (p);
mlsize_t sz = Wosize_hd (hd);
if (Is_blue_hd (hd)){
/* Free object. Give it a string tag. */
Hd_hp (p) = Make_ehd (sz, String_tag, 3);
}else{ Assert (Is_white_hd (hd));
/* Live object. Keep its tag. */
Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3);
}
p += Whsize_wosize (sz);
}
ch = Chunk_next (ch);
}
}
/* Second pass: invert pointers.
Link infix headers in each block in an inverted list of inverted lists.
Don't forget roots and weak pointers. */
{
/* Invert roots first because the threads library needs some heap
data structures to find its roots. Fortunately, it doesn't need
the headers (see above). */
caml_do_roots_r (ctx, invert_root_r);
caml_final_do_weak_roots_r (ctx, invert_root_r);
ch = caml_heap_start;
while (ch != NULL){
word *p = (word *) ch;
chend = ch + Chunk_size (ch);
while ((char *) p < chend){
word q = *p;
size_t sz, i;
tag_t t;
word *infixes;
while (Ecolor (q) == 0) q = * (word *) q;
sz = Whsize_ehd (q);
t = Tag_ehd (q);
if (t == Infix_tag){
/* Get the original header of this block. */
infixes = p + sz;
q = *infixes;
while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
sz = Whsize_ehd (q);
t = Tag_ehd (q);
}
if (t < No_scan_tag){
for (i = 1; i < sz; i++) invert_pointer_at_r (ctx, &(p[i]));
}
p += sz;
}
ch = Chunk_next (ch);
}
/* Invert weak pointers. */
{
value *pp = &caml_weak_list_head;
value p;
word q;
size_t sz, i;
while (1){
p = *pp;
if (p == (value) NULL) break;
q = Hd_val (p);
while (Ecolor (q) == 0) q = * (word *) q;
sz = Wosize_ehd (q);
for (i = 1; i < sz; i++){
if (Field (p,i) != caml_weak_none){
invert_pointer_at_r (ctx, (word *) &(Field (p,i)));
}
}
invert_pointer_at_r (ctx, (word *) pp);
pp = &Field (p, 0);
}
}
}
/* Third pass: reallocate virtually; revert pointers; decode headers.
Rebuild infix headers. */
{
init_compact_allocate_r (ctx);
ch = caml_heap_start;
while (ch != NULL){
word *p = (word *) ch;
chend = ch + Chunk_size (ch);
while ((char *) p < chend){
word q = *p;
if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){
/* There were (normal or infix) pointers to this block. */
size_t sz;
tag_t t;
char *newadr;
word *infixes = NULL;
while (Ecolor (q) == 0) q = * (word *) q;
sz = Whsize_ehd (q);
t = Tag_ehd (q);
if (t == Infix_tag){
/* Get the original header of this block. */
infixes = p + sz;
q = *infixes; Assert (Ecolor (q) == 2);
while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
sz = Whsize_ehd (q);
t = Tag_ehd (q);
}
newadr = compact_allocate_r (ctx, Bsize_wsize (sz));
q = *p;
while (Ecolor (q) == 0){
word next = * (word *) q;
* (word *) q = (word) Val_hp (newadr);
q = next;
}
*p = Make_header (Wosize_whsize (sz), t, Caml_white);
if (infixes != NULL){
/* Rebuild the infix headers and revert the infix pointers. */
while (Ecolor ((word) infixes) != 3){
infixes = (word *) ((word) infixes & ~(uintnat) 3);
q = *infixes;
while (Ecolor (q) == 2){
word next;
q = (word) q & ~(uintnat) 3;
next = * (word *) q;
* (word *) q = (word) Val_hp ((word *) newadr + (infixes - p));
q = next;
} Assert (Ecolor (q) == 1 || Ecolor (q) == 3);
*infixes = Make_header (infixes - p, Infix_tag, Caml_white);
infixes = (word *) q;
}
}
p += sz;
}else{ Assert (Ecolor (q) == 3);
/* This is guaranteed only if caml_compact_heap was called after a
nonincremental major GC: Assert (Tag_ehd (q) == String_tag);
*/
/* No pointers to the header and no infix header:
the object was free. */
*p = Make_header (Wosize_ehd (q), Tag_ehd (q), Caml_blue);
p += Whsize_ehd (q);
}
}
ch = Chunk_next (ch);
}
}
/* Fourth pass: reallocate and move objects.
Use the exact same allocation algorithm as pass 3. */
{
init_compact_allocate_r (ctx);
ch = caml_heap_start;
while (ch != NULL){
word *p = (word *) ch;
chend = ch + Chunk_size (ch);
while ((char *) p < chend){
word q = *p;
if (Color_hd (q) == Caml_white){
size_t sz = Bhsize_hd (q);
char *newadr = compact_allocate_r (ctx, sz);
memmove (newadr, p, sz);
p += Wsize_bsize (sz);
}else{
Assert (Color_hd (q) == Caml_blue);
p += Whsize_hd (q);
}
}
ch = Chunk_next (ch);
}
}
/* Shrink the heap if needed. */
{
/* Find the amount of live data and the unshrinkable free space. */
asize_t live = 0;
asize_t free = 0;
asize_t wanted;
ch = caml_heap_start;
while (ch != NULL){
if (Chunk_alloc (ch) != 0){
live += Wsize_bsize (Chunk_alloc (ch));
free += Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch));
}
ch = Chunk_next (ch);
}
/* Add up the empty chunks until there are enough, then remove the
other empty chunks. */
wanted = caml_percent_free * (live / 100 + 1);
ch = caml_heap_start;
while (ch != NULL){
char *next_chunk = Chunk_next (ch); /* Chunk_next (ch) will be erased */
if (Chunk_alloc (ch) == 0){
if (free < wanted){
free += Wsize_bsize (Chunk_size (ch));
}else{
caml_shrink_heap_r (ctx, ch);
}
}
ch = next_chunk;
}
}
/* Rebuild the free list. */
{
ch = caml_heap_start;
caml_fl_reset_r (ctx);
while (ch != NULL){
if (Chunk_size (ch) > Chunk_alloc (ch)){
caml_make_free_blocks_r (ctx, (value *) (ch + Chunk_alloc (ch)),
Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1,
Caml_white);
}
ch = Chunk_next (ch);
}
}
++ caml_stat_compactions;
caml_gc_message (0x10, "done.\n", 0);
}
value gc_stat (value v) /* ML */
{
value res;
long live_words = 0, live_blocks = 0,
free_words = 0, free_blocks = 0, largest_free = 0,
fragments = 0, heap_chunks = 0;
char *chunk = heap_start, *chunk_end;
char *cur_hp, *prev_hp;
header_t cur_hd;
Assert (v == Atom (0));
while (chunk != NULL){
++ heap_chunks;
chunk_end = chunk + Chunk_size (chunk);
prev_hp = NULL;
cur_hp = chunk;
while (cur_hp < chunk_end){
cur_hd = Hd_hp (cur_hp);
switch (Color_hd (cur_hd)){
case White:
if (Wosize_hd (cur_hd) == 0){
++fragments;
Assert (prev_hp == NULL
|| (Color_hp (prev_hp) != Blue
&& Wosize_hp (prev_hp) > 0));
Assert (Next (cur_hp) == chunk_end
|| (Color_hp (Next (cur_hp)) != Blue
&& Wosize_hp (Next (cur_hp)) > 0));
break;
}
/* FALLTHROUGH */
case Gray: case Black:
Assert (Wosize_hd (cur_hd) > 0);
++ live_blocks;
live_words += Whsize_hd (cur_hd);
break;
case Blue:
Assert (Wosize_hd (cur_hd) > 0);
++ free_blocks;
free_words += Whsize_hd (cur_hd);
if (Whsize_hd (cur_hd) > largest_free){
largest_free = Whsize_hd (cur_hd);
}
Assert (prev_hp == NULL
|| (Color_hp (prev_hp) != Blue
&& Wosize_hp (prev_hp) > 0));
Assert (Next (cur_hp) == chunk_end
|| (Color_hp (Next (cur_hp)) != Blue
&& Wosize_hp (Next (cur_hp)) > 0));
break;
}
prev_hp = cur_hp;
cur_hp = Next (cur_hp);
} Assert (cur_hp == chunk_end);
chunk = Chunk_next (chunk);
}
Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size));
/* Order of elements changed for Moscow ML */
res = alloc (13, 0);
Field (res, 11) = Val_long (stat_minor_words
+ Wsize_bsize (young_ptr - young_start));
Field (res, 12) = Val_long (stat_promoted_words);
Field (res, 9) = Val_long (stat_major_words + allocated_words);
Field (res, 10) = Val_long (stat_minor_collections);
Field (res, 8) = Val_long (stat_major_collections);
Field (res, 4) = Val_long (Wsize_bsize (stat_heap_size));
Field (res, 3) = Val_long (heap_chunks);
Field (res, 7) = Val_long (live_words);
Field (res, 6) = Val_long (live_blocks);
Field (res, 2) = Val_long (free_words);
Field (res, 1) = Val_long (free_blocks);
Field (res, 5) = Val_long (largest_free);
Field (res, 0) = Val_long (fragments);
return res;
}
/* Allocate more memory from malloc for the heap.
Return a block of at least the requested size (in words).
Return NULL when out of memory.
*/
static char *expand_heap (mlsize_t request)
{
char *mem;
char *new_page_table = NULL;
asize_t new_page_table_size = 0;
asize_t malloc_request;
asize_t i, more_pages;
malloc_request = round_heap_chunk_size (Bhsize_wosize (request));
gc_message ("Growing heap to %ldk\n",
(stat_heap_size + malloc_request) / 1024);
mem = aligned_malloc (malloc_request + sizeof (heap_chunk_head),
sizeof (heap_chunk_head));
if (mem == NULL){
gc_message ("No room for growing heap\n", 0);
return NULL;
}
mem += sizeof (heap_chunk_head);
(((heap_chunk_head *) mem) [-1]).size = malloc_request;
Assert (Wosize_bhsize (malloc_request) >= request);
Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Blue);
#ifndef SIXTEEN
if (mem < heap_start){
/* This is WRONG, Henning Niss 2005: */
more_pages = -Page (mem);
}else if (Page (mem + malloc_request) > page_table_size){
Assert (mem >= heap_end);
more_pages = Page (mem + malloc_request) - page_table_size;
}else{
more_pages = 0;
}
if (more_pages != 0){
new_page_table_size = page_table_size + more_pages;
new_page_table = (char *) malloc (new_page_table_size);
if (new_page_table == NULL){
gc_message ("No room for growing page table\n", 0);
free (mem);
return NULL;
}
}
if (mem < heap_start){
Assert (more_pages != 0);
for (i = 0; i < more_pages; i++){
new_page_table [i] = Not_in_heap;
}
bcopy (page_table, new_page_table + more_pages, page_table_size);
(((heap_chunk_head *) mem) [-1]).next = heap_start;
heap_start = mem;
}else{
char **last;
char *cur;
if (mem >= heap_end) heap_end = mem + malloc_request;
if (more_pages != 0){
for (i = page_table_size; i < new_page_table_size; i++){
new_page_table [i] = Not_in_heap;
}
bcopy (page_table, new_page_table, page_table_size);
}
last = &heap_start;
cur = *last;
while (cur != NULL && cur < mem){
last = &((((heap_chunk_head *) cur) [-1]).next);
cur = *last;
}
(((heap_chunk_head *) mem) [-1]).next = cur;
*last = mem;
}
if (more_pages != 0){
free (page_table);
page_table = new_page_table;
page_table_size = new_page_table_size;
}
#else /* Simplified version for the 8086 */
{
char **last;
char *cur;
last = &heap_start;
cur = *last;
while (cur != NULL && (char huge *) cur < (char huge *) mem){
last = &((((heap_chunk_head *) cur) [-1]).next);
cur = *last;
}
(((heap_chunk_head *) mem) [-1]).next = cur;
*last = mem;
}
#endif
for (i = Page (mem); i < Page (mem + malloc_request); i++){
page_table [i] = In_heap;
}
stat_heap_size += malloc_request;
return Bp_hp (mem);
}
void caml_empty_minor_heap_domain (struct domain* domain)
{
CAMLnoalloc;
caml_domain_state* domain_state = domain->state;
struct caml_minor_tables *minor_tables = domain_state->minor_tables;
unsigned rewrite_successes = 0;
unsigned rewrite_failures = 0;
char* young_ptr = domain_state->young_ptr;
char* young_end = domain_state->young_end;
uintnat minor_allocated_bytes = young_end - young_ptr;
struct oldify_state st = {0};
value **r;
struct caml_ephe_ref_elt *re;
struct caml_custom_elt *elt;
st.promote_domain = domain;
if (minor_allocated_bytes != 0) {
uintnat prev_alloc_words = domain_state->allocated_words;
#ifdef DEBUG
/* In DEBUG mode, verify that the minor_ref table contains all young-young pointers
from older to younger objects */
{
struct addrmap young_young_ptrs = ADDRMAP_INIT;
mlsize_t i;
value iter;
for (r = minor_tables->minor_ref.base; r < minor_tables->minor_ref.ptr; r++) {
*caml_addrmap_insert_pos(&young_young_ptrs, (value)*r) = 1;
}
for (iter = (value)young_ptr;
iter < (value)young_end;
iter = next_minor_block(domain_state, iter)) {
value hd = Hd_hp(iter);
if (hd != 0) {
value curr = Val_hp(iter);
tag_t tag = Tag_hd (hd);
if (tag < No_scan_tag && tag != Cont_tag) {
// FIXME: should scan Cont_tag
for (i = 0; i < Wosize_hd(hd); i++) {
value* f = Op_val(curr) + i;
if (Is_block(*f) && is_in_interval(*f, young_ptr, young_end) &&
*f < curr) {
CAMLassert(caml_addrmap_contains(&young_young_ptrs, (value)f));
}
}
}
}
}
caml_addrmap_clear(&young_young_ptrs);
}
#endif
caml_gc_log ("Minor collection of domain %d starting", domain->state->id);
caml_ev_begin("minor_gc");
caml_ev_begin("minor_gc/roots");
caml_do_local_roots(&oldify_one, &st, domain, 0);
caml_scan_stack(&oldify_one, &st, domain_state->current_stack);
for (r = minor_tables->major_ref.base; r < minor_tables->major_ref.ptr; r++) {
value x = **r;
oldify_one (&st, x, &x);
}
caml_ev_end("minor_gc/roots");
caml_ev_begin("minor_gc/promote");
oldify_mopup (&st);
caml_ev_end("minor_gc/promote");
caml_ev_begin("minor_gc/ephemerons");
for (re = minor_tables->ephe_ref.base;
re < minor_tables->ephe_ref.ptr; re++) {
CAMLassert (Ephe_domain(re->ephe) == domain);
if (re->offset == CAML_EPHE_DATA_OFFSET) {
/* Data field has already been handled in oldify_mopup. Handle only
* keys here. */
continue;
}
value* key = &Op_val(re->ephe)[re->offset];
if (*key != caml_ephe_none && Is_block(*key) &&
is_in_interval(*key, young_ptr, young_end)) {
resolve_infix_val(key);
if (Hd_val(*key) == 0) { /* value copied to major heap */
*key = Op_val(*key)[0];
} else {
CAMLassert(!ephe_check_alive_data(re,young_ptr,young_end));
*key = caml_ephe_none;
Ephe_data(re->ephe) = caml_ephe_none;
}
}
}
caml_ev_end("minor_gc/ephemerons");
caml_ev_begin("minor_gc/update_minor_tables");
for (r = minor_tables->major_ref.base;
r < minor_tables->major_ref.ptr; r++) {
value v = **r;
if (Is_block (v) && is_in_interval ((value)Hp_val(v), young_ptr, young_end)) {
value vnew;
header_t hd = Hd_val(v);
int offset = 0;
if (Tag_hd(hd) == Infix_tag) {
offset = Infix_offset_hd(hd);
v -= offset;
}
CAMLassert (Hd_val(v) == 0);
vnew = Op_val(v)[0] + offset;
CAMLassert (Is_block(vnew) && !Is_minor(vnew));
CAMLassert (Hd_val(vnew));
if (Tag_hd(hd) == Infix_tag) {
CAMLassert(Tag_val(vnew) == Infix_tag);
v += offset;
}
if (caml_domain_alone()) {
**r = vnew;
++rewrite_successes;
} else {
if (atomic_compare_exchange_strong((atomic_value*)*r, &v, vnew))
++rewrite_successes;
else
++rewrite_failures;
}
}
}
CAMLassert (!caml_domain_alone() || rewrite_failures == 0);
caml_ev_end("minor_gc/update_minor_tables");
caml_ev_begin("minor_gc/finalisers");
caml_final_update_last_minor(domain);
/* Run custom block finalisation of dead minor values */
for (elt = minor_tables->custom.base; elt < minor_tables->custom.ptr; elt++) {
value v = elt->block;
if (Hd_val(v) == 0) {
/* !!caml_adjust_gc_speed(elt->mem, elt->max); */
} else {
/* Block will be freed: call finalisation function, if any */
void (*final_fun)(value) = Custom_ops_val(v)->finalize;
if (final_fun != NULL) final_fun(v);
}
}
caml_final_empty_young(domain);
caml_ev_end("minor_gc/finalisers");
clear_table ((struct generic_table *)&minor_tables->major_ref);
clear_table ((struct generic_table *)&minor_tables->minor_ref);
clear_table ((struct generic_table *)&minor_tables->ephe_ref);
clear_table ((struct generic_table *)&minor_tables->custom);
domain_state->young_ptr = domain_state->young_end;
domain_state->stat_minor_words += Wsize_bsize (minor_allocated_bytes);
domain_state->stat_minor_collections++;
domain_state->stat_promoted_words += domain_state->allocated_words - prev_alloc_words;
caml_ev_end("minor_gc");
caml_gc_log ("Minor collection of domain %d completed: %2.0f%% of %u KB live, rewrite: successes=%u failures=%u",
domain->state->id,
100.0 * (double)st.live_bytes / (double)minor_allocated_bytes,
(unsigned)(minor_allocated_bytes + 512)/1024, rewrite_successes, rewrite_failures);
}
else {
caml_final_empty_young(domain);
caml_gc_log ("Minor collection of domain %d: skipping", domain->state->id);
}
#ifdef DEBUG
{
value *p;
for (p = (value *) domain_state->young_start;
p < (value *) domain_state->young_end; ++p){
*p = Debug_free_minor;
}
}
#endif
}
CAMLexport value caml_promote(struct domain* domain, value root)
{
value **r;
value iter, f;
mlsize_t i;
caml_domain_state* domain_state = domain->state;
struct caml_minor_tables *minor_tables = domain_state->minor_tables;
char* young_ptr = domain_state->young_ptr;
char* young_end = domain_state->young_end;
float percent_to_scan;
uintnat prev_alloc_words = domain_state->allocated_words;
struct oldify_state st = {0};
struct caml_ephe_ref_elt *re;
/* Integers are already shared */
if (Is_long(root))
return root;
/* Objects which are in the major heap are already shared. */
if (!Is_minor(root))
return root;
st.oldest_promoted = (value)domain_state->young_start;
st.promote_domain = domain;
CAMLassert(caml_owner_of_young_block(root) == domain);
oldify_one (&st, root, &root);
oldify_mopup (&st);
CAMLassert (!Is_minor(root));
/* FIXME: surely a newly-allocated root is already darkened? */
caml_darken(0, root, 0);
percent_to_scan = st.oldest_promoted <= (value)young_ptr ? 0.0 :
(((float)(st.oldest_promoted - (value)young_ptr)) * 100.0 /
((value)young_end - (value)domain_state->young_start));
if (percent_to_scan > Percent_to_promote_with_GC) {
caml_gc_log("caml_promote: forcing minor GC. %%_minor_to_scan=%f", percent_to_scan);
// ???
caml_empty_minor_heap_domain (domain);
} else {
caml_do_local_roots (&forward_pointer, st.promote_domain, domain, 1);
caml_scan_stack (&forward_pointer, st.promote_domain, domain_state->current_stack);
/* Scan major to young pointers. */
for (r = minor_tables->major_ref.base;
r < minor_tables->major_ref.ptr; r++) {
value old_p = **r;
if (Is_block(old_p) && is_in_interval(old_p,young_ptr,young_end)) {
value new_p = old_p;
forward_pointer (st.promote_domain, new_p, &new_p);
if (old_p != new_p) {
if (caml_domain_alone())
**r = new_p;
else
atomic_compare_exchange_strong((atomic_value*)*r, &old_p, new_p);
}
}
}
/* Scan ephemeron ref table */
for (re = minor_tables->ephe_ref.base;
re < minor_tables->ephe_ref.ptr; re++) {
value* key = &Op_val(re->ephe)[re->offset];
if (Is_block(*key) && is_in_interval(*key,young_ptr,young_end)) {
forward_pointer (st.promote_domain, *key, key);
}
}
/* Scan young to young pointers */
for (r = minor_tables->minor_ref.base; r < minor_tables->minor_ref.ptr; r++) {
forward_pointer (st.promote_domain, **r, *r);
}
/* Scan newer objects */
for (iter = (value)young_ptr;
iter <= st.oldest_promoted;
iter = next_minor_block(domain_state, iter)) {
value hd = Hd_hp(iter);
value curr = Val_hp(iter);
if (hd != 0) {
tag_t tag = Tag_hd (hd);
if (tag == Cont_tag) {
struct stack_info* stk = Ptr_val(Op_val(curr)[0]);
if (stk != NULL)
caml_scan_stack(&forward_pointer, st.promote_domain, stk);
} else if (tag < No_scan_tag) {
for (i = 0; i < Wosize_hd (hd); i++) {
f = Op_val(curr)[i];
if (Is_block(f)) {
forward_pointer (st.promote_domain, f,((value*)curr) + i);
}
}
}
}
}
}
domain_state->stat_promoted_words += domain_state->allocated_words - prev_alloc_words;
return root;
}
/* Allocate more memory from malloc for the heap.
Return a block of at least the requested size (in words).
Return NULL when out of memory.
*/
static char *expand_heap (mlsize_t request)
{
char *mem;
char *new_page_table = NULL;
size_t new_page_table_size = 0;
size_t malloc_request;
size_t i, more_pages;
malloc_request = round_heap_chunk_size (Bhsize_wosize (request));
gc_message ("Growing heap to %ldk\n",
(stat_heap_size + malloc_request) / 1024);
mem = aligned_malloc (malloc_request + sizeof (heap_chunk_head),
sizeof (heap_chunk_head));
if (mem == NULL){
gc_message ("No room for growing heap\n", 0);
return NULL;
}
mem += sizeof (heap_chunk_head);
(((heap_chunk_head *) mem) [-1]).size = malloc_request;
assert (Wosize_bhsize (malloc_request) >= request);
Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Blue);
/* The else if check here can never be negative since have mem >= heap_start
* so the Page calculation will be positive. Hence the (unsigned) cast is valid
*/
if (mem < heap_start) {
more_pages = -Page (mem);
} else if ((unsigned) Page(mem + malloc_request) > page_table_size) {
assert (mem >= heap_end);
more_pages = Page (mem + malloc_request) - page_table_size;
} else {
more_pages = 0;
}
if (more_pages != 0) {
new_page_table_size = page_table_size + more_pages;
new_page_table = (char *) malloc (new_page_table_size);
if (new_page_table == NULL){
gc_message ("No room for growing page table\n", 0);
free (mem);
return NULL;
}
}
if (mem < heap_start) {
assert (more_pages != 0);
for (i = 0; i < more_pages; i++){
new_page_table [i] = Not_in_heap;
}
bcopy (page_table, new_page_table + more_pages, page_table_size);
(((heap_chunk_head *) mem) [-1]).next = heap_start;
heap_start = mem;
} else {
char **last;
char *cur;
if (mem >= heap_end) heap_end = mem + malloc_request;
if (more_pages != 0) {
for (i = page_table_size; i < new_page_table_size; i++) {
new_page_table [i] = Not_in_heap;
}
bcopy (page_table, new_page_table, page_table_size);
}
last = &heap_start;
cur = *last;
while (cur != NULL && cur < mem){
last = &((((heap_chunk_head *) cur) [-1]).next);
cur = *last;
}
(((heap_chunk_head *) mem) [-1]).next = cur;
*last = mem;
}
if (more_pages != 0) {
free (page_table);
page_table = new_page_table;
page_table_size = new_page_table_size;
}
for (i = Page (mem); i < (unsigned) Page (mem + malloc_request); i++){
page_table [i] = In_heap;
}
stat_heap_size += malloc_request;
return Bp_hp (mem);
}