1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Damien Doligez, projet Moscova, INRIA Rocquencourt */
6 /* */
7 /* Copyright 2000 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 /* Handling of finalised values. */
19
20 #include "caml/callback.h"
21 #include "caml/compact.h"
22 #include "caml/fail.h"
23 #include "caml/finalise.h"
24 #include "caml/minor_gc.h"
25 #include "caml/mlvalues.h"
26 #include "caml/roots.h"
27 #include "caml/signals.h"
28 #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
29 #include "caml/spacetime.h"
30 #endif
31
32 struct final {
33 value fun;
34 value val;
35 int offset;
36 };
37
38 struct finalisable {
39 struct final *table;
40 uintnat old;
41 uintnat young;
42 uintnat size;
43 };
44 /* [0..old) : finalisable set, the values are in the major heap
45 [old..young) : recent set, the values could be in the minor heap
46 [young..size) : free space
47
48 The element of the finalisable set are moved to the finalising set
49 below when the value are unreachable (for the first or last time).
50
51 */
52
53 static struct finalisable finalisable_first = {NULL,0,0,0};
54 static struct finalisable finalisable_last = {NULL,0,0,0};
55
56 struct to_do {
57 struct to_do *next;
58 int size;
59 struct final item[1]; /* variable size */
60 };
61
62 static struct to_do *to_do_hd = NULL;
63 static struct to_do *to_do_tl = NULL;
64 /*
65 to_do_hd: head of the list of finalisation functions that can be run.
66 to_do_tl: tail of the list of finalisation functions that can be run.
67
68 It is the finalising set.
69 */
70
71 static int running_finalisation_function = 0;
72
73 /* [size] is a number of elements for the [to_do.item] array */
74 static void alloc_to_do (int size)
75 {
76 struct to_do *result = caml_stat_alloc_noexc (sizeof (struct to_do) +
77 size * sizeof (struct final));
78 if (result == NULL) caml_fatal_error ("out of memory");
79 result->next = NULL;
80 result->size = size;
81 if (to_do_tl == NULL){
82 to_do_hd = result;
83 to_do_tl = result;
84 if(!running_finalisation_function) caml_set_action_pending();
85 }else{
86 CAMLassert (to_do_tl->next == NULL);
87 to_do_tl->next = result;
88 to_do_tl = result;
89 }
90 }
91
92 /* Find white finalisable values, move them to the finalising set, and
93 darken them (if darken_value is true).
94 */
95 static void generic_final_update (struct finalisable * final, int darken_value)
96 {
97 uintnat i, j, k;
98 uintnat todo_count = 0;
99
100 CAMLassert (final->old <= final->young);
101 for (i = 0; i < final->old; i++){
102 CAMLassert (Is_block (final->table[i].val));
103 CAMLassert (Is_in_heap (final->table[i].val));
104 if (Is_white_val (final->table[i].val)){
105 ++ todo_count;
106 }
107 }
108
109 /** invariant:
110 - 0 <= j <= i /\ 0 <= k <= i /\ 0 <= k <= todo_count
111 - i : index in final_table, before i all the values are black
112 (alive or in the minor heap) or the finalizer have been copied
113 in to_do_tl.
114 - j : index in final_table, before j all the values are black
115 (alive or in the minor heap), next available slot.
116 - k : index in to_do_tl, next available slot.
117 */
118 if (todo_count > 0){
119 alloc_to_do (todo_count);
120 j = k = 0;
121 for (i = 0; i < final->old; i++){
122 CAMLassert (Is_block (final->table[i].val));
123 CAMLassert (Is_in_heap (final->table[i].val));
124 CAMLassert (Tag_val (final->table[i].val) != Forward_tag);
125 if(Is_white_val (final->table[i].val)){
126 /** dead */
127 to_do_tl->item[k] = final->table[i];
128 if(!darken_value){
129 /* The value is not darken so the finalisation function
130 is called with unit not with the value */
131 to_do_tl->item[k].val = Val_unit;
132 to_do_tl->item[k].offset = 0;
133 };
134 k++;
135 }else{
136 /** alive */
137 final->table[j++] = final->table[i];
138 }
139 }
140 CAMLassert (i == final->old);
141 CAMLassert (k == todo_count);
142 final->old = j;
143 for(;i < final->young; i++){
144 final->table[j++] = final->table[i];
145 }
146 final->young = j;
147 to_do_tl->size = k;
148 if(darken_value){
149 for (i = 0; i < k; i++){
150 /* Note that item may already be dark due to multiple entries in
151 the final table. */
152 caml_darken (to_do_tl->item[i].val, NULL);
153 }
154 }
155 }
156 }
157
158 void caml_final_update_mark_phase (){
159 generic_final_update(&finalisable_first, /* darken_value */ 1);
160 }
161
162 void caml_final_update_clean_phase (){
163 generic_final_update(&finalisable_last, /* darken_value */ 0);
164 }
165
166 /* Call the finalisation functions for the finalising set.
167 Note that this function must be reentrant.
168 */
169 value caml_final_do_calls_exn (void)
170 {
171 struct final f;
172 value res;
173 #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
174 void* saved_spacetime_trie_node_ptr;
175 #endif
176
177 if (!running_finalisation_function && to_do_hd != NULL){
178 if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) ();
179 caml_gc_message (0x80, "Calling finalisation functions.\n");
180 while (1){
181 while (to_do_hd != NULL && to_do_hd->size == 0){
182 struct to_do *next_hd = to_do_hd->next;
183 caml_stat_free (to_do_hd);
184 to_do_hd = next_hd;
185 if (to_do_hd == NULL) to_do_tl = NULL;
186 }
187 if (to_do_hd == NULL) break;
188 CAMLassert (to_do_hd->size > 0);
189 -- to_do_hd->size;
190 f = to_do_hd->item[to_do_hd->size];
191 running_finalisation_function = 1;
192 #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
193 /* We record the finaliser's execution separately.
194 (The code of [caml_callback_exn] will do the hard work of finding
195 the correct place in the trie.) */
196 saved_spacetime_trie_node_ptr = caml_spacetime_trie_node_ptr;
197 caml_spacetime_trie_node_ptr = caml_spacetime_finaliser_trie_root;
198 #endif
199 res = caml_callback_exn (f.fun, f.val + f.offset);
200 #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
201 caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr;
202 #endif
203 running_finalisation_function = 0;
204 if (Is_exception_result (res)) return res;
205 }
206 caml_gc_message (0x80, "Done calling finalisation functions.\n");
207 if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) ();
208 }
209 return Val_unit;
210 }
211
212 /* Call a scanning_action [f] on [x]. */
213 #define Call_action(f,x) (*(f)) ((x), &(x))
214
215 /* Call [*f] on the closures of the finalisable set and
216 the closures and values of the finalising set.
217 This is called by the major GC [caml_darken_all_roots]
218 and by the compactor through [caml_do_roots]
219 */
220 void caml_final_do_roots (scanning_action f)
221 {
222 uintnat i;
223 struct to_do *todo;
224
225 CAMLassert (finalisable_first.old <= finalisable_first.young);
226 for (i = 0; i < finalisable_first.young; i++){
227 Call_action (f, finalisable_first.table[i].fun);
228 };
229
230 CAMLassert (finalisable_last.old <= finalisable_last.young);
231 for (i = 0; i < finalisable_last.young; i++){
232 Call_action (f, finalisable_last.table[i].fun);
233 };
234
235 for (todo = to_do_hd; todo != NULL; todo = todo->next){
236 for (i = 0; i < todo->size; i++){
237 Call_action (f, todo->item[i].fun);
238 Call_action (f, todo->item[i].val);
239 }
240 }
241 }
242
243 /* Call caml_invert_root on the values of the finalisable set. This is called
244 directly by the compactor.
245 */
246 void caml_final_invert_finalisable_values ()
247 {
248 uintnat i;
249
250 CAMLassert (finalisable_first.old <= finalisable_first.young);
251 for (i = 0; i < finalisable_first.young; i++){
252 caml_invert_root(finalisable_first.table[i].val,
253 &finalisable_first.table[i].val);
254 };
255
256 CAMLassert (finalisable_last.old <= finalisable_last.young);
257 for (i = 0; i < finalisable_last.young; i++){
258 caml_invert_root(finalisable_last.table[i].val,
259 &finalisable_last.table[i].val);
260 };
261 }
262
263 /* Call [caml_oldify_one] on the closures and values of the recent set.
264 This is called by the minor GC through [caml_oldify_local_roots].
265 */
266 void caml_final_oldify_young_roots ()
267 {
268 uintnat i;
269
270 CAMLassert (finalisable_first.old <= finalisable_first.young);
271 for (i = finalisable_first.old; i < finalisable_first.young; i++){
272 caml_oldify_one(finalisable_first.table[i].fun,
273 &finalisable_first.table[i].fun);
274 caml_oldify_one(finalisable_first.table[i].val,
275 &finalisable_first.table[i].val);
276 }
277
278 CAMLassert (finalisable_last.old <= finalisable_last.young);
279 for (i = finalisable_last.old; i < finalisable_last.young; i++){
280 caml_oldify_one(finalisable_last.table[i].fun,
281 &finalisable_last.table[i].fun);
282 }
283
284 }
285
286 static void generic_final_minor_update (struct finalisable * final)
287 {
288 uintnat i, j, k;
289 uintnat todo_count = 0;
290
291 CAMLassert (final->old <= final->young);
292 for (i = final->old; i < final->young; i++){
293 CAMLassert (Is_block (final->table[i].val));
294 CAMLassert (Is_in_heap_or_young (final->table[i].val));
295 if (Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){
296 ++ todo_count;
297 }
298 }
299
300 /** invariant:
301 - final->old <= j <= i /\ final->old <= k <= i /\ 0 <= k <= todo_count
302 - i : index in final_table, before i all the values are alive
303 or the finalizer have been copied in to_do_tl.
304 - j : index in final_table, before j all the values are alive,
305 next available slot.
306 - k : index in to_do_tl, next available slot.
307 */
308 if (todo_count > 0){
309 alloc_to_do (todo_count);
310 k = 0;
311 j = final->old;
312 for (i = final->old; i < final->young; i++){
313 CAMLassert (Is_block (final->table[i].val));
314 CAMLassert (Is_in_heap_or_young (final->table[i].val));
315 CAMLassert (Tag_val (final->table[i].val) != Forward_tag);
316 if(Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){
317 /** dead */
318 to_do_tl->item[k] = final->table[i];
319 /* The finalisation function is called with unit not with the value */
320 to_do_tl->item[k].val = Val_unit;
321 to_do_tl->item[k].offset = 0;
322 k++;
323 }else{
324 /** alive */
325 final->table[j++] = final->table[i];
326 }
327 }
328 CAMLassert (i == final->young);
329 CAMLassert (k == todo_count);
330 final->young = j;
331 to_do_tl->size = todo_count;
332 }
333
334 /** update the minor value to the copied major value */
335 for (i = final->old; i < final->young; i++){
336 CAMLassert (Is_block (final->table[i].val));
337 CAMLassert (Is_in_heap_or_young (final->table[i].val));
338 if (Is_young(final->table[i].val)) {
339 CAMLassert (Hd_val(final->table[i].val) == 0);
340 final->table[i].val = Field(final->table[i].val,0);
341 }
342 }
343
344 /** check invariant */
345 CAMLassert (final->old <= final->young);
346 for (i = 0; i < final->young; i++){
347 CAMLassert( Is_in_heap(final->table[i].val) );
348 };
349
350 }
351
352 /* At the end of minor collection update the finalise_last roots in
353 minor heap when moved to major heap or moved them to the finalising
354 set when dead.
355 */
356 void caml_final_update_minor_roots ()
357 {
358 generic_final_minor_update(&finalisable_last);
359 }
360
361 /* Empty the recent set into the finalisable set.
362 This is called at the end of each minor collection.
363 The minor heap must be empty when this is called.
364 */
365 void caml_final_empty_young (void)
366 {
367 finalisable_first.old = finalisable_first.young;
368 finalisable_last.old = finalisable_last.young;
369 }
370
371 /* Put (f,v) in the recent set. */
372 static void generic_final_register (struct finalisable *final, value f, value v)
373 {
374 if (!Is_block (v)
375 || !Is_in_heap_or_young(v)
376 || Tag_val (v) == Lazy_tag
377 #ifdef FLAT_FLOAT_ARRAY
378 || Tag_val (v) == Double_tag
379 #endif
380 || Tag_val (v) == Forward_tag) {
381 caml_invalid_argument ("Gc.finalise");
382 }
383 CAMLassert (final->old <= final->young);
384
385 if (final->young >= final->size){
386 if (final->table == NULL){
387 uintnat new_size = 30;
388 final->table = caml_stat_alloc (new_size * sizeof (struct final));
389 CAMLassert (final->old == 0);
390 CAMLassert (final->young == 0);
391 final->size = new_size;
392 }else{
393 uintnat new_size = final->size * 2;
394 final->table = caml_stat_resize (final->table,
395 new_size * sizeof (struct final));
396 final->size = new_size;
397 }
398 }
399 CAMLassert (final->young < final->size);
400 final->table[final->young].fun = f;
401 if (Tag_val (v) == Infix_tag){
402 final->table[final->young].offset = Infix_offset_val (v);
403 final->table[final->young].val = v - Infix_offset_val (v);
404 }else{
405 final->table[final->young].offset = 0;
406 final->table[final->young].val = v;
407 }
408 ++ final->young;
409
410 }
411
412 CAMLprim value caml_final_register (value f, value v){
413 generic_final_register(&finalisable_first, f, v);
414 return Val_unit;
415 }
416
417 CAMLprim value caml_final_register_called_without_value (value f, value v){
418 generic_final_register(&finalisable_last, f, v);
419 return Val_unit;
420 }
421
422 CAMLprim value caml_final_release (value unit)
423 {
424 running_finalisation_function = 0;
425 /* Some finalisers might be waiting. */
426 if (to_do_tl != NULL)
427 caml_set_action_pending();
428 return Val_unit;
429 }
430
431 static void gen_final_invariant_check(struct finalisable *final){
432 uintnat i;
433
434 CAMLassert (final->old <= final->young);
435 for (i = 0; i < final->old; i++){
436 CAMLassert( Is_in_heap(final->table[i].val) );
437 };
438 for (i = final->old; i < final->young; i++){
439 CAMLassert( Is_in_heap_or_young(final->table[i].val) );
440 };
441 }
442
443 void caml_final_invariant_check(void){
444 gen_final_invariant_check(&finalisable_first);
445 gen_final_invariant_check(&finalisable_last);
446 }
447