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

431 lines
13 KiB
C
Raw Permalink Blame History

/**************************************************************************/
/* */
/* OCaml */
/* */
/* Damien Doligez, projet Moscova, INRIA Rocquencourt */
/* */
/* Copyright 2000 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
/* Handling of finalised values. */
#include "caml/callback.h"
#include "caml/compact.h"
#include "caml/fail.h"
#include "caml/finalise.h"
#include "caml/minor_gc.h"
#include "caml/mlvalues.h"
#include "caml/roots.h"
#include "caml/signals.h"
struct final {
value fun;
value val;
int offset;
};
struct finalisable {
struct final *table;
uintnat old;
uintnat young;
uintnat size;
};
/* [0..old) : finalisable set, the values are in the major heap
[old..young) : recent set, the values could be in the minor heap
[young..size) : free space
The element of the finalisable set are moved to the finalising set
below when the value are unreachable (for the first or last time).
*/
static struct finalisable finalisable_first = {NULL,0,0,0};
static struct finalisable finalisable_last = {NULL,0,0,0};
struct to_do {
struct to_do *next;
int size;
struct final item[1]; /* variable size */
};
static struct to_do *to_do_hd = NULL;
static struct to_do *to_do_tl = NULL;
/*
to_do_hd: head of the list of finalisation functions that can be run.
to_do_tl: tail of the list of finalisation functions that can be run.
It is the finalising set.
*/
static int running_finalisation_function = 0;
/* [size] is a number of elements for the [to_do.item] array */
static void alloc_to_do (int size)
{
struct to_do *result = caml_stat_alloc_noexc (sizeof (struct to_do) +
size * sizeof (struct final));
if (result == NULL) caml_fatal_error ("out of memory");
result->next = NULL;
result->size = size;
if (to_do_tl == NULL){
to_do_hd = result;
to_do_tl = result;
if(!running_finalisation_function) caml_set_action_pending();
}else{
CAMLassert (to_do_tl->next == NULL);
to_do_tl->next = result;
to_do_tl = result;
}
}
/* Find white finalisable values, move them to the finalising set, and
darken them (if darken_value is true).
*/
static void generic_final_update (struct finalisable * final, int darken_value)
{
uintnat i, j, k;
uintnat todo_count = 0;
CAMLassert (final->old <= final->young);
for (i = 0; i < final->old; i++){
CAMLassert (Is_block (final->table[i].val));
CAMLassert (Is_in_heap (final->table[i].val));
if (Is_white_val (final->table[i].val)){
++ todo_count;
}
}
/** invariant:
- 0 <= j <= i /\ 0 <= k <= i /\ 0 <= k <= todo_count
- i : index in final_table, before i all the values are black
(alive or in the minor heap) or the finalizer have been copied
in to_do_tl.
- j : index in final_table, before j all the values are black
(alive or in the minor heap), next available slot.
- k : index in to_do_tl, next available slot.
*/
if (todo_count > 0){
alloc_to_do (todo_count);
j = k = 0;
for (i = 0; i < final->old; i++){
CAMLassert (Is_block (final->table[i].val));
CAMLassert (Is_in_heap (final->table[i].val));
CAMLassert (Tag_val (final->table[i].val) != Forward_tag);
if(Is_white_val (final->table[i].val)){
/** dead */
to_do_tl->item[k] = final->table[i];
if(!darken_value){
/* The value is not darken so the finalisation function
is called with unit not with the value */
to_do_tl->item[k].val = Val_unit;
to_do_tl->item[k].offset = 0;
};
k++;
}else{
/** alive */
final->table[j++] = final->table[i];
}
}
CAMLassert (i == final->old);
CAMLassert (k == todo_count);
final->old = j;
for(;i < final->young; i++){
final->table[j++] = final->table[i];
}
final->young = j;
to_do_tl->size = k;
if(darken_value){
for (i = 0; i < k; i++){
/* Note that item may already be dark due to multiple entries in
the final table. */
caml_darken (to_do_tl->item[i].val, NULL);
}
}
}
}
void caml_final_update_mark_phase (){
generic_final_update(&finalisable_first, /* darken_value */ 1);
}
void caml_final_update_clean_phase (){
generic_final_update(&finalisable_last, /* darken_value */ 0);
}
/* Call the finalisation functions for the finalising set.
Note that this function must be reentrant.
*/
value caml_final_do_calls_exn (void)
{
struct final f;
value res;
if (!running_finalisation_function && to_do_hd != NULL){
if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) ();
caml_gc_message (0x80, "Calling finalisation functions.\n");
while (1){
while (to_do_hd != NULL && to_do_hd->size == 0){
struct to_do *next_hd = to_do_hd->next;
caml_stat_free (to_do_hd);
to_do_hd = next_hd;
if (to_do_hd == NULL) to_do_tl = NULL;
}
if (to_do_hd == NULL) break;
CAMLassert (to_do_hd->size > 0);
-- to_do_hd->size;
f = to_do_hd->item[to_do_hd->size];
running_finalisation_function = 1;
res = caml_callback_exn (f.fun, f.val + f.offset);
running_finalisation_function = 0;
if (Is_exception_result (res)) return res;
}
caml_gc_message (0x80, "Done calling finalisation functions.\n");
if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) ();
}
return Val_unit;
}
/* Call a scanning_action [f] on [x]. */
#define Call_action(f,x) (*(f)) ((x), &(x))
/* Call [*f] on the closures of the finalisable set and
the closures and values of the finalising set.
This is called by the major GC [caml_darken_all_roots]
and by the compactor through [caml_do_roots]
*/
void caml_final_do_roots (scanning_action f)
{
uintnat i;
struct to_do *todo;
CAMLassert (finalisable_first.old <= finalisable_first.young);
for (i = 0; i < finalisable_first.young; i++){
Call_action (f, finalisable_first.table[i].fun);
};
CAMLassert (finalisable_last.old <= finalisable_last.young);
for (i = 0; i < finalisable_last.young; i++){
Call_action (f, finalisable_last.table[i].fun);
};
for (todo = to_do_hd; todo != NULL; todo = todo->next){
for (i = 0; i < todo->size; i++){
Call_action (f, todo->item[i].fun);
Call_action (f, todo->item[i].val);
}
}
}
/* Call caml_invert_root on the values of the finalisable set. This is called
directly by the compactor.
*/
void caml_final_invert_finalisable_values ()
{
uintnat i;
CAMLassert (finalisable_first.old <= finalisable_first.young);
for (i = 0; i < finalisable_first.young; i++){
caml_invert_root(finalisable_first.table[i].val,
&finalisable_first.table[i].val);
};
CAMLassert (finalisable_last.old <= finalisable_last.young);
for (i = 0; i < finalisable_last.young; i++){
caml_invert_root(finalisable_last.table[i].val,
&finalisable_last.table[i].val);
};
}
/* Call [caml_oldify_one] on the closures and values of the recent set.
This is called by the minor GC through [caml_oldify_local_roots].
*/
void caml_final_oldify_young_roots ()
{
uintnat i;
CAMLassert (finalisable_first.old <= finalisable_first.young);
for (i = finalisable_first.old; i < finalisable_first.young; i++){
caml_oldify_one(finalisable_first.table[i].fun,
&finalisable_first.table[i].fun);
caml_oldify_one(finalisable_first.table[i].val,
&finalisable_first.table[i].val);
}
CAMLassert (finalisable_last.old <= finalisable_last.young);
for (i = finalisable_last.old; i < finalisable_last.young; i++){
caml_oldify_one(finalisable_last.table[i].fun,
&finalisable_last.table[i].fun);
}
}
static void generic_final_minor_update (struct finalisable * final)
{
uintnat i, j, k;
uintnat todo_count = 0;
CAMLassert (final->old <= final->young);
for (i = final->old; i < final->young; i++){
CAMLassert (Is_block (final->table[i].val));
CAMLassert (Is_in_heap_or_young (final->table[i].val));
if (Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){
++ todo_count;
}
}
/** invariant:
- final->old <= j <= i /\ final->old <= k <= i /\ 0 <= k <= todo_count
- i : index in final_table, before i all the values are alive
or the finalizer have been copied in to_do_tl.
- j : index in final_table, before j all the values are alive,
next available slot.
- k : index in to_do_tl, next available slot.
*/
if (todo_count > 0){
alloc_to_do (todo_count);
k = 0;
j = final->old;
for (i = final->old; i < final->young; i++){
CAMLassert (Is_block (final->table[i].val));
CAMLassert (Is_in_heap_or_young (final->table[i].val));
CAMLassert (Tag_val (final->table[i].val) != Forward_tag);
if(Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){
/** dead */
to_do_tl->item[k] = final->table[i];
/* The finalisation function is called with unit not with the value */
to_do_tl->item[k].val = Val_unit;
to_do_tl->item[k].offset = 0;
k++;
}else{
/** alive */
final->table[j++] = final->table[i];
}
}
CAMLassert (i == final->young);
CAMLassert (k == todo_count);
final->young = j;
to_do_tl->size = todo_count;
}
/** update the minor value to the copied major value */
for (i = final->old; i < final->young; i++){
CAMLassert (Is_block (final->table[i].val));
CAMLassert (Is_in_heap_or_young (final->table[i].val));
if (Is_young(final->table[i].val)) {
CAMLassert (Hd_val(final->table[i].val) == 0);
final->table[i].val = Field(final->table[i].val,0);
}
}
/** check invariant */
CAMLassert (final->old <= final->young);
for (i = 0; i < final->young; i++){
CAMLassert( Is_in_heap(final->table[i].val) );
};
}
/* At the end of minor collection update the finalise_last roots in
minor heap when moved to major heap or moved them to the finalising
set when dead.
*/
void caml_final_update_minor_roots ()
{
generic_final_minor_update(&finalisable_last);
}
/* Empty the recent set into the finalisable set.
This is called at the end of each minor collection.
The minor heap must be empty when this is called.
*/
void caml_final_empty_young (void)
{
finalisable_first.old = finalisable_first.young;
finalisable_last.old = finalisable_last.young;
}
/* Put (f,v) in the recent set. */
static void generic_final_register (struct finalisable *final, value f, value v)
{
if (!Is_block (v)
|| !Is_in_heap_or_young(v)
|| Tag_val (v) == Lazy_tag
#ifdef FLAT_FLOAT_ARRAY
|| Tag_val (v) == Double_tag
#endif
|| Tag_val (v) == Forward_tag) {
caml_invalid_argument ("Gc.finalise");
}
CAMLassert (final->old <= final->young);
if (final->young >= final->size){
if (final->table == NULL){
uintnat new_size = 30;
final->table = caml_stat_alloc (new_size * sizeof (struct final));
CAMLassert (final->old == 0);
CAMLassert (final->young == 0);
final->size = new_size;
}else{
uintnat new_size = final->size * 2;
final->table = caml_stat_resize (final->table,
new_size * sizeof (struct final));
final->size = new_size;
}
}
CAMLassert (final->young < final->size);
final->table[final->young].fun = f;
if (Tag_val (v) == Infix_tag){
final->table[final->young].offset = Infix_offset_val (v);
final->table[final->young].val = v - Infix_offset_val (v);
}else{
final->table[final->young].offset = 0;
final->table[final->young].val = v;
}
++ final->young;
}
CAMLprim value caml_final_register (value f, value v){
generic_final_register(&finalisable_first, f, v);
return Val_unit;
}
CAMLprim value caml_final_register_called_without_value (value f, value v){
generic_final_register(&finalisable_last, f, v);
return Val_unit;
}
CAMLprim value caml_final_release (value unit)
{
running_finalisation_function = 0;
/* Some finalisers might be waiting. */
if (to_do_tl != NULL)
caml_set_action_pending();
return Val_unit;
}
static void gen_final_invariant_check(struct finalisable *final){
uintnat i;
CAMLassert (final->old <= final->young);
for (i = 0; i < final->old; i++){
CAMLassert( Is_in_heap(final->table[i].val) );
};
for (i = final->old; i < final->young; i++){
CAMLassert( Is_in_heap_or_young(final->table[i].val) );
};
}
void caml_final_invariant_check(void){
gen_final_invariant_check(&finalisable_first);
gen_final_invariant_check(&finalisable_last);
}
Reference in New Issue View Git Blame Copy Permalink