/* 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); } }
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; }