Commit | Line | Data |
---|---|---|
22a52da1 | 1 | /* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc. |
e1f2bf99 MD |
2 | * |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
16 | * Boston, MA 02111-1307 USA | |
17 | * | |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
40 | * If you do not wish that, delete this exception notice. */ | |
1bbd0b84 GB |
41 | |
42 | /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, | |
43 | gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ | |
44 | ||
e1f2bf99 MD |
45 | \f |
46 | ||
47 | /* This is an implementation of guardians as described in | |
48 | * R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in | |
49 | * a Generation-Based Garbage Collector" ACM SIGPLAN Conference on | |
50 | * Programming Language Design and Implementation, June 1993 | |
51 | * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz | |
52 | * | |
56495472 ML |
53 | * By this point, the semantics are actually quite different from |
54 | * those described in the abovementioned paper. The semantic changes | |
55 | * are there to improve safety and intuitiveness. The interface is | |
56 | * still (mostly) the one described by the paper, however. | |
57 | * | |
58 | * Original design: Mikael Djurfeldt | |
59 | * Original implementation: Michael Livshin | |
60 | * Hacked on since by: everybody | |
e1f2bf99 MD |
61 | */ |
62 | ||
e1f2bf99 | 63 | |
a0599745 MD |
64 | #include "libguile/_scm.h" |
65 | #include "libguile/ports.h" | |
66 | #include "libguile/print.h" | |
67 | #include "libguile/smob.h" | |
a0599745 | 68 | #include "libguile/validate.h" |
56495472 | 69 | #include "libguile/root.h" |
d9dcd933 ML |
70 | #include "libguile/hashtab.h" |
71 | #include "libguile/weaks.h" | |
56495472 | 72 | |
a0599745 | 73 | #include "libguile/guardians.h" |
e1f2bf99 | 74 | |
e1f2bf99 MD |
75 | |
76 | /* The live and zombies FIFOs are implemented as tconcs as described | |
77 | in Dybvig's paper. This decouples addition and removal of elements | |
78 | so that no synchronization between these needs to take place. | |
79 | */ | |
01449aa5 DH |
80 | |
81 | typedef struct tconc_t | |
82 | { | |
83 | SCM head; | |
84 | SCM tail; | |
85 | } tconc_t; | |
86 | ||
87 | #define TCONC_EMPTYP(tc) (SCM_EQ_P ((tc).head, (tc).tail)) | |
88 | ||
e1f2bf99 | 89 | #define TCONC_IN(tc, obj, pair) \ |
d3a6bc94 | 90 | do { \ |
e1f2bf99 | 91 | SCM_SETCAR ((tc).tail, obj); \ |
22a52da1 DH |
92 | SCM_SET_CELL_WORD_0 (pair, SCM_BOOL_F); \ |
93 | SCM_SET_CELL_WORD_1 (pair, SCM_EOL); \ | |
e1f2bf99 MD |
94 | SCM_SETCDR ((tc).tail, pair); \ |
95 | (tc).tail = pair; \ | |
d3a6bc94 | 96 | } while (0) |
e1f2bf99 MD |
97 | |
98 | #define TCONC_OUT(tc, res) \ | |
d3a6bc94 | 99 | do { \ |
e1f2bf99 MD |
100 | (res) = SCM_CAR ((tc).head); \ |
101 | (tc).head = SCM_CDR ((tc).head); \ | |
d3a6bc94 | 102 | } while (0) |
e1f2bf99 | 103 | |
e1f2bf99 | 104 | |
92c2555f | 105 | static scm_t_bits tc16_guardian; |
e1f2bf99 MD |
106 | |
107 | typedef struct guardian_t | |
108 | { | |
109 | tconc_t live; | |
110 | tconc_t zombies; | |
01a119ac | 111 | struct guardian_t *next; |
c0a5d888 | 112 | unsigned long flags; |
e1f2bf99 MD |
113 | } guardian_t; |
114 | ||
56495472 | 115 | #define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x) |
7fa93bf8 | 116 | #define GUARDIAN(x) ((guardian_t *) SCM_CELL_WORD_1 (x)) |
56495472 | 117 | |
c0a5d888 ML |
118 | #define F_GREEDY 1L |
119 | #define F_LISTED (1L << 1) | |
120 | #define F_DESTROYED (1L << 2) | |
121 | ||
122 | #define GREEDY_P(x) (((x)->flags & F_GREEDY) != 0) | |
123 | #define SET_GREEDY(x) ((x)->flags |= F_GREEDY) | |
124 | ||
125 | #define LISTED_P(x) (((x)->flags & F_LISTED) != 0) | |
126 | #define SET_LISTED(x) ((x)->flags |= F_LISTED) | |
127 | #define CLR_LISTED(x) ((x)->flags &= ~F_LISTED) | |
128 | ||
129 | #define DESTROYED_P(x) (((x)->flags & F_DESTROYED) != 0) | |
130 | #define SET_DESTROYED(x) ((x)->flags |= F_DESTROYED) | |
56495472 ML |
131 | |
132 | /* during the gc mark phase, live guardians are linked into the lists | |
133 | here. */ | |
134 | static guardian_t *greedy_guardians = NULL; | |
135 | static guardian_t *sharing_guardians = NULL; | |
136 | ||
d9dcd933 | 137 | static SCM greedily_guarded_whash = SCM_EOL; |
56495472 ML |
138 | |
139 | /* this is the list of guarded objects that are parts of cycles. we | |
140 | don't know in which order to return them from guardians, so we just | |
141 | unguard them and whine about it in after-gc-hook */ | |
142 | static SCM self_centered_zombies = SCM_EOL; | |
143 | ||
e1f2bf99 | 144 | |
56495472 | 145 | static void |
c0a5d888 | 146 | add_to_live_list (guardian_t *g) |
56495472 | 147 | { |
c0a5d888 | 148 | if (LISTED_P (g)) |
56495472 | 149 | return; |
e1f2bf99 | 150 | |
c0a5d888 | 151 | if (GREEDY_P (g)) |
56495472 | 152 | { |
c0a5d888 ML |
153 | g->next = greedy_guardians; |
154 | greedy_guardians = g; | |
56495472 ML |
155 | } |
156 | else | |
157 | { | |
c0a5d888 ML |
158 | g->next = sharing_guardians; |
159 | sharing_guardians = g; | |
56495472 | 160 | } |
01449aa5 | 161 | |
c0a5d888 | 162 | SET_LISTED (g); |
56495472 | 163 | } |
e46f3fa6 | 164 | |
01449aa5 | 165 | /* mark a guardian by adding it to the live guardian list. */ |
e1f2bf99 | 166 | static SCM |
01449aa5 DH |
167 | guardian_mark (SCM ptr) |
168 | { | |
c0a5d888 | 169 | add_to_live_list (GUARDIAN (ptr)); |
01449aa5 DH |
170 | |
171 | /* the objects protected by the guardian are not marked here: that | |
172 | would prevent them from ever getting collected. instead marking | |
56495472 | 173 | is done at the end of the mark phase by guardian_zombify. */ |
01449aa5 DH |
174 | return SCM_BOOL_F; |
175 | } | |
176 | ||
177 | ||
1be6b49c | 178 | static size_t |
01449aa5 DH |
179 | guardian_free (SCM ptr) |
180 | { | |
181 | scm_must_free (GUARDIAN (ptr)); | |
182 | return sizeof (guardian_t); | |
183 | } | |
184 | ||
185 | ||
186 | static int | |
e81d98ec | 187 | guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED) |
01449aa5 | 188 | { |
c0a5d888 ML |
189 | guardian_t *g = GUARDIAN (guardian); |
190 | ||
56495472 | 191 | scm_puts ("#<", port); |
c0a5d888 ML |
192 | |
193 | if (DESTROYED_P (g)) | |
194 | scm_puts ("destroyed ", port); | |
195 | ||
196 | if (GREEDY_P (g)) | |
197 | scm_puts ("greedy", port); | |
75bc0690 | 198 | else |
c0a5d888 ML |
199 | scm_puts ("sharing", port); |
200 | ||
201 | scm_puts (" guardian 0x", port); | |
202 | scm_intprint ((long) g, 16, port); | |
203 | ||
204 | if (! DESTROYED_P (g)) | |
205 | { | |
206 | scm_puts (" (reachable: ", port); | |
207 | scm_display (scm_length (SCM_CDR (g->live.head)), port); | |
208 | scm_puts (" unreachable: ", port); | |
209 | scm_display (scm_length (SCM_CDR (g->zombies.head)), port); | |
210 | scm_puts (")", port); | |
211 | } | |
212 | ||
213 | scm_puts (">", port); | |
01449aa5 DH |
214 | |
215 | return 1; | |
216 | } | |
217 | ||
218 | ||
c0a5d888 ML |
219 | /* This is the Scheme entry point for each guardian: If OBJ is an |
220 | * object, it's added to the guardian's live list. If OBJ is unbound, | |
221 | * the next available unreachable object (or #f if none) is returned. | |
222 | * | |
223 | * If the second optional argument THROW_P is true (the default), then | |
224 | * an error is raised if GUARDIAN is greedy and OBJ is already greedily | |
225 | * guarded. If THROW_P is false, #f is returned instead of raising the | |
226 | * error, and #t is returned if everything is fine. | |
01449aa5 DH |
227 | */ |
228 | static SCM | |
c0a5d888 | 229 | guardian_apply (SCM guardian, SCM obj, SCM throw_p) |
e1f2bf99 | 230 | { |
c0a5d888 ML |
231 | if (DESTROYED_P (GUARDIAN (guardian))) |
232 | scm_misc_error ("guard", "attempted use of destroyed guardian: ~A", | |
233 | SCM_LIST1 (guardian)); | |
234 | ||
235 | if (!SCM_UNBNDP (obj)) | |
236 | return scm_guard (guardian, obj, | |
237 | (SCM_UNBNDP (throw_p) | |
238 | ? 1 | |
239 | : SCM_NFALSEP (throw_p))); | |
e1f2bf99 | 240 | else |
01449aa5 | 241 | return scm_get_one_zombie (guardian); |
e1f2bf99 MD |
242 | } |
243 | ||
01449aa5 | 244 | |
c0a5d888 ML |
245 | SCM |
246 | scm_guard (SCM guardian, SCM obj, int throw_p) | |
e46f3fa6 | 247 | { |
c0a5d888 ML |
248 | guardian_t *g = GUARDIAN (guardian); |
249 | ||
01449aa5 | 250 | if (!SCM_IMP (obj)) |
e46f3fa6 GH |
251 | { |
252 | SCM z; | |
01449aa5 | 253 | |
75bc0690 ML |
254 | SCM_NEWCELL (z); |
255 | ||
256 | /* This critical section barrier will be replaced by a mutex. */ | |
257 | SCM_DEFER_INTS; | |
258 | ||
c0a5d888 | 259 | if (GREEDY_P (g)) |
56495472 | 260 | { |
22a52da1 | 261 | if (!SCM_FALSEP (scm_hashq_get_handle |
d9dcd933 | 262 | (greedily_guarded_whash, obj))) |
75bc0690 ML |
263 | { |
264 | SCM_ALLOW_INTS; | |
c0a5d888 ML |
265 | |
266 | if (throw_p) | |
267 | scm_misc_error ("guard", | |
268 | "object is already greedily guarded: ~A", | |
269 | SCM_LIST1 (obj)); | |
270 | else | |
271 | return SCM_BOOL_F; | |
75bc0690 | 272 | } |
56495472 | 273 | else |
d9dcd933 ML |
274 | scm_hashq_create_handle_x (greedily_guarded_whash, |
275 | obj, guardian); | |
56495472 | 276 | } |
e46f3fa6 | 277 | |
c0a5d888 | 278 | TCONC_IN (g->live, obj, z); |
75bc0690 | 279 | |
e46f3fa6 GH |
280 | SCM_ALLOW_INTS; |
281 | } | |
75bc0690 | 282 | |
c0a5d888 ML |
283 | return throw_p ? SCM_UNSPECIFIED : SCM_BOOL_T; |
284 | ||
e46f3fa6 GH |
285 | } |
286 | ||
01449aa5 | 287 | |
e46f3fa6 GH |
288 | SCM |
289 | scm_get_one_zombie (SCM guardian) | |
290 | { | |
c0a5d888 | 291 | guardian_t *g = GUARDIAN (guardian); |
e46f3fa6 GH |
292 | SCM res = SCM_BOOL_F; |
293 | ||
294 | /* This critical section barrier will be replaced by a mutex. */ | |
295 | SCM_DEFER_INTS; | |
75bc0690 | 296 | |
c0a5d888 ML |
297 | if (!TCONC_EMPTYP (g->zombies)) |
298 | TCONC_OUT (g->zombies, res); | |
56495472 ML |
299 | |
300 | if (SCM_NFALSEP (res) | |
c0a5d888 | 301 | && GREEDY_P (g)) |
d9dcd933 | 302 | scm_hashq_remove_x (greedily_guarded_whash, res); |
75bc0690 ML |
303 | |
304 | SCM_ALLOW_INTS; | |
56495472 | 305 | |
e46f3fa6 GH |
306 | return res; |
307 | } | |
e1f2bf99 | 308 | |
01449aa5 | 309 | |
56495472 ML |
310 | SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, |
311 | (SCM greedy_p), | |
e46f3fa6 GH |
312 | "Create a new guardian.\n" |
313 | "A guardian protects a set of objects from garbage collection,\n" | |
314 | "allowing a program to apply cleanup or other actions.\n\n" | |
315 | ||
2069af38 | 316 | "@code{make-guardian} returns a procedure representing the guardian.\n" |
e46f3fa6 GH |
317 | "Calling the guardian procedure with an argument adds the\n" |
318 | "argument to the guardian's set of protected objects.\n" | |
319 | "Calling the guardian procedure without an argument returns\n" | |
320 | "one of the protected objects which are ready for garbage\n" | |
2069af38 | 321 | "collection, or @code{#f} if no such object is available.\n" |
e46f3fa6 | 322 | "Objects which are returned in this way are removed from\n" |
92ccc1f1 | 323 | "the guardian.\n\n" |
e46f3fa6 | 324 | |
2069af38 NJ |
325 | "@code{make-guardian} takes one optional argument that says whether the\n" |
326 | "new guardian should be greedy or sharing. If there is any chance\n" | |
56495472 | 327 | "that any object protected by the guardian may be resurrected,\n" |
c0a5d888 | 328 | "then you should make the guardian greedy (this is the default).\n\n" |
56495472 | 329 | |
da4a1dba GB |
330 | "See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993)\n" |
331 | "\"Guardians in a Generation-Based Garbage Collector\".\n" | |
332 | "ACM SIGPLAN Conference on Programming Language Design\n" | |
56495472 ML |
333 | "and Implementation, June 1993.\n\n" |
334 | ||
335 | "(the semantics are slightly different at this point, but the\n" | |
336 | "paper still (mostly) accurately describes the interface).") | |
1bbd0b84 | 337 | #define FUNC_NAME s_scm_make_guardian |
e1f2bf99 | 338 | { |
01449aa5 | 339 | guardian_t *g = SCM_MUST_MALLOC_TYPE (guardian_t); |
e46f3fa6 GH |
340 | SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL); |
341 | SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL); | |
e1f2bf99 | 342 | SCM z; |
e46f3fa6 | 343 | |
e1f2bf99 MD |
344 | /* A tconc starts out with one tail pair. */ |
345 | g->live.head = g->live.tail = z1; | |
346 | g->zombies.head = g->zombies.tail = z2; | |
56495472 | 347 | |
c0a5d888 ML |
348 | g->next = NULL; |
349 | g->flags = 0L; | |
23a62151 | 350 | |
c0a5d888 ML |
351 | /* [cmm] the UNBNDP check below is redundant but I like it. */ |
352 | if (SCM_UNBNDP (greedy_p) || SCM_NFALSEP (greedy_p)) | |
353 | SET_GREEDY (g); | |
354 | ||
01449aa5 | 355 | SCM_NEWSMOB (z, tc16_guardian, g); |
e1f2bf99 | 356 | |
01449aa5 | 357 | return z; |
e1f2bf99 | 358 | } |
1bbd0b84 | 359 | #undef FUNC_NAME |
e1f2bf99 | 360 | |
e46f3fa6 | 361 | |
c0a5d888 ML |
362 | SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0, |
363 | (SCM guardian), | |
2069af38 | 364 | "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.") |
c0a5d888 ML |
365 | #define FUNC_NAME s_scm_guardian_destroyed_p |
366 | { | |
367 | SCM res = SCM_BOOL_F; | |
368 | ||
369 | /* This critical section barrier will be replaced by a mutex. */ | |
370 | SCM_DEFER_INTS; | |
371 | ||
372 | res = SCM_BOOL (DESTROYED_P (GUARDIAN (guardian))); | |
373 | ||
374 | SCM_ALLOW_INTS; | |
375 | ||
376 | return res; | |
377 | } | |
378 | #undef FUNC_NAME | |
379 | ||
2069af38 | 380 | SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0, |
c0a5d888 | 381 | (SCM guardian), |
2069af38 | 382 | "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.\n") |
c0a5d888 ML |
383 | #define FUNC_NAME s_scm_guardian_greedy_p |
384 | { | |
385 | return SCM_BOOL (GREEDY_P (GUARDIAN (guardian))); | |
386 | } | |
387 | #undef FUNC_NAME | |
388 | ||
389 | SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0, | |
390 | (SCM guardian), | |
391 | "Destroys @var{guardian}, by making it impossible to put any more\n" | |
392 | "objects in it or get any objects from it. It also unguards any\n" | |
393 | "objects guarded by @var{guardian}.") | |
394 | #define FUNC_NAME s_scm_destroy_guardian_x | |
395 | { | |
396 | guardian_t *g = GUARDIAN (guardian); | |
397 | ||
398 | /* This critical section barrier will be replaced by a mutex. */ | |
399 | SCM_DEFER_INTS; | |
400 | ||
401 | if (DESTROYED_P (g)) | |
402 | { | |
403 | SCM_ALLOW_INTS; | |
404 | SCM_MISC_ERROR ("guardian is already destroyed: ~A", SCM_LIST1 (guardian)); | |
405 | } | |
406 | ||
407 | if (GREEDY_P (g)) | |
408 | { | |
409 | /* clear the "greedily guarded" property of the objects */ | |
410 | SCM pair; | |
411 | for (pair = g->live.head; pair != g->live.tail; pair = SCM_CDR (pair)) | |
412 | scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair)); | |
413 | for (pair = g->zombies.head; pair != g->zombies.tail; pair = SCM_CDR (pair)) | |
414 | scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair)); | |
415 | } | |
416 | ||
417 | /* empty the lists */ | |
418 | g->live.head = g->live.tail; | |
419 | g->zombies.head = g->zombies.tail; | |
420 | ||
421 | SET_DESTROYED (g); | |
422 | ||
423 | SCM_ALLOW_INTS; | |
424 | ||
425 | return SCM_UNSPECIFIED; | |
426 | } | |
427 | #undef FUNC_NAME | |
428 | ||
01449aa5 | 429 | /* called before gc mark phase begins to initialise the live guardian list. */ |
5d2565a7 | 430 | static void * |
e81d98ec DH |
431 | guardian_gc_init (void *dummy1 SCM_UNUSED, |
432 | void *dummy2 SCM_UNUSED, | |
433 | void *dummy3 SCM_UNUSED) | |
e1f2bf99 | 434 | { |
56495472 | 435 | greedy_guardians = sharing_guardians = NULL; |
5d2565a7 MD |
436 | |
437 | return 0; | |
e1f2bf99 MD |
438 | } |
439 | ||
56495472 | 440 | static void |
c275ccf5 | 441 | mark_dependencies_in_tconc (tconc_t *tc) |
56495472 ML |
442 | { |
443 | SCM pair, next_pair; | |
444 | SCM *prev_ptr; | |
445 | ||
c275ccf5 | 446 | /* scan the list for unmarked objects, and mark their |
56495472 | 447 | dependencies */ |
c275ccf5 ML |
448 | for (pair = tc->head, prev_ptr = &tc->head; |
449 | ! SCM_EQ_P (pair, tc->tail); | |
56495472 ML |
450 | pair = next_pair) |
451 | { | |
452 | SCM obj = SCM_CAR (pair); | |
453 | next_pair = SCM_CDR (pair); | |
454 | ||
455 | if (! SCM_MARKEDP (obj)) | |
456 | { | |
457 | /* a candidate for finalizing */ | |
458 | scm_gc_mark_dependencies (obj); | |
459 | ||
460 | if (SCM_MARKEDP (obj)) | |
461 | { | |
462 | /* uh oh. a cycle. transfer this object (the | |
463 | spine cell, to be exact) to | |
464 | self_centered_zombies, so we'll be able to | |
465 | complain about it later. */ | |
466 | *prev_ptr = next_pair; | |
467 | SCM_SETGCMARK (pair); | |
468 | SCM_SETCDR (pair, SCM_CDR (self_centered_zombies)); | |
469 | SCM_SETCDR (self_centered_zombies, pair); | |
470 | } | |
471 | else | |
472 | { | |
473 | /* see if this is a guardian. if yes, list it (but don't | |
474 | mark it yet). */ | |
475 | if (GUARDIAN_P (obj)) | |
c0a5d888 | 476 | add_to_live_list (GUARDIAN (obj)); |
56495472 ML |
477 | |
478 | prev_ptr = SCM_CDRLOC (pair); | |
479 | } | |
480 | } | |
481 | } | |
482 | } | |
483 | ||
c275ccf5 ML |
484 | static void |
485 | mark_dependencies (guardian_t *g) | |
486 | { | |
487 | mark_dependencies_in_tconc (&g->zombies); | |
488 | mark_dependencies_in_tconc (&g->live); | |
489 | } | |
490 | ||
56495472 ML |
491 | static void |
492 | mark_and_zombify (guardian_t *g) | |
493 | { | |
494 | SCM tconc_tail = g->live.tail; | |
495 | SCM *prev_ptr = &g->live.head; | |
496 | SCM pair = g->live.head; | |
497 | ||
498 | while (! SCM_EQ_P (pair, tconc_tail)) | |
499 | { | |
500 | SCM next_pair = SCM_CDR (pair); | |
501 | ||
502 | if (SCM_NMARKEDP (SCM_CAR (pair))) | |
503 | { | |
504 | /* got you, zombie! */ | |
505 | ||
506 | /* out of the live list! */ | |
507 | *prev_ptr = next_pair; | |
508 | ||
c0a5d888 | 509 | if (GREEDY_P (g)) |
56495472 ML |
510 | /* if the guardian is greedy, mark this zombie now. this |
511 | way it won't be zombified again this time around. */ | |
512 | SCM_SETGCMARK (SCM_CAR (pair)); | |
513 | ||
514 | /* into the zombie list! */ | |
515 | TCONC_IN (g->zombies, SCM_CAR (pair), pair); | |
516 | } | |
517 | else | |
518 | prev_ptr = SCM_CDRLOC (pair); | |
519 | ||
520 | pair = next_pair; | |
521 | } | |
522 | ||
523 | /* Mark the cells of the live list (yes, the cells in the list, we | |
524 | don't care about objects pointed to by the list cars, since we | |
525 | know they are already marked). */ | |
526 | for (pair = g->live.head; !SCM_NULLP (pair); pair = SCM_CDR (pair)) | |
527 | SCM_SETGCMARK (pair); | |
528 | } | |
529 | ||
e46f3fa6 GH |
530 | |
531 | /* this is called by the garbage collector between the mark and sweep | |
532 | phases. for each marked guardian, it moves any unmarked object in | |
533 | its live list (tconc) to its zombie list (tconc). */ | |
5d2565a7 | 534 | static void * |
e81d98ec DH |
535 | guardian_zombify (void *dummy1 SCM_UNUSED, |
536 | void *dummy2 SCM_UNUSED, | |
537 | void *dummy3 SCM_UNUSED) | |
e1f2bf99 | 538 | { |
56495472 ML |
539 | guardian_t *last_greedy_guardian = NULL; |
540 | guardian_t *last_sharing_guardian = NULL; | |
541 | guardian_t *first_greedy_guardian = NULL; | |
542 | guardian_t *first_sharing_guardian = NULL; | |
543 | guardian_t *g; | |
544 | ||
545 | /* First, find all newly unreachable objects and mark their | |
546 | dependencies. | |
547 | ||
548 | Note that new guardians may be stuck on the end of the live | |
549 | guardian lists as we run this loop, since guardians might be | |
550 | guarded too. When we mark a guarded guardian, its mark function | |
551 | sticks in the appropriate live guardian list. The loop | |
552 | terminates when no new guardians are found. */ | |
e46f3fa6 | 553 | |
50fecba9 | 554 | do { |
56495472 ML |
555 | first_greedy_guardian = greedy_guardians; |
556 | first_sharing_guardian = sharing_guardians; | |
557 | ||
558 | for (g = greedy_guardians; g != last_greedy_guardian; | |
559 | g = g->next) | |
560 | mark_dependencies (g); | |
561 | for (g = sharing_guardians; g != last_sharing_guardian; | |
562 | g = g->next) | |
563 | mark_dependencies (g); | |
564 | ||
565 | last_greedy_guardian = first_greedy_guardian; | |
566 | last_sharing_guardian = first_sharing_guardian; | |
567 | } while (first_greedy_guardian != greedy_guardians | |
568 | || first_sharing_guardian != sharing_guardians); | |
50fecba9 | 569 | |
56495472 ML |
570 | /* now, scan all the guardians that are currently known to be live |
571 | and move their unmarked objects to zombie lists. */ | |
572 | ||
573 | for (g = greedy_guardians; g; g = g->next) | |
574 | { | |
575 | mark_and_zombify (g); | |
c0a5d888 | 576 | CLR_LISTED (g); |
56495472 ML |
577 | } |
578 | for (g = sharing_guardians; g; g = g->next) | |
579 | { | |
580 | mark_and_zombify (g); | |
c0a5d888 | 581 | CLR_LISTED (g); |
56495472 | 582 | } |
5d2565a7 | 583 | |
56495472 ML |
584 | /* Preserve the zombies in their undead state, by marking to prevent |
585 | collection. */ | |
586 | for (g = greedy_guardians; g; g = g->next) | |
587 | scm_gc_mark (g->zombies.head); | |
588 | for (g = sharing_guardians; g; g = g->next) | |
589 | scm_gc_mark (g->zombies.head); | |
590 | ||
5d2565a7 | 591 | return 0; |
e1f2bf99 MD |
592 | } |
593 | ||
56495472 | 594 | static void * |
e81d98ec DH |
595 | whine_about_self_centered_zombies (void *dummy1 SCM_UNUSED, |
596 | void *dummy2 SCM_UNUSED, | |
597 | void *dummy3 SCM_UNUSED) | |
56495472 ML |
598 | { |
599 | if (! SCM_NULLP (SCM_CDR (self_centered_zombies))) | |
600 | { | |
601 | SCM pair; | |
602 | ||
603 | scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:", | |
604 | scm_cur_errp); | |
605 | scm_newline (scm_cur_errp); | |
606 | for (pair = SCM_CDR (self_centered_zombies); | |
607 | ! SCM_NULLP (pair); pair = SCM_CDR (pair)) | |
608 | { | |
609 | scm_display (SCM_CAR (pair), scm_cur_errp); | |
610 | scm_newline (scm_cur_errp); | |
611 | } | |
612 | ||
613 | SCM_SETCDR (self_centered_zombies, SCM_EOL); | |
614 | } | |
615 | ||
616 | return 0; | |
617 | } | |
e1f2bf99 MD |
618 | |
619 | void | |
56495472 | 620 | scm_init_guardians () |
e1f2bf99 | 621 | { |
01449aa5 DH |
622 | tc16_guardian = scm_make_smob_type ("guardian", 0); |
623 | scm_set_smob_mark (tc16_guardian, guardian_mark); | |
624 | scm_set_smob_free (tc16_guardian, guardian_free); | |
625 | scm_set_smob_print (tc16_guardian, guardian_print); | |
c0a5d888 | 626 | scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0); |
01449aa5 DH |
627 | |
628 | scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0); | |
629 | scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0); | |
e1f2bf99 | 630 | |
56495472 ML |
631 | self_centered_zombies = |
632 | scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL)); | |
633 | scm_c_hook_add (&scm_after_gc_c_hook, | |
634 | whine_about_self_centered_zombies, 0, 0); | |
635 | ||
d9dcd933 ML |
636 | greedily_guarded_whash = |
637 | scm_permanent_object (scm_make_doubly_weak_hash_table (SCM_MAKINUM (31))); | |
638 | ||
8dc9439f | 639 | #ifndef SCM_MAGIC_SNARFER |
a0599745 | 640 | #include "libguile/guardians.x" |
8dc9439f | 641 | #endif |
e1f2bf99 | 642 | } |
89e00824 ML |
643 | |
644 | /* | |
645 | Local Variables: | |
646 | c-file-style: "gnu" | |
647 | End: | |
648 | */ |