1 files changed, 445 insertions, 0 deletions

diff --git a/test/monniaux/ocaml/byterun/finalise.c b/test/monniaux/ocaml/byterun/finalise.c
new file mode 100644
index 00000000..d34913fb
--- /dev/null
+++ b/test/monniaux/ocaml/byterun/finalise.c
@@ -0,0 +1,445 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 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"
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "caml/spacetime.h"
+#endif
+
+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.
+*/
+
+
+/* [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;
+  }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);
+}
+
+
+static int running_finalisation_function = 0;
+
+/* Call the finalisation functions for the finalising set.
+   Note that this function must be reentrant.
+*/
+void caml_final_do_calls (void)
+{
+  struct final f;
+  value res;
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  void* saved_spacetime_trie_node_ptr;
+#endif
+
+  if (running_finalisation_function) return;
+  if (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;
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+      /* We record the finaliser's execution separately.
+         (The code of [caml_callback_exn] will do the hard work of finding
+         the correct place in the trie.) */
+      saved_spacetime_trie_node_ptr = caml_spacetime_trie_node_ptr;
+      caml_spacetime_trie_node_ptr = caml_spacetime_finaliser_trie_root;
+#endif
+      res = caml_callback_exn (f.fun, f.val + f.offset);
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+      caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr;
+#endif
+      running_finalisation_function = 0;
+      if (Is_exception_result (res)) caml_raise (Extract_exception (res));
+    }
+    caml_gc_message (0x80, "Done calling finalisation functions.\n");
+    if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) ();
+  }
+}
+
+/* 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;
+  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);
+}