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