static void verify_pool(pool* a, sizeclass sz, struct mem_stats* s) {
value* v;
for (v = a->next_obj; v; v = (value*)v[1]) {
Assert(*v == 0);
}
value* p = (value*)((char*)a + POOL_HEADER_SZ);
value* end = (value*)a + POOL_WSIZE;
mlsize_t wh = wsize_sizeclass[sz];
s->overhead += Wsize_bsize(POOL_HEADER_SZ);
while (p + wh <= end) {
header_t hd = (header_t)*p;
Assert(hd == 0 || !Has_status_hd(hd, global.GARBAGE));
if (hd) {
s->live += Whsize_hd(hd);
s->overhead += wh - Whsize_hd(hd);
s->live_blocks++;
} else {
s->free += wh;
}
p += wh;
}
Assert(end - p == wastage_sizeclass[sz]);
s->overhead += end - p;
s->alloced += POOL_WSIZE;
}
/* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free
block and the desired size, it allocates a new block from the free
block. There are three cases:
0. The free block has the desired size. Detach the block from the
free-list and return it.
1. The free block is 1 word longer than the desired size. Detach
the block from the free list. The remaining word cannot be linked:
turn it into an empty block (header only), and return the rest.
2. The free block is big enough. Split it in two and return the right
block.
In all cases, the allocated block is right-justified in the free block:
it is located in the high-address words of the free block. This way,
the linking of the free-list does not change in case 2.
*/
static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur)
{
header_t h = Hd_bp (cur);
Assert (Whsize_hd (h) >= wh_sz);
if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */
caml_fl_cur_size -= Whsize_hd (h);
Next (prev) = Next (cur);
Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL);
if (caml_fl_merge == cur) caml_fl_merge = prev;
#ifdef DEBUG
fl_last = NULL;
#endif
/* In case 1, the following creates the empty block correctly.
In case 0, it gives an invalid header to the block. The function
calling [caml_fl_allocate] will overwrite it. */
Hd_op (cur) = Make_header (0, 0, Caml_white);
if (policy == Policy_first_fit){
if (flpi + 1 < flp_size && flp[flpi + 1] == cur){
flp[flpi + 1] = prev;
}else if (flpi == flp_size - 1){
beyond = (prev == Fl_head) ? NULL : prev;
-- flp_size;
}
}
}else{ /* Case 2. */
caml_fl_cur_size -= wh_sz;
Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue);
}
if (policy == Policy_next_fit) fl_prev = prev;
return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
}
static intnat large_alloc_sweep(struct caml_heap_state* local) {
large_alloc* a = local->unswept_large;
if (!a) return 0;
local->unswept_large = a->next;
header_t hd = *(header_t*)((char*)a + LARGE_ALLOC_HEADER_SZ);
if (Has_status_hd(hd, global.GARBAGE)) {
local->stats.large_words -=
Whsize_hd(hd) + Wsize_bsize(LARGE_ALLOC_HEADER_SZ);
local->stats.large_blocks--;
free(a);
} else {
a->next = local->swept_large;
local->swept_large = a;
}
return Whsize_hd(hd);
}
static void verify_large(large_alloc* a, struct mem_stats* s) {
for (; a; a = a->next) {
header_t hd = *(header_t*)((char*)a + LARGE_ALLOC_HEADER_SZ);
Assert (!Has_status_hd(hd, global.GARBAGE));
s->alloced += Wsize_bsize(LARGE_ALLOC_HEADER_SZ) + Whsize_hd(hd);
s->overhead += Wsize_bsize(LARGE_ALLOC_HEADER_SZ);
}
}
static intnat pool_sweep(struct caml_heap_state* local, pool** plist, sizeclass sz) {
pool* a = *plist;
if (!a) return 0;
*plist = a->next;
value* p = (value*)((char*)a + POOL_HEADER_SZ);
value* end = (value*)a + POOL_WSIZE;
mlsize_t wh = wsize_sizeclass[sz];
int all_free = 1, all_used = 1;
struct heap_stats* s = &local->stats;
while (p + wh <= end) {
header_t hd = (header_t)*p;
if (hd == 0) {
/* already on freelist */
all_used = 0;
} else if (Has_status_hd(hd, global.GARBAGE)) {
Assert(Whsize_hd(hd) <= wh);
/* add to freelist */
p[0] = 0;
p[1] = (value)a->next_obj;
Assert(Is_block((value)p));
a->next_obj = p;
all_used = 0;
/* update stats */
s->pool_live_blocks--;
s->pool_live_words -= Whsize_hd(hd);
s->pool_frag_words -= (wh - Whsize_hd(hd));
} else {
/* still live */
all_free = 0;
}
p += wh;
}
if (all_free) {
pool_release(local, a, sz);
} else {
pool** list = all_used ? &local->full_pools[sz] : &local->avail_pools[sz];
a->next = *list;
*list = a;
}
return POOL_WSIZE;
}
static intnat mark(value initial, intnat budget) {
value next = initial;
int found_next = 1;
while (budget > 0 && found_next) {
value v = next;
header_t hd_v;
found_next = 0;
Assert(Is_markable(v));
Assert(v == mark_normalise(v));
stat_blocks_marked++;
/* mark the current object */
hd_v = Hd_val(v);
// caml_gc_log ("mark: v=0x%lx hd=0x%lx tag=%d sz=%lu",
// v, hd_v, Tag_val(v), Wosize_val(v));
if (Tag_hd (hd_v) == Stack_tag) {
// caml_gc_log ("mark: stack=%p", (value*)v);
caml_scan_stack(&caml_darken, v);
} else if (Tag_hd (hd_v) < No_scan_tag) {
int i;
for (i = 0; i < Wosize_hd(hd_v); i++) {
value child = Op_val(v)[i];
// caml_gc_log ("mark: v=%p i=%u child=%p",(value*)v,i,(value*)child);
/* FIXME: this is wrong, as Debug_tag(N) is a valid value.
However, it's a useful debugging aid for now */
Assert(!Is_debug_tag(child));
if (Is_markable(child)) {
child = mark_normalise(child);
if (caml_mark_object(child)) {
if (!found_next) {
next = child;
found_next = 1;
} else {
mark_stack_push(child);
}
}
}
}
}
budget -= Whsize_hd(hd_v);
/* if we haven't found any markable children, pop an object to mark */
if (!found_next) {
found_next = mark_stack_pop(&next);
}
}
if (found_next) {
mark_stack_push(next);
}
return budget;
}
/* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free
block and the desired size, it allocates a new block from the free
block. There are three cases:
0. The free block has the desired size. Detach the block from the
free-list and return it.
1. The free block is 1 word longer than the desired size. Detach
the block from the free list. The remaining word cannot be linked:
turn it into an empty block (header only), and return the rest.
2. The free block is big enough. Split it in two and return the right
block.
In all cases, the allocated block is right-justified in the free block:
it is located in the high-address words of the free block. This way,
the linking of the free-list does not change in case 2.
*/
static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur)
{
header_t h = Hd_bp (cur);
Assert (Whsize_hd (h) >= wh_sz);
if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */
caml_fl_cur_size -= Whsize_hd (h);
Next (prev) = Next (cur);
Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL);
if (caml_fl_merge == cur) caml_fl_merge = prev;
#ifdef DEBUG
fl_last = NULL;
#endif
/* In case 1, the following creates the empty block correctly.
In case 0, it gives an invalid header to the block. The function
calling [caml_fl_allocate] will overwrite it. */
Hd_op (cur) = Make_header (0, 0, Caml_white);
}else{ /* Case 2. */
caml_fl_cur_size -= wh_sz;
Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue);
}
fl_prev = prev;
return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
}
static intnat mark(value initial, intnat budget) {
value next = initial;
int found_next = 1;
while (budget > 0 && found_next) {
value v = next;
header_t hd_v;
found_next = 0;
Assert(Is_markable(v));
Assert(v == mark_normalise(v));
stat_blocks_marked++;
/* mark the current object */
hd_v = Hd_val(v);
if (Tag_hd (hd_v) == Stack_tag) {
caml_scan_stack(&caml_darken, v);
} else if (Tag_hd (hd_v) < No_scan_tag) {
int i;
for (i = 0; i < Wosize_hd(hd_v); i++) {
value child = Field(v, i);
if (Is_markable(child)) {
child = mark_normalise(child);
if (caml_mark_object(child)) {
if (!found_next) {
next = child;
found_next = 1;
} else {
mark_stack_push(child);
}
}
}
}
}
budget -= Whsize_hd(hd_v);
/* if we haven't found any markable children, pop an object to mark */
if (!found_next) {
found_next = mark_stack_pop(&next);
}
}
if (found_next) {
mark_stack_push(next);
}
return budget;
}
/* [caml_fl_merge_block] returns the head pointer of the next block after [bp],
because merging blocks may change the size of [bp]. */
char *caml_fl_merge_block (char *bp)
{
char *prev, *cur, *adj;
header_t hd = Hd_bp (bp);
mlsize_t prev_wosz;
caml_fl_cur_size += Whsize_hd (hd);
#ifdef DEBUG
caml_set_fields (bp, 0, Debug_free_major);
#endif
prev = caml_fl_merge;
cur = Next (prev);
/* The sweep code makes sure that this is the right place to insert
this block: */
Assert (prev < bp || prev == Fl_head);
Assert (cur > bp || cur == NULL);
if (policy == Policy_first_fit) truncate_flp (prev);
/* If [last_fragment] and [bp] are adjacent, merge them. */
if (last_fragment == Hp_bp (bp)){
mlsize_t bp_whsz = Whsize_bp (bp);
if (bp_whsz <= Max_wosize){
hd = Make_header (bp_whsz, 0, Caml_white);
bp = last_fragment;
Hd_bp (bp) = hd;
caml_fl_cur_size += Whsize_wosize (0);
}
}
/* If [bp] and [cur] are adjacent, remove [cur] from the free-list
and merge them. */
adj = bp + Bosize_hd (hd);
if (adj == Hp_bp (cur)){
char *next_cur = Next (cur);
mlsize_t cur_whsz = Whsize_bp (cur);
if (Wosize_hd (hd) + cur_whsz <= Max_wosize){
Next (prev) = next_cur;
if (policy == Policy_next_fit && fl_prev == cur) fl_prev = prev;
hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue);
Hd_bp (bp) = hd;
adj = bp + Bosize_hd (hd);
#ifdef DEBUG
fl_last = NULL;
Next (cur) = (char *) Debug_free_major;
Hd_bp (cur) = Debug_free_major;
#endif
cur = next_cur;
}
}
/* If [prev] and [bp] are adjacent merge them, else insert [bp] into
the free-list if it is big enough. */
prev_wosz = Wosize_bp (prev);
if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp)
&& prev_wosz + Whsize_hd (hd) < Max_wosize){
Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue);
#ifdef DEBUG
Hd_bp (bp) = Debug_free_major;
#endif
Assert (caml_fl_merge == prev);
}else if (Wosize_hd (hd) != 0){
Hd_bp (bp) = Bluehd_hd (hd);
Next (bp) = cur;
Next (prev) = bp;
caml_fl_merge = bp;
}else{
/* This is a fragment. Leave it in white but remember it for eventual
merging with the next block. */
last_fragment = bp;
caml_fl_cur_size -= Whsize_wosize (0);
}
return adj;
}
/* 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;
}
