diff options
Diffstat (limited to 'byterun/minor_gc.c')
-rw-r--r-- | byterun/minor_gc.c | 558 |
1 files changed, 0 insertions, 558 deletions
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c deleted file mode 100644 index fce3ae06a5..0000000000 --- a/byterun/minor_gc.c +++ /dev/null @@ -1,558 +0,0 @@ -/**************************************************************************/ -/* */ -/* 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 Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -#define CAML_INTERNALS - -#include <string.h> -#include "caml/custom.h" -#include "caml/config.h" -#include "caml/fail.h" -#include "caml/finalise.h" -#include "caml/gc.h" -#include "caml/gc_ctrl.h" -#include "caml/major_gc.h" -#include "caml/memory.h" -#include "caml/minor_gc.h" -#include "caml/misc.h" -#include "caml/mlvalues.h" -#include "caml/roots.h" -#include "caml/signals.h" -#include "caml/weak.h" - -/* Pointers into the minor heap. - [caml_young_base] - The [malloc] block that contains the heap. - [caml_young_start] ... [caml_young_end] - The whole range of the minor heap: all young blocks are inside - this interval. - [caml_young_alloc_start]...[caml_young_alloc_end] - The allocation arena: newly-allocated blocks are carved from - this interval, starting at [caml_young_alloc_end]. - [caml_young_alloc_mid] is the mid-point of this interval. - [caml_young_ptr], [caml_young_trigger], [caml_young_limit] - These pointers are all inside the allocation arena. - - [caml_young_ptr] is where the next allocation will take place. - - [caml_young_trigger] is how far we can allocate before triggering - [caml_gc_dispatch]. Currently, it is either [caml_young_alloc_start] - or the mid-point of the allocation arena. - - [caml_young_limit] is the pointer that is compared to - [caml_young_ptr] for allocation. It is either - [caml_young_alloc_end] if a signal is pending and we are in - native code, or [caml_young_trigger]. -*/ - -struct generic_table CAML_TABLE_STRUCT(char); - -asize_t caml_minor_heap_wsz; -static void *caml_young_base = NULL; -CAMLexport value *caml_young_start = NULL, *caml_young_end = NULL; -CAMLexport value *caml_young_alloc_start = NULL, - *caml_young_alloc_mid = NULL, - *caml_young_alloc_end = NULL; -CAMLexport value *caml_young_ptr = NULL, *caml_young_limit = NULL; -CAMLexport value *caml_young_trigger = NULL; - -CAMLexport struct caml_ref_table - caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; - -CAMLexport struct caml_ephe_ref_table - caml_ephe_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; - -CAMLexport struct caml_custom_table - caml_custom_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; -/* Table of custom blocks in the minor heap that contain finalizers - or GC speed parameters. */ - -int caml_in_minor_collection = 0; - -double caml_extra_heap_resources_minor = 0; - -/* [sz] and [rsv] are numbers of entries */ -static void alloc_generic_table (struct generic_table *tbl, asize_t sz, - asize_t rsv, asize_t element_size) -{ - void *new_table; - - tbl->size = sz; - tbl->reserve = rsv; - new_table = (void *) caml_stat_alloc_noexc((tbl->size + tbl->reserve) * - element_size); - if (new_table == NULL) caml_fatal_error ("not enough memory"); - if (tbl->base != NULL) caml_stat_free (tbl->base); - tbl->base = new_table; - tbl->ptr = tbl->base; - tbl->threshold = tbl->base + tbl->size * element_size; - tbl->limit = tbl->threshold; - tbl->end = tbl->base + (tbl->size + tbl->reserve) * element_size; -} - -void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) -{ - alloc_generic_table ((struct generic_table *) tbl, sz, rsv, sizeof (value *)); -} - -void caml_alloc_ephe_table (struct caml_ephe_ref_table *tbl, asize_t sz, - asize_t rsv) -{ - alloc_generic_table ((struct generic_table *) tbl, sz, rsv, - sizeof (struct caml_ephe_ref_elt)); -} - -void caml_alloc_custom_table (struct caml_custom_table *tbl, asize_t sz, - asize_t rsv) -{ - alloc_generic_table ((struct generic_table *) tbl, sz, rsv, - sizeof (struct caml_custom_elt)); -} - -static void reset_table (struct generic_table *tbl) -{ - tbl->size = 0; - tbl->reserve = 0; - if (tbl->base != NULL) caml_stat_free (tbl->base); - tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL; -} - -static void clear_table (struct generic_table *tbl) -{ - tbl->ptr = tbl->base; - tbl->limit = tbl->threshold; -} - -void caml_set_minor_heap_size (asize_t bsz) -{ - char *new_heap; - void *new_heap_base; - - CAMLassert (bsz >= Bsize_wsize(Minor_heap_min)); - CAMLassert (bsz <= Bsize_wsize(Minor_heap_max)); - CAMLassert (bsz % sizeof (value) == 0); - if (caml_young_ptr != caml_young_alloc_end){ - CAML_INSTR_INT ("force_minor/set_minor_heap_size@", 1); - caml_requested_minor_gc = 0; - caml_young_trigger = caml_young_alloc_mid; - caml_young_limit = caml_young_trigger; - caml_empty_minor_heap (); - } - CAMLassert (caml_young_ptr == caml_young_alloc_end); - new_heap = caml_stat_alloc_aligned_noexc(bsz, 0, &new_heap_base); - if (new_heap == NULL) caml_raise_out_of_memory(); - if (caml_page_table_add(In_young, new_heap, new_heap + bsz) != 0) - caml_raise_out_of_memory(); - - if (caml_young_start != NULL){ - caml_page_table_remove(In_young, caml_young_start, caml_young_end); - caml_stat_free (caml_young_base); - } - caml_young_base = new_heap_base; - caml_young_start = (value *) new_heap; - caml_young_end = (value *) (new_heap + bsz); - caml_young_alloc_start = caml_young_start; - caml_young_alloc_mid = caml_young_alloc_start + Wsize_bsize (bsz) / 2; - caml_young_alloc_end = caml_young_end; - caml_young_trigger = caml_young_alloc_start; - caml_young_limit = caml_young_trigger; - caml_young_ptr = caml_young_alloc_end; - caml_minor_heap_wsz = Wsize_bsize (bsz); - - reset_table ((struct generic_table *) &caml_ref_table); - reset_table ((struct generic_table *) &caml_ephe_ref_table); - reset_table ((struct generic_table *) &caml_custom_table); -} - -static value oldify_todo_list = 0; - -/* Note that the tests on the tag depend on the fact that Infix_tag, - Forward_tag, and No_scan_tag are contiguous. */ - -void caml_oldify_one (value v, value *p) -{ - value result; - header_t hd; - mlsize_t sz, i; - tag_t tag; - - tail_call: - if (Is_block (v) && Is_young (v)){ - CAMLassert ((value *) Hp_val (v) >= caml_young_ptr); - hd = Hd_val (v); - if (hd == 0){ /* If already forwarded */ - *p = Field (v, 0); /* then forward pointer is first field. */ - }else{ - tag = Tag_hd (hd); - if (tag < Infix_tag){ - value field0; - - sz = Wosize_hd (hd); - result = caml_alloc_shr_preserving_profinfo (sz, tag, hd); - *p = result; - field0 = Field (v, 0); - Hd_val (v) = 0; /* Set forward flag */ - Field (v, 0) = result; /* and forward pointer. */ - if (sz > 1){ - Field (result, 0) = field0; - Field (result, 1) = oldify_todo_list; /* Add this block */ - oldify_todo_list = v; /* to the "to do" list. */ - }else{ - CAMLassert (sz == 1); - p = &Field (result, 0); - v = field0; - goto tail_call; - } - }else if (tag >= No_scan_tag){ - sz = Wosize_hd (hd); - result = caml_alloc_shr_preserving_profinfo (sz, tag, hd); - for (i = 0; i < sz; i++) Field (result, i) = Field (v, i); - Hd_val (v) = 0; /* Set forward flag */ - Field (v, 0) = result; /* and forward pointer. */ - *p = result; - }else if (tag == Infix_tag){ - mlsize_t offset = Infix_offset_hd (hd); - caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */ - *p += offset; - }else{ - value f = Forward_val (v); - tag_t ft = 0; - int vv = 1; - - CAMLassert (tag == Forward_tag); - if (Is_block (f)){ - if (Is_young (f)){ - vv = 1; - ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); - }else{ - vv = Is_in_value_area(f); - if (vv){ - ft = Tag_val (f); - } - } - } - if (!vv || ft == Forward_tag || ft == Lazy_tag -#ifdef FLAT_FLOAT_ARRAY - || ft == Double_tag -#endif - ){ - /* Do not short-circuit the pointer. Copy as a normal block. */ - CAMLassert (Wosize_hd (hd) == 1); - result = caml_alloc_shr_preserving_profinfo (1, Forward_tag, hd); - *p = result; - Hd_val (v) = 0; /* Set (GC) forward flag */ - Field (v, 0) = result; /* and forward pointer. */ - p = &Field (result, 0); - v = f; - goto tail_call; - }else{ - v = f; /* Follow the forwarding */ - goto tail_call; /* then oldify. */ - } - } - } - }else{ - *p = v; - } -} - -/* Test if the ephemeron is alive, everything outside minor heap is alive */ -static inline int ephe_check_alive_data(struct caml_ephe_ref_elt *re){ - mlsize_t i; - value child; - for (i = CAML_EPHE_FIRST_KEY; i < Wosize_val(re->ephe); i++){ - child = Field (re->ephe, i); - if(child != caml_ephe_none - && Is_block (child) && Is_young (child) - && Hd_val (child) != 0){ /* Value not copied to major heap */ - return 0; - } - } - return 1; -} - -/* Finish the work that was put off by [caml_oldify_one]. - Note that [caml_oldify_one] itself is called by oldify_mopup, so we - have to be careful to remove the first entry from the list before - oldifying its fields. */ -void caml_oldify_mopup (void) -{ - value v, new_v, f; - mlsize_t i; - struct caml_ephe_ref_elt *re; - int redo = 0; - - while (oldify_todo_list != 0){ - v = oldify_todo_list; /* Get the head. */ - CAMLassert (Hd_val (v) == 0); /* It must be forwarded. */ - new_v = Field (v, 0); /* Follow forward pointer. */ - oldify_todo_list = Field (new_v, 1); /* Remove from list. */ - - f = Field (new_v, 0); - if (Is_block (f) && Is_young (f)){ - caml_oldify_one (f, &Field (new_v, 0)); - } - for (i = 1; i < Wosize_val (new_v); i++){ - f = Field (v, i); - if (Is_block (f) && Is_young (f)){ - caml_oldify_one (f, &Field (new_v, i)); - }else{ - Field (new_v, i) = f; - } - } - } - - /* Oldify the data in the minor heap of alive ephemeron - During minor collection keys outside the minor heap are considered alive */ - for (re = caml_ephe_ref_table.base; - re < caml_ephe_ref_table.ptr; re++){ - /* look only at ephemeron with data in the minor heap */ - if (re->offset == 1){ - value *data = &Field(re->ephe,1); - if (*data != caml_ephe_none && Is_block (*data) && Is_young (*data)){ - if (Hd_val (*data) == 0){ /* Value copied to major heap */ - *data = Field (*data, 0); - } else { - if (ephe_check_alive_data(re)){ - caml_oldify_one(*data,data); - redo = 1; /* oldify_todo_list can still be 0 */ - } - } - } - } - } - - if (redo) caml_oldify_mopup (); -} - -/* Make sure the minor heap is empty by performing a minor collection - if needed. -*/ -void caml_empty_minor_heap (void) -{ - value **r; - struct caml_custom_elt *elt; - uintnat prev_alloc_words; - struct caml_ephe_ref_elt *re; - - if (caml_young_ptr != caml_young_alloc_end){ - if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) (); - CAML_INSTR_SETUP (tmr, "minor"); - prev_alloc_words = caml_allocated_words; - caml_in_minor_collection = 1; - caml_gc_message (0x02, "<"); - caml_oldify_local_roots(); - CAML_INSTR_TIME (tmr, "minor/local_roots"); - for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){ - caml_oldify_one (**r, *r); - } - CAML_INSTR_TIME (tmr, "minor/ref_table"); - caml_oldify_mopup (); - CAML_INSTR_TIME (tmr, "minor/copy"); - /* Update the ephemerons */ - for (re = caml_ephe_ref_table.base; - re < caml_ephe_ref_table.ptr; re++){ - if(re->offset < Wosize_val(re->ephe)){ - /* If it is not the case, the ephemeron has been truncated */ - value *key = &Field(re->ephe,re->offset); - if (*key != caml_ephe_none && Is_block (*key) && Is_young (*key)){ - if (Hd_val (*key) == 0){ /* Value copied to major heap */ - *key = Field (*key, 0); - }else{ /* Value not copied so it's dead */ - CAMLassert(!ephe_check_alive_data(re)); - *key = caml_ephe_none; - Field(re->ephe,1) = caml_ephe_none; - } - } - } - } - /* Update the OCaml finalise_last values */ - caml_final_update_minor_roots(); - /* Run custom block finalisation of dead minor values */ - for (elt = caml_custom_table.base; elt < caml_custom_table.ptr; elt++){ - value v = elt->block; - if (Hd_val (v) == 0){ - /* Block was copied to the major heap: adjust GC speed numbers. */ - caml_adjust_gc_speed(elt->mem, elt->max); - }else{ - /* Block will be freed: call finalization function, if any. */ - void (*final_fun)(value) = Custom_ops_val(v)->finalize; - if (final_fun != NULL) final_fun(v); - } - } - CAML_INSTR_TIME (tmr, "minor/update_weak"); - caml_stat_minor_words += caml_young_alloc_end - caml_young_ptr; - caml_gc_clock += (double) (caml_young_alloc_end - caml_young_ptr) - / caml_minor_heap_wsz; - caml_young_ptr = caml_young_alloc_end; - clear_table ((struct generic_table *) &caml_ref_table); - clear_table ((struct generic_table *) &caml_ephe_ref_table); - clear_table ((struct generic_table *) &caml_custom_table); - caml_extra_heap_resources_minor = 0; - caml_gc_message (0x02, ">"); - caml_in_minor_collection = 0; - caml_final_empty_young (); - CAML_INSTR_TIME (tmr, "minor/finalized"); - caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; - CAML_INSTR_INT ("minor/promoted#", caml_allocated_words - prev_alloc_words); - ++ caml_stat_minor_collections; - if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) (); - }else{ - /* The minor heap is empty nothing to do. */ - caml_final_empty_young (); - } -#ifdef DEBUG - { - value *p; - for (p = caml_young_alloc_start; p < caml_young_alloc_end; ++p){ - *p = Debug_free_minor; - } - } -#endif -} - -#ifdef CAML_INSTR -extern uintnat caml_instr_alloc_jump; -#endif - -/* Do a minor collection or a slice of major collection, call finalisation - functions, etc. - Leave enough room in the minor heap to allocate at least one object. -*/ -CAMLexport void caml_gc_dispatch (void) -{ - value *trigger = caml_young_trigger; /* save old value of trigger */ -#ifdef CAML_INSTR - CAML_INSTR_SETUP(tmr, "dispatch"); - CAML_INSTR_TIME (tmr, "overhead"); - CAML_INSTR_INT ("alloc/jump#", caml_instr_alloc_jump); - caml_instr_alloc_jump = 0; -#endif - - if (trigger == caml_young_alloc_start || caml_requested_minor_gc){ - /* The minor heap is full, we must do a minor collection. */ - /* reset the pointers first because the end hooks might allocate */ - caml_requested_minor_gc = 0; - caml_young_trigger = caml_young_alloc_mid; - caml_young_limit = caml_young_trigger; - caml_empty_minor_heap (); - /* The minor heap is empty, we can start a major collection. */ - if (caml_gc_phase == Phase_idle) caml_major_collection_slice (-1); - CAML_INSTR_TIME (tmr, "dispatch/minor"); - - caml_final_do_calls (); - CAML_INSTR_TIME (tmr, "dispatch/finalizers"); - - while (caml_young_ptr - caml_young_alloc_start < Max_young_whsize){ - /* The finalizers or the hooks have filled up the minor heap, we must - repeat the minor collection. */ - caml_requested_minor_gc = 0; - caml_young_trigger = caml_young_alloc_mid; - caml_young_limit = caml_young_trigger; - caml_empty_minor_heap (); - /* The minor heap is empty, we can start a major collection. */ - if (caml_gc_phase == Phase_idle) caml_major_collection_slice (-1); - CAML_INSTR_TIME (tmr, "dispatch/finalizers_minor"); - } - } - if (trigger != caml_young_alloc_start || caml_requested_major_slice){ - /* The minor heap is half-full, do a major GC slice. */ - caml_requested_major_slice = 0; - caml_young_trigger = caml_young_alloc_start; - caml_young_limit = caml_young_trigger; - caml_major_collection_slice (-1); - CAML_INSTR_TIME (tmr, "dispatch/major"); - } -} - -/* For backward compatibility with Lablgtk: do a minor collection to - ensure that the minor heap is empty. -*/ -CAMLexport void caml_minor_collection (void) -{ - caml_requested_minor_gc = 1; - caml_gc_dispatch (); -} - -CAMLexport value caml_check_urgent_gc (value extra_root) -{ - CAMLparam1 (extra_root); - if (caml_requested_major_slice || caml_requested_minor_gc){ - CAML_INSTR_INT ("force_minor/check_urgent_gc@", 1); - caml_gc_dispatch(); - } - CAMLreturn (extra_root); -} - -static void realloc_generic_table -(struct generic_table *tbl, asize_t element_size, - char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error) -{ - CAMLassert (tbl->ptr == tbl->limit); - CAMLassert (tbl->limit <= tbl->end); - CAMLassert (tbl->limit >= tbl->threshold); - - if (tbl->base == NULL){ - alloc_generic_table (tbl, caml_minor_heap_wsz / 8, 256, - element_size); - }else if (tbl->limit == tbl->threshold){ - CAML_INSTR_INT (msg_intr_int, 1); - caml_gc_message (0x08, msg_threshold, 0); - tbl->limit = tbl->end; - caml_request_minor_gc (); - }else{ - asize_t sz; - asize_t cur_ptr = tbl->ptr - tbl->base; - CAMLassert (caml_requested_minor_gc); - - tbl->size *= 2; - sz = (tbl->size + tbl->reserve) * element_size; - caml_gc_message (0x08, msg_growing, (intnat) sz/1024); - tbl->base = caml_stat_resize_noexc (tbl->base, sz); - if (tbl->base == NULL){ - caml_fatal_error ("%s", msg_error); - } - tbl->end = tbl->base + (tbl->size + tbl->reserve) * element_size; - tbl->threshold = tbl->base + tbl->size * element_size; - tbl->ptr = tbl->base + cur_ptr; - tbl->limit = tbl->end; - } -} - -void caml_realloc_ref_table (struct caml_ref_table *tbl) -{ - realloc_generic_table - ((struct generic_table *) tbl, sizeof (value *), - "request_minor/realloc_ref_table@", - "ref_table threshold crossed\n", - "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", - "ref_table overflow"); -} - -void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *tbl) -{ - realloc_generic_table - ((struct generic_table *) tbl, sizeof (struct caml_ephe_ref_elt), - "request_minor/realloc_ephe_ref_table@", - "ephe_ref_table threshold crossed\n", - "Growing ephe_ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", - "ephe_ref_table overflow"); -} - -void caml_realloc_custom_table (struct caml_custom_table *tbl) -{ - realloc_generic_table - ((struct generic_table *) tbl, sizeof (struct caml_custom_elt), - "request_minor/realloc_custom_table@", - "custom_table threshold crossed\n", - "Growing custom_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", - "custom_table overflow"); -} |