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