aboutsummaryrefslogtreecommitdiffstats
path: root/test/monniaux/ocaml/byterun/globroots.c
diff options
context:
space:
mode:
Diffstat (limited to 'test/monniaux/ocaml/byterun/globroots.c')
-rw-r--r--test/monniaux/ocaml/byterun/globroots.c291
1 files changed, 291 insertions, 0 deletions
diff --git a/test/monniaux/ocaml/byterun/globroots.c b/test/monniaux/ocaml/byterun/globroots.c
new file mode 100644
index 00000000..f689723c
--- /dev/null
+++ b/test/monniaux/ocaml/byterun/globroots.c
@@ -0,0 +1,291 @@
+/**************************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 2001 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
+
+/* Registration of global memory roots */
+
+#include "caml/memory.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/roots.h"
+#include "caml/globroots.h"
+
+/* The sets of global memory roots are represented as skip lists
+ (see William Pugh, "Skip lists: a probabilistic alternative to
+ balanced binary trees", Comm. ACM 33(6), 1990). */
+
+struct global_root {
+ value * root; /* the address of the root */
+ struct global_root * forward[1]; /* variable-length array */
+};
+
+#define NUM_LEVELS 17
+
+struct global_root_list {
+ value * root; /* dummy value for layout compatibility */
+ struct global_root * forward[NUM_LEVELS]; /* forward chaining */
+ int level; /* max used level */
+};
+
+/* Generate a random level for a new node: 0 with probability 3/4,
+ 1 with probability 3/16, 2 with probability 3/64, etc.
+ We use a simple linear congruential PRNG (see Knuth vol 2) instead
+ of random(), because we need exactly 32 bits of pseudo-random data
+ (i.e. 2 * (NUM_LEVELS - 1)). Moreover, the congruential PRNG
+ is faster and guaranteed to be deterministic (to reproduce bugs). */
+
+static uint32_t random_seed = 0;
+
+static int random_level(void)
+{
+ uint32_t r;
+ int level = 0;
+
+ /* Linear congruence with modulus = 2^32, multiplier = 69069
+ (Knuth vol 2 p. 106, line 15 of table 1), additive = 25173. */
+ r = random_seed = random_seed * 69069 + 25173;
+ /* Knuth (vol 2 p. 13) shows that the least significant bits are
+ "less random" than the most significant bits with a modulus of 2^m,
+ so consume most significant bits first */
+ while ((r & 0xC0000000U) == 0xC0000000U) { level++; r = r << 2; }
+ CAMLassert(level < NUM_LEVELS);
+ return level;
+}
+
+/* Insertion in a global root list */
+
+static void caml_insert_global_root(struct global_root_list * rootlist,
+ value * r)
+{
+ struct global_root * update[NUM_LEVELS];
+ struct global_root * e, * f;
+ int i, new_level;
+
+ CAMLassert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
+
+ /* Init "cursor" to list head */
+ e = (struct global_root *) rootlist;
+ /* Find place to insert new node */
+ for (i = rootlist->level; i >= 0; i--) {
+ while (1) {
+ f = e->forward[i];
+ if (f == NULL || f->root >= r) break;
+ e = f;
+ }
+ update[i] = e;
+ }
+ e = e->forward[0];
+ /* If already present, don't do anything */
+ if (e != NULL && e->root == r) return;
+ /* Insert additional element, updating list level if necessary */
+ new_level = random_level();
+ if (new_level > rootlist->level) {
+ for (i = rootlist->level + 1; i <= new_level; i++)
+ update[i] = (struct global_root *) rootlist;
+ rootlist->level = new_level;
+ }
+ e = caml_stat_alloc(sizeof(struct global_root) +
+ new_level * sizeof(struct global_root *));
+ e->root = r;
+ for (i = 0; i <= new_level; i++) {
+ e->forward[i] = update[i]->forward[i];
+ update[i]->forward[i] = e;
+ }
+}
+
+/* Deletion in a global root list */
+
+static void caml_delete_global_root(struct global_root_list * rootlist,
+ value * r)
+{
+ struct global_root * update[NUM_LEVELS];
+ struct global_root * e, * f;
+ int i;
+
+ CAMLassert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
+
+ /* Init "cursor" to list head */
+ e = (struct global_root *) rootlist;
+ /* Find element in list */
+ for (i = rootlist->level; i >= 0; i--) {
+ while (1) {
+ f = e->forward[i];
+ if (f == NULL || f->root >= r) break;
+ e = f;
+ }
+ update[i] = e;
+ }
+ e = e->forward[0];
+ /* If not found, nothing to do */
+ if (e == NULL || e->root != r) return;
+ /* Rebuild list without node */
+ for (i = 0; i <= rootlist->level; i++) {
+ if (update[i]->forward[i] == e)
+ update[i]->forward[i] = e->forward[i];
+ }
+ /* Reclaim list element */
+ caml_stat_free(e);
+ /* Down-correct list level */
+ while (rootlist->level > 0 &&
+ rootlist->forward[rootlist->level] == NULL)
+ rootlist->level--;
+}
+
+/* Iterate over a global root list */
+
+static void caml_iterate_global_roots(scanning_action f,
+ struct global_root_list * rootlist)
+{
+ struct global_root * gr;
+
+ for (gr = rootlist->forward[0]; gr != NULL; gr = gr->forward[0]) {
+ f(*(gr->root), gr->root);
+ }
+}
+
+/* Empty a global root list */
+
+static void caml_empty_global_roots(struct global_root_list * rootlist)
+{
+ struct global_root * gr, * next;
+ int i;
+
+ CAMLassert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
+
+ for (gr = rootlist->forward[0]; gr != NULL; /**/) {
+ next = gr->forward[0];
+ caml_stat_free(gr);
+ gr = next;
+ }
+ for (i = 0; i <= rootlist->level; i++) rootlist->forward[i] = NULL;
+ rootlist->level = 0;
+}
+
+/* The three global root lists */
+
+struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 };
+ /* mutable roots, don't know whether old or young */
+struct global_root_list caml_global_roots_young = { NULL, { NULL, }, 0 };
+ /* generational roots pointing to minor or major heap */
+struct global_root_list caml_global_roots_old = { NULL, { NULL, }, 0 };
+ /* generational roots pointing to major heap */
+
+/* Register a global C root of the mutable kind */
+
+CAMLexport void caml_register_global_root(value *r)
+{
+ CAMLassert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */
+ caml_insert_global_root(&caml_global_roots, r);
+}
+
+/* Un-register a global C root of the mutable kind */
+
+CAMLexport void caml_remove_global_root(value *r)
+{
+ caml_delete_global_root(&caml_global_roots, r);
+}
+
+/* Register a global C root of the generational kind */
+
+CAMLexport void caml_register_generational_global_root(value *r)
+{
+ value v = *r;
+ CAMLassert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */
+ if (Is_block(v)) {
+ if (Is_young(v))
+ caml_insert_global_root(&caml_global_roots_young, r);
+ else if (Is_in_heap(v))
+ caml_insert_global_root(&caml_global_roots_old, r);
+ }
+}
+
+/* Un-register a global C root of the generational kind */
+
+CAMLexport void caml_remove_generational_global_root(value *r)
+{
+ value v = *r;
+ if (Is_block(v)) {
+ if (Is_in_heap_or_young(v))
+ caml_delete_global_root(&caml_global_roots_young, r);
+ if (Is_in_heap(v))
+ caml_delete_global_root(&caml_global_roots_old, r);
+ }
+}
+
+/* Modify the value of a global C root of the generational kind */
+
+CAMLexport void caml_modify_generational_global_root(value *r, value newval)
+{
+ value oldval = *r;
+
+ /* It is OK to have a root in roots_young that suddenly points to
+ the old generation -- the next minor GC will take care of that.
+ What needs corrective action is a root in roots_old that suddenly
+ points to the young generation. */
+ if (Is_block(newval) && Is_young(newval) &&
+ Is_block(oldval) && Is_in_heap(oldval)) {
+ caml_delete_global_root(&caml_global_roots_old, r);
+ caml_insert_global_root(&caml_global_roots_young, r);
+ }
+ /* PR#4704 */
+ else if (!Is_block(oldval) && Is_block(newval)) {
+ /* The previous value in the root was unboxed but now it is boxed.
+ The root won't appear in any of the root lists thus far (by virtue
+ of the operation of [caml_register_generational_global_root]), so we
+ need to make sure it gets in, or else it will never be scanned. */
+ if (Is_young(newval))
+ caml_insert_global_root(&caml_global_roots_young, r);
+ else if (Is_in_heap(newval))
+ caml_insert_global_root(&caml_global_roots_old, r);
+ }
+ else if (Is_block(oldval) && !Is_block(newval)) {
+ /* The previous value in the root was boxed but now it is unboxed, so
+ the root should be removed. If [oldval] is young, this will happen
+ anyway at the next minor collection, but it is safer to delete it
+ here. */
+ if (Is_in_heap_or_young(oldval))
+ caml_delete_global_root(&caml_global_roots_young, r);
+ if (Is_in_heap(oldval))
+ caml_delete_global_root(&caml_global_roots_old, r);
+ }
+ /* end PR#4704 */
+ *r = newval;
+}
+
+/* Scan all global roots */
+
+void caml_scan_global_roots(scanning_action f)
+{
+ caml_iterate_global_roots(f, &caml_global_roots);
+ caml_iterate_global_roots(f, &caml_global_roots_young);
+ caml_iterate_global_roots(f, &caml_global_roots_old);
+}
+
+/* Scan global roots for a minor collection */
+
+void caml_scan_global_young_roots(scanning_action f)
+{
+ struct global_root * gr;
+
+ caml_iterate_global_roots(f, &caml_global_roots);
+ caml_iterate_global_roots(f, &caml_global_roots_young);
+ /* Move young roots to old roots */
+ for (gr = caml_global_roots_young.forward[0];
+ gr != NULL; gr = gr->forward[0]) {
+ caml_insert_global_root(&caml_global_roots_old, gr->root);
+ }
+ caml_empty_global_roots(&caml_global_roots_young);
+}
generated by cgit (git 2.34.1) at 2024-06-02 10:54:22 +0000