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