1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 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 /* To walk the memory roots for garbage collection */
19
20 #include "caml/finalise.h"
21 #include "caml/globroots.h"
22 #include "caml/memory.h"
23 #include "caml/major_gc.h"
24 #include "caml/minor_gc.h"
25 #include "caml/misc.h"
26 #include "caml/mlvalues.h"
27 #include "caml/stack.h"
28 #include "caml/roots.h"
29 #include <string.h>
30 #include <stdio.h>
31
32 /* Roots registered from C functions */
33
34 struct caml__roots_block *caml_local_roots = NULL;
35
36 void (*caml_scan_roots_hook) (scanning_action) = NULL;
37
38 /* The hashtable of frame descriptors */
39 frame_descr ** caml_frame_descriptors = NULL;
40 int caml_frame_descriptors_mask = 0;
41
42 /* Linked-list */
43
44 typedef struct link {
45 void *data;
46 struct link *next;
47 } link;
48
cons(void * data,link * tl)49 static link *cons(void *data, link *tl) {
50 link *lnk = caml_stat_alloc(sizeof(link));
51 lnk->data = data;
52 lnk->next = tl;
53 return lnk;
54 }
55
56 #define iter_list(list,lnk) \
57 for (lnk = list; lnk != NULL; lnk = lnk->next)
58
59 /* Linked-list of frametables */
60
61 static link *frametables = NULL;
62 static intnat num_descr = 0;
63
count_descriptors(link * list)64 static int count_descriptors(link *list) {
65 intnat num_descr = 0;
66 link *lnk;
67 iter_list(list,lnk) {
68 num_descr += *((intnat*) lnk->data);
69 }
70 return num_descr;
71 }
72
frametables_list_tail(link * list)73 static link* frametables_list_tail(link *list) {
74 link *lnk, *tail = NULL;
75 iter_list(list,lnk) {
76 tail = lnk;
77 }
78 return tail;
79 }
80
next_frame_descr(frame_descr * d)81 static frame_descr * next_frame_descr(frame_descr * d) {
82 uintnat nextd;
83 nextd =
84 ((uintnat)d +
85 sizeof(char *) + sizeof(short) + sizeof(short) +
86 sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
87 & -sizeof(frame_descr *);
88 if (d->frame_size & 1) nextd += sizeof(void *); /* pointer to debuginfo */
89 return((frame_descr *) nextd);
90 }
91
fill_hashtable(link * frametables)92 static void fill_hashtable(link *frametables) {
93 intnat len, j;
94 intnat * tbl;
95 frame_descr * d;
96 uintnat h;
97 link *lnk = NULL;
98
99 iter_list(frametables,lnk) {
100 tbl = (intnat*) lnk->data;
101 len = *tbl;
102 d = (frame_descr *)(tbl + 1);
103 for (j = 0; j < len; j++) {
104 h = Hash_retaddr(d->retaddr);
105 while (caml_frame_descriptors[h] != NULL) {
106 h = (h+1) & caml_frame_descriptors_mask;
107 }
108 caml_frame_descriptors[h] = d;
109 d = next_frame_descr(d);
110 }
111 }
112 }
113
init_frame_descriptors(link * new_frametables)114 static void init_frame_descriptors(link *new_frametables)
115 {
116 intnat tblsize, increase, i;
117 link *tail = NULL;
118
119 Assert(new_frametables);
120
121 tail = frametables_list_tail(new_frametables);
122 increase = count_descriptors(new_frametables);
123 tblsize = caml_frame_descriptors_mask + 1;
124
125 /* Reallocate the caml_frame_descriptor table if it is too small */
126 if(tblsize < (num_descr + increase) * 2) {
127
128 /* Merge both lists */
129 tail->next = frametables;
130 frametables = NULL;
131
132 /* [num_descr] can be less than [num_descr + increase] if frame
133 tables where unregistered */
134 num_descr = count_descriptors(new_frametables);
135
136 tblsize = 4;
137 while (tblsize < 2 * num_descr) tblsize *= 2;
138
139 caml_frame_descriptors_mask = tblsize - 1;
140 if(caml_frame_descriptors) caml_stat_free(caml_frame_descriptors);
141 caml_frame_descriptors =
142 (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *));
143 for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL;
144
145 fill_hashtable(new_frametables);
146 } else {
147 num_descr += increase;
148 fill_hashtable(new_frametables);
149 tail->next = frametables;
150 }
151
152 frametables = new_frametables;
153 }
154
caml_init_frame_descriptors(void)155 void caml_init_frame_descriptors(void) {
156 intnat i;
157 link *new_frametables = NULL;
158 for (i = 0; caml_frametable[i] != 0; i++)
159 new_frametables = cons(caml_frametable[i],new_frametables);
160 init_frame_descriptors(new_frametables);
161 }
162
caml_register_frametable(intnat * table)163 void caml_register_frametable(intnat *table) {
164 link *new_frametables = cons(table,NULL);
165 init_frame_descriptors(new_frametables);
166 }
167
remove_entry(frame_descr * d)168 static void remove_entry(frame_descr * d) {
169 uintnat i;
170 uintnat r;
171 uintnat j;
172
173 i = Hash_retaddr(d->retaddr);
174 while (caml_frame_descriptors[i] != d) {
175 i = (i+1) & caml_frame_descriptors_mask;
176 }
177
178 r1:
179 j = i;
180 caml_frame_descriptors[i] = NULL;
181 r2:
182 i = (i+1) & caml_frame_descriptors_mask;
183 // r3
184 if(caml_frame_descriptors[i] == NULL) return;
185 r = Hash_retaddr(caml_frame_descriptors[i]->retaddr);
186 /* If r is between i and j (cyclically), i.e. if
187 caml_frame_descriptors[i]->retaddr don't need to be moved */
188 if(( ( j < r ) && ( r <= i ) ) ||
189 ( ( i < j ) && ( j < r ) ) || /* i cycled, r not */
190 ( ( r <= i ) && ( i < j ) ) ) { /* i and r cycled */
191 goto r2;
192 }
193 // r4
194 caml_frame_descriptors[j] = caml_frame_descriptors[i];
195 goto r1;
196 }
197
caml_unregister_frametable(intnat * table)198 void caml_unregister_frametable(intnat *table) {
199 intnat len, j;
200 link *lnk;
201 link *previous = frametables;
202 frame_descr * d;
203
204 len = *table;
205 d = (frame_descr *)(table + 1);
206 for (j = 0; j < len; j++) {
207 remove_entry(d);
208 d = next_frame_descr(d);
209 }
210
211 iter_list(frametables,lnk) {
212 if(lnk->data == table) {
213 previous->next = lnk->next;
214 caml_stat_free(lnk);
215 break;
216 }
217 previous = lnk;
218 }
219 }
220
221 /* Communication with [caml_start_program] and [caml_call_gc]. */
222
223 char * caml_top_of_stack;
224 char * caml_bottom_of_stack = NULL; /* no stack initially */
225 uintnat caml_last_return_address = 1; /* not in OCaml code initially */
226 value * caml_gc_regs;
227 intnat caml_globals_inited = 0;
228 static intnat caml_globals_scanned = 0;
229 static link * caml_dyn_globals = NULL;
230
caml_register_dyn_global(void * v)231 void caml_register_dyn_global(void *v) {
232 caml_dyn_globals = cons((void*) v,caml_dyn_globals);
233 }
234
235 /* Call [caml_oldify_one] on (at least) all the roots that point to the minor
236 heap. */
caml_oldify_local_roots(void)237 void caml_oldify_local_roots (void)
238 {
239 char * sp;
240 uintnat retaddr;
241 value * regs;
242 frame_descr * d;
243 uintnat h;
244 int i, j, n, ofs;
245 #ifdef Stack_grows_upwards
246 short * p; /* PR#4339: stack offsets are negative in this case */
247 #else
248 unsigned short * p;
249 #endif
250 value * glob;
251 value * root;
252 struct caml__roots_block *lr;
253 link *lnk;
254
255 /* The global roots */
256 for (i = caml_globals_scanned;
257 i <= caml_globals_inited && caml_globals[i] != 0;
258 i++) {
259 for(glob = caml_globals[i]; *glob != 0; glob++) {
260 for (j = 0; j < Wosize_val(*glob); j++){
261 Oldify (&Field (*glob, j));
262 }
263 }
264 }
265 caml_globals_scanned = caml_globals_inited;
266
267 /* Dynamic global roots */
268 iter_list(caml_dyn_globals, lnk) {
269 for(glob = (value *) lnk->data; *glob != 0; glob++) {
270 for (j = 0; j < Wosize_val(*glob); j++){
271 Oldify (&Field (*glob, j));
272 }
273 }
274 }
275
276 /* The stack and local roots */
277 sp = caml_bottom_of_stack;
278 retaddr = caml_last_return_address;
279 regs = caml_gc_regs;
280 if (sp != NULL) {
281 while (1) {
282 /* Find the descriptor corresponding to the return address */
283 h = Hash_retaddr(retaddr);
284 while(1) {
285 d = caml_frame_descriptors[h];
286 if (d->retaddr == retaddr) break;
287 h = (h+1) & caml_frame_descriptors_mask;
288 }
289 if (d->frame_size != 0xFFFF) {
290 /* Scan the roots in this frame */
291 for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
292 ofs = *p;
293 if (ofs & 1) {
294 root = regs + (ofs >> 1);
295 } else {
296 root = (value *)(sp + ofs);
297 }
298 Oldify (root);
299 }
300 /* Move to next frame */
301 #ifndef Stack_grows_upwards
302 sp += (d->frame_size & 0xFFFC);
303 #else
304 sp -= (d->frame_size & 0xFFFC);
305 #endif
306 retaddr = Saved_return_address(sp);
307 #ifdef Already_scanned
308 /* Stop here if the frame has been scanned during earlier GCs */
309 if (Already_scanned(sp, retaddr)) break;
310 /* Mark frame as already scanned */
311 Mark_scanned(sp, retaddr);
312 #endif
313 } else {
314 /* This marks the top of a stack chunk for an ML callback.
315 Skip C portion of stack and continue with next ML stack chunk. */
316 struct caml_context * next_context = Callback_link(sp);
317 sp = next_context->bottom_of_stack;
318 retaddr = next_context->last_retaddr;
319 regs = next_context->gc_regs;
320 /* A null sp means no more ML stack chunks; stop here. */
321 if (sp == NULL) break;
322 }
323 }
324 }
325 /* Local C roots */
326 for (lr = caml_local_roots; lr != NULL; lr = lr->next) {
327 for (i = 0; i < lr->ntables; i++){
328 for (j = 0; j < lr->nitems; j++){
329 root = &(lr->tables[i][j]);
330 Oldify (root);
331 }
332 }
333 }
334 /* Global C roots */
335 caml_scan_global_young_roots(&caml_oldify_one);
336 /* Finalised values */
337 caml_final_oldify_young_roots ();
338 /* Hook */
339 if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
340 }
341
342 uintnat caml_incremental_roots_count = 0;
343
344 /* Call [caml_darken] on all roots, incrementally:
345 [caml_darken_all_roots_start] does the non-incremental part and
346 sets things up for [caml_darken_all_roots_slice].
347 */
caml_darken_all_roots_start(void)348 void caml_darken_all_roots_start (void)
349 {
350 caml_do_roots (caml_darken, 0);
351 }
352
353 /* Call [caml_darken] on at most [work] global roots. Return the
354 amount of work not done, if any. If this is strictly positive,
355 the darkening is done.
356 */
caml_darken_all_roots_slice(intnat work)357 intnat caml_darken_all_roots_slice (intnat work)
358 {
359 static int i, j;
360 static value *glob;
361 static int do_resume = 0;
362 static mlsize_t roots_count = 0;
363 intnat remaining_work = work;
364 CAML_INSTR_SETUP (tmr, "");
365
366 /* If the loop was started in a previous call, resume it. */
367 if (do_resume) goto resume;
368
369 /* This is the same loop as in [caml_do_roots], but we make it
370 suspend itself when [work] reaches 0. */
371 for (i = 0; caml_globals[i] != 0; i++) {
372 for(glob = caml_globals[i]; *glob != 0; glob++) {
373 for (j = 0; j < Wosize_val(*glob); j++){
374 caml_darken (Field (*glob, j), &Field (*glob, j));
375 -- remaining_work;
376 if (remaining_work == 0){
377 roots_count += work;
378 do_resume = 1;
379 goto suspend;
380 }
381 resume: ;
382 }
383 }
384 }
385
386 /* The loop finished normally, so all roots are now darkened. */
387 caml_incremental_roots_count = roots_count + work - remaining_work;
388 /* Prepare for the next run. */
389 do_resume = 0;
390 roots_count = 0;
391
392 suspend:
393 /* Do this in both cases. */
394 CAML_INSTR_TIME (tmr, "major/mark/global_roots_slice");
395 return remaining_work;
396 }
397
caml_do_roots(scanning_action f,int do_globals)398 void caml_do_roots (scanning_action f, int do_globals)
399 {
400 int i, j;
401 value * glob;
402 link *lnk;
403 CAML_INSTR_SETUP (tmr, "major_roots");
404
405 if (do_globals){
406 /* The global roots */
407 for (i = 0; caml_globals[i] != 0; i++) {
408 for(glob = caml_globals[i]; *glob != 0; glob++) {
409 for (j = 0; j < Wosize_val(*glob); j++)
410 f (Field (*glob, j), &Field (*glob, j));
411 }
412 }
413 }
414 /* Dynamic global roots */
415 iter_list(caml_dyn_globals, lnk) {
416 for(glob = (value *) lnk->data; *glob != 0; glob++) {
417 for (j = 0; j < Wosize_val(*glob); j++){
418 f (Field (*glob, j), &Field (*glob, j));
419 }
420 }
421 }
422 CAML_INSTR_TIME (tmr, "major_roots/dynamic_global");
423 /* The stack and local roots */
424 caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address,
425 caml_gc_regs, caml_local_roots);
426 CAML_INSTR_TIME (tmr, "major_roots/local");
427 /* Global C roots */
428 caml_scan_global_roots(f);
429 CAML_INSTR_TIME (tmr, "major_roots/C");
430 /* Finalised values */
431 caml_final_do_roots (f);
432 CAML_INSTR_TIME (tmr, "major_roots/finalised");
433 /* Hook */
434 if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);
435 CAML_INSTR_TIME (tmr, "major_roots/hook");
436 }
437
caml_do_local_roots(scanning_action f,char * bottom_of_stack,uintnat last_retaddr,value * gc_regs,struct caml__roots_block * local_roots)438 void caml_do_local_roots(scanning_action f, char * bottom_of_stack,
439 uintnat last_retaddr, value * gc_regs,
440 struct caml__roots_block * local_roots)
441 {
442 char * sp;
443 uintnat retaddr;
444 value * regs;
445 frame_descr * d;
446 uintnat h;
447 int i, j, n, ofs;
448 #ifdef Stack_grows_upwards
449 short * p; /* PR#4339: stack offsets are negative in this case */
450 #else
451 unsigned short * p;
452 #endif
453 value * root;
454 struct caml__roots_block *lr;
455
456 sp = bottom_of_stack;
457 retaddr = last_retaddr;
458 regs = gc_regs;
459 if (sp != NULL) {
460 while (1) {
461 /* Find the descriptor corresponding to the return address */
462 h = Hash_retaddr(retaddr);
463 while(1) {
464 d = caml_frame_descriptors[h];
465 if (d->retaddr == retaddr) break;
466 h = (h+1) & caml_frame_descriptors_mask;
467 }
468 if (d->frame_size != 0xFFFF) {
469 /* Scan the roots in this frame */
470 for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
471 ofs = *p;
472 if (ofs & 1) {
473 root = regs + (ofs >> 1);
474 } else {
475 root = (value *)(sp + ofs);
476 }
477 f (*root, root);
478 }
479 /* Move to next frame */
480 #ifndef Stack_grows_upwards
481 sp += (d->frame_size & 0xFFFC);
482 #else
483 sp -= (d->frame_size & 0xFFFC);
484 #endif
485 retaddr = Saved_return_address(sp);
486 #ifdef Mask_already_scanned
487 retaddr = Mask_already_scanned(retaddr);
488 #endif
489 } else {
490 /* This marks the top of a stack chunk for an ML callback.
491 Skip C portion of stack and continue with next ML stack chunk. */
492 struct caml_context * next_context = Callback_link(sp);
493 sp = next_context->bottom_of_stack;
494 retaddr = next_context->last_retaddr;
495 regs = next_context->gc_regs;
496 /* A null sp means no more ML stack chunks; stop here. */
497 if (sp == NULL) break;
498 }
499 }
500 }
501 /* Local C roots */
502 for (lr = local_roots; lr != NULL; lr = lr->next) {
503 for (i = 0; i < lr->ntables; i++){
504 for (j = 0; j < lr->nitems; j++){
505 root = &(lr->tables[i][j]);
506 f (*root, root);
507 }
508 }
509 }
510 }
511
512 uintnat (*caml_stack_usage_hook)(void) = NULL;
513
caml_stack_usage(void)514 uintnat caml_stack_usage (void)
515 {
516 uintnat sz;
517 sz = (value *) caml_top_of_stack - (value *) caml_bottom_of_stack;
518 if (caml_stack_usage_hook != NULL)
519 sz += (*caml_stack_usage_hook)();
520 return sz;
521 }
522