byterun/globroots.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
   6 /*                                                                     */
   7 /*  Copyright 2001 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../LICENSE.     */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id$ */
  15
  16 /* Registration of global memory roots */
  17
  18 #include "memory.h"
  19 #include "misc.h"
  20 #include "mlvalues.h"
  21 #include "globroots.h"
  22
  23 /* The set of global memory roots is represented as a skip list
  24    (see William Pugh, "Skip lists: a probabilistic alternative to
  25    balanced binary trees", Comm. ACM 33(6), 1990). */
  26
  27 /* Generate a random level for a new node: 0 with probability 3/4,
  28    1 with probability 3/16, 2 with probability 3/64, etc.
  29    We use a simple linear congruential PRNG (see Knuth vol 2) instead
  30    of random(), because we need exactly 32 bits of pseudo-random data
  31    (i.e. 2 * (NUM_LEVELS - 1)).  Moreover, the congruential PRNG
  32    is faster and guaranteed to be deterministic (to reproduce bugs). */
  33
  34 static uint32 random_seed = 0;
  35
  36 static int random_level(void)
  37 {
  38   uint32 r;
  39   int level = 0;
  40
  41   /* Linear congruence with modulus = 2^32, multiplier = 69069
  42      (Knuth vol 2 p. 106, line 15 of table 1), additive = 25173. */
  43   r = random_seed = random_seed * 69069 + 25173;
  44   /* Knuth (vol 2 p. 13) shows that the least significant bits are
  45      "less random" than the most significant bits with a modulus of 2^m,
  46      so consume most significant bits first */
  47   while ((r & 0xC0000000U) == 0xC0000000U) { level++; r = r << 2; }
  48   Assert(level < NUM_LEVELS);
  49   return level;
  50 }
  51
  52 /* The initial global root list */
  53
  54 struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 };
  55
  56 /* Register a global C root */
  57
  58 CAMLexport void caml_register_global_root(value *r)
  59 {
  60   struct global_root * update[NUM_LEVELS];
  61   struct global_root * e, * f;
  62   int i, new_level;
  63
  64   Assert (((intnat) r & 3) == 0);  /* compact.c demands this (for now) */
  65
  66   /* Init "cursor" to list head */
  67   e = (struct global_root *) &caml_global_roots;
  68   /* Find place to insert new node */
  69   for (i = caml_global_roots.level; i >= 0; i--) {
  70     while (1) {
  71       f = e->forward[i];
  72       if (f == NULL || f->root >= r) break;
  73       e = f;
  74     }
  75     update[i] = e;
  76   }
  77   e = e->forward[0];
  78   /* If already present, don't do anything */
  79   if (e != NULL && e->root == r) return;
  80   /* Insert additional element, updating list level if necessary */
  81   new_level = random_level();
  82   if (new_level > caml_global_roots.level) {
  83     for (i = caml_global_roots.level + 1; i <= new_level; i++)
  84       update[i] = (struct global_root *) &caml_global_roots;
  85     caml_global_roots.level = new_level;
  86   }
  87   e = caml_stat_alloc(sizeof(struct global_root) +
  88                       new_level * sizeof(struct global_root *));
  89   e->root = r;
  90   for (i = 0; i <= new_level; i++) {
  91     e->forward[i] = update[i]->forward[i];
  92     update[i]->forward[i] = e;
  93   }
  94 }
  95
  96 /* Un-register a global C root */
  97
  98 CAMLexport void caml_remove_global_root(value *r)
  99 {
 100   struct global_root * update[NUM_LEVELS];
 101   struct global_root * e, * f;
 102   int i;
 103
 104   /* Init "cursor" to list head */
 105   e = (struct global_root *) &caml_global_roots;
 106   /* Find element in list */
 107   for (i = caml_global_roots.level; i >= 0; i--) {
 108     while (1) {
 109       f = e->forward[i];
 110       if (f == NULL || f->root >= r) break;
 111       e = f;
 112     }
 113     update[i] = e;
 114   }
 115   e = e->forward[0];
 116   /* If not found, nothing to do */
 117   if (e == NULL || e->root != r) return;
 118   /* Rebuild list without node */
 119   for (i = 0; i <= caml_global_roots.level; i++) {
 120     if (update[i]->forward[i] == e)
 121       update[i]->forward[i] = e->forward[i];
 122   }
 123   /* Reclaim list element */
 124   caml_stat_free(e);
 125   /* Down-correct list level */
 126   while (caml_global_roots.level > 0 &&
 127          caml_global_roots.forward[caml_global_roots.level] == NULL)
 128     caml_global_roots.level--;
 129 }