1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 2001 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Registration of global memory roots */
19
20 #include "caml/memory.h"
21 #include "caml/misc.h"
22 #include "caml/mlvalues.h"
23 #include "caml/roots.h"
24 #include "caml/globroots.h"
25
26 /* The sets of global memory roots are represented as skip lists
27 (see William Pugh, "Skip lists: a probabilistic alternative to
28 balanced binary trees", Comm. ACM 33(6), 1990). */
29
30 struct global_root {
31 value * root; /* the address of the root */
32 struct global_root * forward[1]; /* variable-length array */
33 };
34
35 #define NUM_LEVELS 17
36
37 struct global_root_list {
38 value * root; /* dummy value for layout compatibility */
39 struct global_root * forward[NUM_LEVELS]; /* forward chaining */
40 int level; /* max used level */
41 };
42
43 /* Generate a random level for a new node: 0 with probability 3/4,
44 1 with probability 3/16, 2 with probability 3/64, etc.
45 We use a simple linear congruential PRNG (see Knuth vol 2) instead
46 of random(), because we need exactly 32 bits of pseudo-random data
47 (i.e. 2 * (NUM_LEVELS - 1)). Moreover, the congruential PRNG
48 is faster and guaranteed to be deterministic (to reproduce bugs). */
49
50 static uint32_t random_seed = 0;
51
random_level(void)52 static int random_level(void)
53 {
54 uint32_t r;
55 int level = 0;
56
57 /* Linear congruence with modulus = 2^32, multiplier = 69069
58 (Knuth vol 2 p. 106, line 15 of table 1), additive = 25173. */
59 r = random_seed = random_seed * 69069 + 25173;
60 /* Knuth (vol 2 p. 13) shows that the least significant bits are
61 "less random" than the most significant bits with a modulus of 2^m,
62 so consume most significant bits first */
63 while ((r & 0xC0000000U) == 0xC0000000U) { level++; r = r << 2; }
64 Assert(level < NUM_LEVELS);
65 return level;
66 }
67
68 /* Insertion in a global root list */
69
caml_insert_global_root(struct global_root_list * rootlist,value * r)70 static void caml_insert_global_root(struct global_root_list * rootlist,
71 value * r)
72 {
73 struct global_root * update[NUM_LEVELS];
74 struct global_root * e, * f;
75 int i, new_level;
76
77 Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
78
79 /* Init "cursor" to list head */
80 e = (struct global_root *) rootlist;
81 /* Find place to insert new node */
82 for (i = rootlist->level; i >= 0; i--) {
83 while (1) {
84 f = e->forward[i];
85 if (f == NULL || f->root >= r) break;
86 e = f;
87 }
88 update[i] = e;
89 }
90 e = e->forward[0];
91 /* If already present, don't do anything */
92 if (e != NULL && e->root == r) return;
93 /* Insert additional element, updating list level if necessary */
94 new_level = random_level();
95 if (new_level > rootlist->level) {
96 for (i = rootlist->level + 1; i <= new_level; i++)
97 update[i] = (struct global_root *) rootlist;
98 rootlist->level = new_level;
99 }
100 e = caml_stat_alloc(sizeof(struct global_root) +
101 new_level * sizeof(struct global_root *));
102 e->root = r;
103 for (i = 0; i <= new_level; i++) {
104 e->forward[i] = update[i]->forward[i];
105 update[i]->forward[i] = e;
106 }
107 }
108
109 /* Deletion in a global root list */
110
caml_delete_global_root(struct global_root_list * rootlist,value * r)111 static void caml_delete_global_root(struct global_root_list * rootlist,
112 value * r)
113 {
114 struct global_root * update[NUM_LEVELS];
115 struct global_root * e, * f;
116 int i;
117
118 Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
119
120 /* Init "cursor" to list head */
121 e = (struct global_root *) rootlist;
122 /* Find element in list */
123 for (i = rootlist->level; i >= 0; i--) {
124 while (1) {
125 f = e->forward[i];
126 if (f == NULL || f->root >= r) break;
127 e = f;
128 }
129 update[i] = e;
130 }
131 e = e->forward[0];
132 /* If not found, nothing to do */
133 if (e == NULL || e->root != r) return;
134 /* Rebuild list without node */
135 for (i = 0; i <= rootlist->level; i++) {
136 if (update[i]->forward[i] == e)
137 update[i]->forward[i] = e->forward[i];
138 }
139 /* Reclaim list element */
140 caml_stat_free(e);
141 /* Down-correct list level */
142 while (rootlist->level > 0 &&
143 rootlist->forward[rootlist->level] == NULL)
144 rootlist->level--;
145 }
146
147 /* Iterate over a global root list */
148
caml_iterate_global_roots(scanning_action f,struct global_root_list * rootlist)149 static void caml_iterate_global_roots(scanning_action f,
150 struct global_root_list * rootlist)
151 {
152 struct global_root * gr;
153
154 for (gr = rootlist->forward[0]; gr != NULL; gr = gr->forward[0]) {
155 f(*(gr->root), gr->root);
156 }
157 }
158
159 /* Empty a global root list */
160
caml_empty_global_roots(struct global_root_list * rootlist)161 static void caml_empty_global_roots(struct global_root_list * rootlist)
162 {
163 struct global_root * gr, * next;
164 int i;
165
166 Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
167
168 for (gr = rootlist->forward[0]; gr != NULL; /**/) {
169 next = gr->forward[0];
170 caml_stat_free(gr);
171 gr = next;
172 }
173 for (i = 0; i <= rootlist->level; i++) rootlist->forward[i] = NULL;
174 rootlist->level = 0;
175 }
176
177 /* The three global root lists */
178
179 struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 };
180 /* mutable roots, don't know whether old or young */
181 struct global_root_list caml_global_roots_young = { NULL, { NULL, }, 0 };
182 /* generational roots pointing to minor or major heap */
183 struct global_root_list caml_global_roots_old = { NULL, { NULL, }, 0 };
184 /* generational roots pointing to major heap */
185
186 /* Register a global C root of the mutable kind */
187
caml_register_global_root(value * r)188 CAMLexport void caml_register_global_root(value *r)
189 {
190 Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */
191 caml_insert_global_root(&caml_global_roots, r);
192 }
193
194 /* Un-register a global C root of the mutable kind */
195
caml_remove_global_root(value * r)196 CAMLexport void caml_remove_global_root(value *r)
197 {
198 caml_delete_global_root(&caml_global_roots, r);
199 }
200
201 /* Register a global C root of the generational kind */
202
caml_register_generational_global_root(value * r)203 CAMLexport void caml_register_generational_global_root(value *r)
204 {
205 value v = *r;
206 Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */
207 if (Is_block(v)) {
208 if (Is_young(v))
209 caml_insert_global_root(&caml_global_roots_young, r);
210 else if (Is_in_heap(v))
211 caml_insert_global_root(&caml_global_roots_old, r);
212 }
213 }
214
215 /* Un-register a global C root of the generational kind */
216
caml_remove_generational_global_root(value * r)217 CAMLexport void caml_remove_generational_global_root(value *r)
218 {
219 value v = *r;
220 if (Is_block(v)) {
221 if (Is_in_heap_or_young(v))
222 caml_delete_global_root(&caml_global_roots_young, r);
223 if (Is_in_heap(v))
224 caml_delete_global_root(&caml_global_roots_old, r);
225 }
226 }
227
228 /* Modify the value of a global C root of the generational kind */
229
caml_modify_generational_global_root(value * r,value newval)230 CAMLexport void caml_modify_generational_global_root(value *r, value newval)
231 {
232 value oldval = *r;
233
234 /* It is OK to have a root in roots_young that suddenly points to
235 the old generation -- the next minor GC will take care of that.
236 What needs corrective action is a root in roots_old that suddenly
237 points to the young generation. */
238 if (Is_block(newval) && Is_young(newval) &&
239 Is_block(oldval) && Is_in_heap(oldval)) {
240 caml_delete_global_root(&caml_global_roots_old, r);
241 caml_insert_global_root(&caml_global_roots_young, r);
242 }
243 /* PR#4704 */
244 else if (!Is_block(oldval) && Is_block(newval)) {
245 /* The previous value in the root was unboxed but now it is boxed.
246 The root won't appear in any of the root lists thus far (by virtue
247 of the operation of [caml_register_generational_global_root]), so we
248 need to make sure it gets in, or else it will never be scanned. */
249 if (Is_young(newval))
250 caml_insert_global_root(&caml_global_roots_young, r);
251 else if (Is_in_heap(newval))
252 caml_insert_global_root(&caml_global_roots_old, r);
253 }
254 else if (Is_block(oldval) && !Is_block(newval)) {
255 /* The previous value in the root was boxed but now it is unboxed, so
256 the root should be removed. If [oldval] is young, this will happen
257 anyway at the next minor collection, but it is safer to delete it
258 here. */
259 if (Is_in_heap_or_young(oldval))
260 caml_delete_global_root(&caml_global_roots_young, r);
261 if (Is_in_heap(oldval))
262 caml_delete_global_root(&caml_global_roots_old, r);
263 }
264 /* end PR#4704 */
265 *r = newval;
266 }
267
268 /* Scan all global roots */
269
caml_scan_global_roots(scanning_action f)270 void caml_scan_global_roots(scanning_action f)
271 {
272 caml_iterate_global_roots(f, &caml_global_roots);
273 caml_iterate_global_roots(f, &caml_global_roots_young);
274 caml_iterate_global_roots(f, &caml_global_roots_old);
275 }
276
277 /* Scan global roots for a minor collection */
278
caml_scan_global_young_roots(scanning_action f)279 void caml_scan_global_young_roots(scanning_action f)
280 {
281 struct global_root * gr;
282
283 caml_iterate_global_roots(f, &caml_global_roots);
284 caml_iterate_global_roots(f, &caml_global_roots_young);
285 /* Move young roots to old roots */
286 for (gr = caml_global_roots_young.forward[0];
287 gr != NULL; gr = gr->forward[0]) {
288 caml_insert_global_root(&caml_global_roots_old, gr->root);
289 }
290 caml_empty_global_roots(&caml_global_roots_young);
291 }
292