Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
ocaml/byterun/major_gc.c

557 lines
18 KiB
C
Raw Blame History

/***********************************************************************/
/* */
/* OCaml */
/* */
/* Damien Doligez, projet Para, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
#include <limits.h>
#include "caml/compact.h"
#include "caml/custom.h"
#include "caml/config.h"
#include "caml/fail.h"
#include "caml/finalise.h"
#include "caml/freelist.h"
#include "caml/gc.h"
#include "caml/gc_ctrl.h"
#include "caml/major_gc.h"
#include "caml/misc.h"
#include "caml/mlvalues.h"
#include "caml/roots.h"
#include "caml/weak.h"
#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
#define NATIVE_CODE_AND_NO_NAKED_POINTERS
#else
#undef NATIVE_CODE_AND_NO_NAKED_POINTERS
#endif
uintnat caml_percent_free;
uintnat caml_major_heap_increment;
CAMLexport char *caml_heap_start;
char *caml_gc_sweep_hp;
int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */
static value *gray_vals;
static value *gray_vals_cur, *gray_vals_end;
static asize_t gray_vals_size;
static int heap_is_pure; /* The heap is pure if the only gray objects
below [markhp] are also in [gray_vals]. */
uintnat caml_allocated_words;
uintnat caml_dependent_size, caml_dependent_allocated;
double caml_extra_heap_resources;
uintnat caml_fl_wsz_at_phase_change = 0;
extern char *caml_fl_merge; /* Defined in freelist.c. */
static char *markhp, *chunk, *limit;
int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */
static value *weak_prev;
#ifdef DEBUG
static unsigned long major_gc_counter = 0;
#endif
static void realloc_gray_vals (void)
{
value *new;
Assert (gray_vals_cur == gray_vals_end);
if (gray_vals_size < caml_stat_heap_wsz / 32){
caml_gc_message (0x08, "Growing gray_vals to %"
ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
(intnat) gray_vals_size * sizeof (value) / 512);
new = (value *) realloc ((char *) gray_vals,
2 * gray_vals_size * sizeof (value));
if (new == NULL){
caml_gc_message (0x08, "No room for growing gray_vals\n", 0);
gray_vals_cur = gray_vals;
heap_is_pure = 0;
}else{
gray_vals = new;
gray_vals_cur = gray_vals + gray_vals_size;
gray_vals_size *= 2;
gray_vals_end = gray_vals + gray_vals_size;
}
}else{
gray_vals_cur = gray_vals + gray_vals_size / 2;
heap_is_pure = 0;
}
}
void caml_darken (value v, value *p /* not used */)
{
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
if (Is_block (v) && Wosize_val (v) > 0) {
/* We insist that naked pointers to outside the heap point to things that
look like values with headers coloured black. This isn't always
strictly necessary but is essential in certain cases---in particular
when the value is allocated in a read-only section. (For the values
where it would be safe it is a performance improvement since we avoid
putting them on the grey list.) */
CAMLassert (Is_in_heap (v) || Is_black_hd (Hd_val (v)));
#else
if (Is_block (v) && Is_in_heap (v)) {
#endif
header_t h = Hd_val (v);
tag_t t = Tag_hd (h);
if (t == Infix_tag){
v -= Infix_offset_val(v);
h = Hd_val (v);
t = Tag_hd (h);
}
CAMLassert (!Is_blue_hd (h));
if (Is_white_hd (h)){
if (t < No_scan_tag){
Hd_val (v) = Grayhd_hd (h);
*gray_vals_cur++ = v;
if (gray_vals_cur >= gray_vals_end) realloc_gray_vals ();
}else{
Hd_val (v) = Blackhd_hd (h);
}
}
}
}
static void start_cycle (void)
{
Assert (caml_gc_phase == Phase_idle);
Assert (gray_vals_cur == gray_vals);
caml_gc_message (0x01, "Starting new major GC cycle\n", 0);
caml_darken_all_roots();
caml_gc_phase = Phase_mark;
caml_gc_subphase = Subphase_main;
markhp = NULL;
#ifdef DEBUG
++ major_gc_counter;
caml_heap_check ();
#endif
}
static void mark_slice (intnat work)
{
value *gray_vals_ptr; /* Local copy of gray_vals_cur */
value v, child;
header_t hd;
mlsize_t size, i;
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
int marking_closure = 0;
#endif
caml_gc_message (0x40, "Marking %ld words\n", work);
caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
gray_vals_ptr = gray_vals_cur;
while (work > 0){
if (gray_vals_ptr > gray_vals){
v = *--gray_vals_ptr;
hd = Hd_val(v);
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
marking_closure =
(Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag);
#endif
Assert (Is_gray_hd (hd));
Hd_val (v) = Blackhd_hd (hd);
size = Wosize_hd (hd);
if (Tag_hd (hd) < No_scan_tag){
for (i = 0; i < size; i++){
child = Field (v, i);
#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS
if (Is_block (child)
&& Wosize_val (child) > 0 /* Atoms never need to be marked. */
/* Closure blocks contain code pointers at offsets that cannot
be reliably determined, so we always use the page table when
marking such values. */
&& (!marking_closure || Is_in_heap (child))) {
/* See [caml_darken] for a description of this assertion. */
CAMLassert (Is_in_heap (child) || Is_black_hd (Hd_val (child)));
#else
if (Is_block (child) && Is_in_heap (child)) {
#endif
hd = Hd_val (child);
if (Tag_hd (hd) == Forward_tag){
value f = Forward_val (child);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
Field (v, i) = f;
}
}
else if (Tag_hd(hd) == Infix_tag) {
child -= Infix_offset_val(child);
hd = Hd_val(child);
}
if (Is_white_hd (hd)){
Hd_val (child) = Grayhd_hd (hd);
*gray_vals_ptr++ = child;
if (gray_vals_ptr >= gray_vals_end) {
gray_vals_cur = gray_vals_ptr;
realloc_gray_vals ();
gray_vals_ptr = gray_vals_cur;
}
}
}
}
}
work -= Whsize_wosize(size);
}else if (markhp != NULL){
if (markhp == limit){
chunk = Chunk_next (chunk);
if (chunk == NULL){
markhp = NULL;
}else{
markhp = chunk;
limit = chunk + Chunk_size (chunk);
}
}else{
if (Is_gray_val (Val_hp (markhp))){
Assert (gray_vals_ptr == gray_vals);
*gray_vals_ptr++ = Val_hp (markhp);
}
markhp += Bhsize_hp (markhp);
}
}else if (!heap_is_pure){
heap_is_pure = 1;
chunk = caml_heap_start;
markhp = chunk;
limit = chunk + Chunk_size (chunk);
}else{
switch (caml_gc_subphase){
case Subphase_main: {
/* The main marking phase is over. Start removing weak pointers to
dead values. */
caml_gc_subphase = Subphase_weak1;
weak_prev = &caml_weak_list_head;
}
break;
case Subphase_weak1: {
value cur, curfield;
mlsize_t sz, i;
header_t hd;
cur = *weak_prev;
if (cur != (value) NULL){
hd = Hd_val (cur);
sz = Wosize_hd (hd);
for (i = 1; i < sz; i++){
curfield = Field (cur, i);
weak_again:
if (curfield != caml_weak_none
&& Is_block (curfield) && Is_in_heap (curfield)){
if (Tag_val (curfield) == Forward_tag){
value f = Forward_val (curfield);
if (Is_block (f)) {
if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){
/* Do not short-circuit the pointer. */
}else{
Field (cur, i) = curfield = f;
goto weak_again;
}
}
}
if (Is_white_val (curfield)){
Field (cur, i) = caml_weak_none;
}
}
}
weak_prev = &Field (cur, 0);
work -= Whsize_hd (hd);
}else{
/* Subphase_weak1 is done.
Handle finalised values and start removing dead weak arrays. */
gray_vals_cur = gray_vals_ptr;
caml_final_update ();
gray_vals_ptr = gray_vals_cur;
caml_gc_subphase = Subphase_weak2;
weak_prev = &caml_weak_list_head;
}
}
break;
case Subphase_weak2: {
value cur;
header_t hd;
cur = *weak_prev;
if (cur != (value) NULL){
hd = Hd_val (cur);
if (Color_hd (hd) == Caml_white){
/* The whole array is dead, remove it from the list. */
*weak_prev = Field (cur, 0);
}else{
weak_prev = &Field (cur, 0);
}
work -= 1;
}else{
/* Subphase_weak2 is done. Go to Subphase_final. */
caml_gc_subphase = Subphase_final;
}
}
break;
case Subphase_final: {
/* Initialise the sweep phase. */
gray_vals_cur = gray_vals_ptr;
caml_gc_sweep_hp = caml_heap_start;
caml_fl_init_merge ();
caml_gc_phase = Phase_sweep;
chunk = caml_heap_start;
caml_gc_sweep_hp = chunk;
limit = chunk + Chunk_size (chunk);
work = 0;
caml_fl_wsz_at_phase_change = caml_fl_cur_wsz;
}
break;
default: Assert (0);
}
}
}
gray_vals_cur = gray_vals_ptr;
}
static void sweep_slice (intnat work)
{
char *hp;
header_t hd;
caml_gc_message (0x40, "Sweeping %ld words\n", work);
while (work > 0){
if (caml_gc_sweep_hp < limit){
hp = caml_gc_sweep_hp;
hd = Hd_hp (hp);
work -= Whsize_hd (hd);
caml_gc_sweep_hp += Bhsize_hd (hd);
switch (Color_hd (hd)){
case Caml_white:
if (Tag_hd (hd) == Custom_tag){
void (*final_fun)(value) = Custom_ops_val(Val_hp(hp))->finalize;
if (final_fun != NULL) final_fun(Val_hp(hp));
}
caml_gc_sweep_hp = (char *) caml_fl_merge_block (Val_hp (hp));
break;
case Caml_blue:
/* Only the blocks of the free-list are blue. See [freelist.c]. */
caml_fl_merge = Bp_hp (hp);
break;
default: /* gray or black */
Assert (Color_hd (hd) == Caml_black);
Hd_hp (hp) = Whitehd_hd (hd);
break;
}
Assert (caml_gc_sweep_hp <= limit);
}else{
chunk = Chunk_next (chunk);
if (chunk == NULL){
/* Sweeping is done. */
++ caml_stat_major_collections;
work = 0;
caml_gc_phase = Phase_idle;
}else{
caml_gc_sweep_hp = chunk;
limit = chunk + Chunk_size (chunk);
}
}
}
}
/* The main entry point for the GC. Called after each minor GC.
[howmuch] is the amount of work to do, 0 to let the GC compute it.
Return the computed amount of work to do.
*/
intnat caml_major_collection_slice (intnat howmuch)
{
double p, dp;
intnat computed_work;
/*
Free memory at the start of the GC cycle (garbage + free list) (assumed):
FM = caml_stat_heap_wsz * caml_percent_free
/ (100 + caml_percent_free)
Assuming steady state and enforcing a constant allocation rate, then
FM is divided in 2/3 for garbage and 1/3 for free list.
G = 2 * FM / 3
G is also the amount of memory that will be used during this cycle
(still assuming steady state).
Proportion of G consumed since the previous slice:
PH = caml_allocated_words / G
= caml_allocated_words * 3 * (100 + caml_percent_free)
/ (2 * caml_stat_heap_wsz * caml_percent_free)
Proportion of extra-heap resources consumed since the previous slice:
PE = caml_extra_heap_resources
Proportion of total work to do in this slice:
P = max (PH, PE)
Amount of marking work for the GC cycle:
MW = caml_stat_heap_wsz * 100 / (100 + caml_percent_free)
Amount of sweeping work for the GC cycle:
SW = caml_stat_heap_wsz
In order to finish marking with a non-empty free list, we will
use 40% of the time for marking, and 60% for sweeping.
If TW is the total work for this cycle,
MW = 40/100 * TW
SW = 60/100 * TW
Amount of work to do for this slice:
W = P * TW
Amount of marking work for a marking slice:
MS = P * MW / (40/100)
MS = P * caml_stat_heap_wsz * 250 / (100 + caml_percent_free)
Amount of sweeping work for a sweeping slice:
SS = P * SW / (60/100)
SS = P * caml_stat_heap_wsz * 5 / 3
This slice will either mark MS words or sweep SS words.
*/
if (caml_gc_phase == Phase_idle) start_cycle ();
p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free)
/ caml_stat_heap_wsz / caml_percent_free / 2.0;
if (caml_dependent_size > 0){
dp = (double) caml_dependent_allocated * (100 + caml_percent_free)
/ caml_dependent_size / caml_percent_free;
}else{
dp = 0.0;
}
if (p < dp) p = dp;
if (p < caml_extra_heap_resources) p = caml_extra_heap_resources;
caml_gc_message (0x40, "allocated_words = %"
ARCH_INTNAT_PRINTF_FORMAT "u\n",
caml_allocated_words);
caml_gc_message (0x40, "extra_heap_resources = %"
ARCH_INTNAT_PRINTF_FORMAT "uu\n",
(uintnat) (caml_extra_heap_resources * 1000000));
caml_gc_message (0x40, "amount of work to do = %"
ARCH_INTNAT_PRINTF_FORMAT "uu\n",
(uintnat) (p * 1000000));
if (caml_gc_phase == Phase_mark){
computed_work = (intnat) (p * caml_stat_heap_wsz * 250
/ (100 + caml_percent_free));
}else{
computed_work = (intnat) (p * caml_stat_heap_wsz * 5 / 3);
}
caml_gc_message (0x40, "ordered work = %ld words\n", howmuch);
caml_gc_message (0x40, "computed work = %ld words\n", computed_work);
if (howmuch == 0) howmuch = computed_work;
if (caml_gc_phase == Phase_mark){
mark_slice (howmuch);
caml_gc_message (0x02, "!", 0);
}else{
Assert (caml_gc_phase == Phase_sweep);
sweep_slice (howmuch);
caml_gc_message (0x02, "$", 0);
}
if (caml_gc_phase == Phase_idle) caml_compact_heap_maybe ();
caml_stat_major_words += caml_allocated_words;
caml_allocated_words = 0;
caml_dependent_allocated = 0;
caml_extra_heap_resources = 0.0;
return computed_work;
}
/* The minor heap must be empty when this function is called;
the minor heap is empty when this function returns.
*/
/* This does not call caml_compact_heap_maybe because the estimations of
free and live memory are only valid for a cycle done incrementally.
Besides, this function is called by caml_compact_heap_maybe.
*/
void caml_finish_major_cycle (void)
{
if (caml_gc_phase == Phase_idle) start_cycle ();
while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX);
Assert (caml_gc_phase == Phase_sweep);
while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX);
Assert (caml_gc_phase == Phase_idle);
caml_stat_major_words += caml_allocated_words;
caml_allocated_words = 0;
}
/* Make sure the request is at least Heap_chunk_min and round it up
to a multiple of the page size.
The argument and result are both numbers of words.
*/
static asize_t clip_heap_chunk_size (asize_t request)
{
if (request < Heap_chunk_min){
request = Heap_chunk_min;
}
return
Wsize_bsize (((Bsize_wsize (request) + Page_size - 1) >> Page_log) << Page_log);
}
/* Compute the heap increment, make sure the request is at least that big,
then call clip_heap_chunk_size, then make sure the result is >= request.
The argument and result are both numbers of words.
*/
asize_t caml_round_heap_chunk_wsz (asize_t request)
{
asize_t result = request;
uintnat incr;
/* Compute the heap increment as a word size. */
if (caml_major_heap_increment > 1000){
incr = caml_major_heap_increment;
}else{
incr = caml_stat_heap_wsz / 100 * caml_major_heap_increment;
}
if (result < incr){
result = incr;
}
result = clip_heap_chunk_size (result);
if (result < request){
caml_raise_out_of_memory ();
return 0; /* not reached */
}
return result;
}
/* [heap_size] is a number of bytes */
void caml_init_major_heap (asize_t heap_size)
{
caml_stat_heap_wsz = Wsize_bsize (clip_heap_chunk_size (heap_size));
caml_stat_top_heap_wsz = caml_stat_heap_wsz;
Assert (Bsize_wsize (caml_stat_heap_wsz) % Page_size == 0);
caml_heap_start = (char *) caml_alloc_for_heap (Bsize_wsize (caml_stat_heap_wsz));
if (caml_heap_start == NULL)
caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n");
Chunk_next (caml_heap_start) = NULL;
caml_stat_heap_chunks = 1;
if (caml_page_table_add(In_heap, caml_heap_start,
caml_heap_start + Bsize_wsize (caml_stat_heap_wsz)) != 0) {
caml_fatal_error ("Fatal error: not enough memory "
"for the initial page table.\n");
}
caml_fl_init_merge ();
caml_make_free_blocks ((value *) caml_heap_start,
caml_stat_heap_wsz, 1, Caml_white);
caml_gc_phase = Phase_idle;
gray_vals_size = 2048;
gray_vals = (value *) malloc (gray_vals_size * sizeof (value));
if (gray_vals == NULL)
caml_fatal_error ("Fatal error: not enough memory for the gray cache.\n");
gray_vals_cur = gray_vals;
gray_vals_end = gray_vals + gray_vals_size;
heap_is_pure = 1;
caml_allocated_words = 0;
caml_extra_heap_resources = 0.0;
}
Reference in New Issue View Git Blame Copy Permalink