| 1 | /* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. |
| 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. */ |
| 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 | |
| 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 | * |
| 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 |
| 61 | */ |
| 62 | |
| 63 | |
| 64 | #include "libguile/_scm.h" |
| 65 | #include "libguile/ports.h" |
| 66 | #include "libguile/print.h" |
| 67 | #include "libguile/smob.h" |
| 68 | #include "libguile/validate.h" |
| 69 | #include "libguile/properties.h" |
| 70 | #include "libguile/root.h" |
| 71 | |
| 72 | #include "libguile/guardians.h" |
| 73 | |
| 74 | |
| 75 | /* The live and zombies FIFOs are implemented as tconcs as described |
| 76 | in Dybvig's paper. This decouples addition and removal of elements |
| 77 | so that no synchronization between these needs to take place. |
| 78 | */ |
| 79 | |
| 80 | typedef struct tconc_t |
| 81 | { |
| 82 | SCM head; |
| 83 | SCM tail; |
| 84 | } tconc_t; |
| 85 | |
| 86 | #define TCONC_EMPTYP(tc) (SCM_EQ_P ((tc).head, (tc).tail)) |
| 87 | |
| 88 | #define TCONC_IN(tc, obj, pair) \ |
| 89 | do { \ |
| 90 | SCM_SETCAR ((tc).tail, obj); \ |
| 91 | SCM_SETCAR (pair, SCM_BOOL_F); \ |
| 92 | SCM_SETCDR (pair, SCM_EOL); \ |
| 93 | SCM_SETCDR ((tc).tail, pair); \ |
| 94 | (tc).tail = pair; \ |
| 95 | } while (0) |
| 96 | |
| 97 | #define TCONC_OUT(tc, res) \ |
| 98 | do { \ |
| 99 | (res) = SCM_CAR ((tc).head); \ |
| 100 | (tc).head = SCM_CDR ((tc).head); \ |
| 101 | } while (0) |
| 102 | |
| 103 | |
| 104 | static scm_bits_t tc16_guardian; |
| 105 | |
| 106 | typedef struct guardian_t |
| 107 | { |
| 108 | tconc_t live; |
| 109 | tconc_t zombies; |
| 110 | struct guardian_t *next; |
| 111 | int greedy_p; |
| 112 | int listed_p; |
| 113 | } guardian_t; |
| 114 | |
| 115 | #define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x) |
| 116 | #define GUARDIAN(x) ((guardian_t *) SCM_CELL_WORD_1 (x)) |
| 117 | #define GUARDIAN_LIVE(x) (GUARDIAN (x)->live) |
| 118 | #define GUARDIAN_ZOMBIES(x) (GUARDIAN (x)->zombies) |
| 119 | #define GUARDIAN_NEXT(x) (GUARDIAN (x)->next) |
| 120 | #define GUARDIAN_GREEDY_P(x) (GUARDIAN (x)->greedy_p) |
| 121 | #define GUARDIAN_LISTED_P(x) (GUARDIAN (x)->listed_p) |
| 122 | |
| 123 | |
| 124 | /* during the gc mark phase, live guardians are linked into the lists |
| 125 | here. */ |
| 126 | static guardian_t *greedy_guardians = NULL; |
| 127 | static guardian_t *sharing_guardians = NULL; |
| 128 | |
| 129 | /* greedily guarded objects have this property set, so that we can |
| 130 | catch any attempt to greedily guard them again */ |
| 131 | static SCM greedily_guarded_prop = SCM_EOL; |
| 132 | |
| 133 | /* this is the list of guarded objects that are parts of cycles. we |
| 134 | don't know in which order to return them from guardians, so we just |
| 135 | unguard them and whine about it in after-gc-hook */ |
| 136 | static SCM self_centered_zombies = SCM_EOL; |
| 137 | |
| 138 | |
| 139 | static void |
| 140 | add_to_live_list (SCM g) |
| 141 | { |
| 142 | if (GUARDIAN_LISTED_P (g)) |
| 143 | return; |
| 144 | |
| 145 | if (GUARDIAN_GREEDY_P (g)) |
| 146 | { |
| 147 | GUARDIAN_NEXT (g) = greedy_guardians; |
| 148 | greedy_guardians = GUARDIAN (g); |
| 149 | } |
| 150 | else |
| 151 | { |
| 152 | GUARDIAN_NEXT (g) = sharing_guardians; |
| 153 | sharing_guardians = GUARDIAN (g); |
| 154 | } |
| 155 | |
| 156 | GUARDIAN_LISTED_P (g) = 1; |
| 157 | } |
| 158 | |
| 159 | /* mark a guardian by adding it to the live guardian list. */ |
| 160 | static SCM |
| 161 | guardian_mark (SCM ptr) |
| 162 | { |
| 163 | add_to_live_list (ptr); |
| 164 | |
| 165 | /* the objects protected by the guardian are not marked here: that |
| 166 | would prevent them from ever getting collected. instead marking |
| 167 | is done at the end of the mark phase by guardian_zombify. */ |
| 168 | return SCM_BOOL_F; |
| 169 | } |
| 170 | |
| 171 | |
| 172 | static scm_sizet |
| 173 | guardian_free (SCM ptr) |
| 174 | { |
| 175 | scm_must_free (GUARDIAN (ptr)); |
| 176 | return sizeof (guardian_t); |
| 177 | } |
| 178 | |
| 179 | |
| 180 | static int |
| 181 | guardian_print (SCM g, SCM port, scm_print_state *pstate) |
| 182 | { |
| 183 | scm_puts ("#<", port); |
| 184 | if (GUARDIAN_GREEDY_P (g)) |
| 185 | scm_puts ("greedy ", port); |
| 186 | scm_puts ("guardian (reachable: ", port); |
| 187 | scm_display (scm_length (SCM_CDR (GUARDIAN_LIVE (g).head)), port); |
| 188 | scm_puts (" unreachable: ", port); |
| 189 | scm_display (scm_length (SCM_CDR (GUARDIAN_ZOMBIES (g).head)), port); |
| 190 | scm_puts (")>", port); |
| 191 | |
| 192 | return 1; |
| 193 | } |
| 194 | |
| 195 | |
| 196 | /* This is the Scheme entry point for each guardian: If arg is an object, it's |
| 197 | * added to the guardian's live list. If arg is unbound, the next available |
| 198 | * zombified object (or #f if none) is returned. |
| 199 | */ |
| 200 | static SCM |
| 201 | guardian_apply (SCM guardian, SCM arg) |
| 202 | { |
| 203 | if (!SCM_UNBNDP (arg)) |
| 204 | { |
| 205 | scm_guard (guardian, arg); |
| 206 | return SCM_UNSPECIFIED; |
| 207 | } |
| 208 | else |
| 209 | return scm_get_one_zombie (guardian); |
| 210 | } |
| 211 | |
| 212 | |
| 213 | void |
| 214 | scm_guard (SCM guardian, SCM obj) |
| 215 | { |
| 216 | if (!SCM_IMP (obj)) |
| 217 | { |
| 218 | SCM z; |
| 219 | |
| 220 | if (GUARDIAN_GREEDY_P (guardian)) |
| 221 | { |
| 222 | if (SCM_NFALSEP (scm_primitive_property_ref |
| 223 | (greedily_guarded_prop, obj))) |
| 224 | scm_misc_error ("guard", |
| 225 | "object is already greedily guarded", obj); |
| 226 | else |
| 227 | scm_primitive_property_set_x (greedily_guarded_prop, |
| 228 | obj, SCM_BOOL_T); |
| 229 | } |
| 230 | |
| 231 | SCM_NEWCELL (z); |
| 232 | |
| 233 | /* This critical section barrier will be replaced by a mutex. */ |
| 234 | SCM_DEFER_INTS; |
| 235 | TCONC_IN (GUARDIAN_LIVE (guardian), obj, z); |
| 236 | SCM_ALLOW_INTS; |
| 237 | } |
| 238 | } |
| 239 | |
| 240 | |
| 241 | SCM |
| 242 | scm_get_one_zombie (SCM guardian) |
| 243 | { |
| 244 | SCM res = SCM_BOOL_F; |
| 245 | |
| 246 | /* This critical section barrier will be replaced by a mutex. */ |
| 247 | SCM_DEFER_INTS; |
| 248 | if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (guardian))) |
| 249 | TCONC_OUT (GUARDIAN_ZOMBIES (guardian), res); |
| 250 | SCM_ALLOW_INTS; |
| 251 | |
| 252 | if (SCM_NFALSEP (res) |
| 253 | && GUARDIAN_GREEDY_P (guardian) |
| 254 | && SCM_NFALSEP (scm_primitive_property_ref |
| 255 | (greedily_guarded_prop, res))) |
| 256 | scm_primitive_property_del_x (greedily_guarded_prop, res); |
| 257 | |
| 258 | return res; |
| 259 | } |
| 260 | |
| 261 | |
| 262 | SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0, |
| 263 | (SCM greedy_p), |
| 264 | "Create a new guardian.\n" |
| 265 | "A guardian protects a set of objects from garbage collection,\n" |
| 266 | "allowing a program to apply cleanup or other actions.\n\n" |
| 267 | |
| 268 | "make-guardian returns a procedure representing the guardian.\n" |
| 269 | "Calling the guardian procedure with an argument adds the\n" |
| 270 | "argument to the guardian's set of protected objects.\n" |
| 271 | "Calling the guardian procedure without an argument returns\n" |
| 272 | "one of the protected objects which are ready for garbage\n" |
| 273 | "collection or @code{#f} if no such object is available.\n" |
| 274 | "Objects which are returned in this way are removed from\n" |
| 275 | "the guardian.\n\n" |
| 276 | |
| 277 | "make-guardian takes one optional argument that says whether the\n" |
| 278 | "new guardian should be greedy or not. if there is any chance\n" |
| 279 | "that any object protected by the guardian may be resurrected,\n" |
| 280 | "then make the guardian greedy (this is the default).\n\n" |
| 281 | |
| 282 | "See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993)\n" |
| 283 | "\"Guardians in a Generation-Based Garbage Collector\".\n" |
| 284 | "ACM SIGPLAN Conference on Programming Language Design\n" |
| 285 | "and Implementation, June 1993.\n\n" |
| 286 | |
| 287 | "(the semantics are slightly different at this point, but the\n" |
| 288 | "paper still (mostly) accurately describes the interface).") |
| 289 | #define FUNC_NAME s_scm_make_guardian |
| 290 | { |
| 291 | guardian_t *g = SCM_MUST_MALLOC_TYPE (guardian_t); |
| 292 | SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL); |
| 293 | SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL); |
| 294 | SCM z; |
| 295 | |
| 296 | /* A tconc starts out with one tail pair. */ |
| 297 | g->live.head = g->live.tail = z1; |
| 298 | g->zombies.head = g->zombies.tail = z2; |
| 299 | g->listed_p = 0; |
| 300 | |
| 301 | if (SCM_UNBNDP (greedy_p)) |
| 302 | g->greedy_p = 1; |
| 303 | else |
| 304 | g->greedy_p = SCM_NFALSEP (greedy_p); |
| 305 | |
| 306 | SCM_NEWSMOB (z, tc16_guardian, g); |
| 307 | |
| 308 | return z; |
| 309 | } |
| 310 | #undef FUNC_NAME |
| 311 | |
| 312 | |
| 313 | /* called before gc mark phase begins to initialise the live guardian list. */ |
| 314 | static void * |
| 315 | guardian_gc_init (void *dummy1, void *dummy2, void *dummy3) |
| 316 | { |
| 317 | greedy_guardians = sharing_guardians = NULL; |
| 318 | |
| 319 | return 0; |
| 320 | } |
| 321 | |
| 322 | static void |
| 323 | mark_dependencies (guardian_t *g) |
| 324 | { |
| 325 | SCM pair, next_pair; |
| 326 | SCM *prev_ptr; |
| 327 | |
| 328 | /* scan the live list for unmarked objects, and mark their |
| 329 | dependencies */ |
| 330 | for (pair = g->live.head, prev_ptr = &g->live.head; |
| 331 | ! SCM_EQ_P (pair, g->live.tail); |
| 332 | pair = next_pair) |
| 333 | { |
| 334 | SCM obj = SCM_CAR (pair); |
| 335 | next_pair = SCM_CDR (pair); |
| 336 | |
| 337 | if (! SCM_MARKEDP (obj)) |
| 338 | { |
| 339 | /* a candidate for finalizing */ |
| 340 | scm_gc_mark_dependencies (obj); |
| 341 | |
| 342 | if (SCM_MARKEDP (obj)) |
| 343 | { |
| 344 | /* uh oh. a cycle. transfer this object (the |
| 345 | spine cell, to be exact) to |
| 346 | self_centered_zombies, so we'll be able to |
| 347 | complain about it later. */ |
| 348 | *prev_ptr = next_pair; |
| 349 | SCM_SETGCMARK (pair); |
| 350 | SCM_SETCDR (pair, SCM_CDR (self_centered_zombies)); |
| 351 | SCM_SETCDR (self_centered_zombies, pair); |
| 352 | } |
| 353 | else |
| 354 | { |
| 355 | /* see if this is a guardian. if yes, list it (but don't |
| 356 | mark it yet). */ |
| 357 | if (GUARDIAN_P (obj)) |
| 358 | add_to_live_list (obj); |
| 359 | |
| 360 | prev_ptr = SCM_CDRLOC (pair); |
| 361 | } |
| 362 | } |
| 363 | } |
| 364 | } |
| 365 | |
| 366 | static void |
| 367 | mark_and_zombify (guardian_t *g) |
| 368 | { |
| 369 | SCM tconc_tail = g->live.tail; |
| 370 | SCM *prev_ptr = &g->live.head; |
| 371 | SCM pair = g->live.head; |
| 372 | |
| 373 | while (! SCM_EQ_P (pair, tconc_tail)) |
| 374 | { |
| 375 | SCM next_pair = SCM_CDR (pair); |
| 376 | |
| 377 | if (SCM_NMARKEDP (SCM_CAR (pair))) |
| 378 | { |
| 379 | /* got you, zombie! */ |
| 380 | |
| 381 | /* out of the live list! */ |
| 382 | *prev_ptr = next_pair; |
| 383 | |
| 384 | if (g->greedy_p) |
| 385 | /* if the guardian is greedy, mark this zombie now. this |
| 386 | way it won't be zombified again this time around. */ |
| 387 | SCM_SETGCMARK (SCM_CAR (pair)); |
| 388 | |
| 389 | /* into the zombie list! */ |
| 390 | TCONC_IN (g->zombies, SCM_CAR (pair), pair); |
| 391 | } |
| 392 | else |
| 393 | prev_ptr = SCM_CDRLOC (pair); |
| 394 | |
| 395 | pair = next_pair; |
| 396 | } |
| 397 | |
| 398 | /* Mark the cells of the live list (yes, the cells in the list, we |
| 399 | don't care about objects pointed to by the list cars, since we |
| 400 | know they are already marked). */ |
| 401 | for (pair = g->live.head; !SCM_NULLP (pair); pair = SCM_CDR (pair)) |
| 402 | SCM_SETGCMARK (pair); |
| 403 | } |
| 404 | |
| 405 | |
| 406 | /* this is called by the garbage collector between the mark and sweep |
| 407 | phases. for each marked guardian, it moves any unmarked object in |
| 408 | its live list (tconc) to its zombie list (tconc). */ |
| 409 | static void * |
| 410 | guardian_zombify (void *dummy1, void *dummy2, void *dummy3) |
| 411 | { |
| 412 | guardian_t *last_greedy_guardian = NULL; |
| 413 | guardian_t *last_sharing_guardian = NULL; |
| 414 | guardian_t *first_greedy_guardian = NULL; |
| 415 | guardian_t *first_sharing_guardian = NULL; |
| 416 | guardian_t *g; |
| 417 | |
| 418 | /* First, find all newly unreachable objects and mark their |
| 419 | dependencies. |
| 420 | |
| 421 | Note that new guardians may be stuck on the end of the live |
| 422 | guardian lists as we run this loop, since guardians might be |
| 423 | guarded too. When we mark a guarded guardian, its mark function |
| 424 | sticks in the appropriate live guardian list. The loop |
| 425 | terminates when no new guardians are found. */ |
| 426 | |
| 427 | do { |
| 428 | first_greedy_guardian = greedy_guardians; |
| 429 | first_sharing_guardian = sharing_guardians; |
| 430 | |
| 431 | for (g = greedy_guardians; g != last_greedy_guardian; |
| 432 | g = g->next) |
| 433 | mark_dependencies (g); |
| 434 | for (g = sharing_guardians; g != last_sharing_guardian; |
| 435 | g = g->next) |
| 436 | mark_dependencies (g); |
| 437 | |
| 438 | last_greedy_guardian = first_greedy_guardian; |
| 439 | last_sharing_guardian = first_sharing_guardian; |
| 440 | } while (first_greedy_guardian != greedy_guardians |
| 441 | || first_sharing_guardian != sharing_guardians); |
| 442 | |
| 443 | /* now, scan all the guardians that are currently known to be live |
| 444 | and move their unmarked objects to zombie lists. */ |
| 445 | |
| 446 | for (g = greedy_guardians; g; g = g->next) |
| 447 | { |
| 448 | mark_and_zombify (g); |
| 449 | g->listed_p = 0; |
| 450 | } |
| 451 | for (g = sharing_guardians; g; g = g->next) |
| 452 | { |
| 453 | mark_and_zombify (g); |
| 454 | g->listed_p = 0; |
| 455 | } |
| 456 | |
| 457 | /* Preserve the zombies in their undead state, by marking to prevent |
| 458 | collection. */ |
| 459 | for (g = greedy_guardians; g; g = g->next) |
| 460 | scm_gc_mark (g->zombies.head); |
| 461 | for (g = sharing_guardians; g; g = g->next) |
| 462 | scm_gc_mark (g->zombies.head); |
| 463 | |
| 464 | return 0; |
| 465 | } |
| 466 | |
| 467 | static void * |
| 468 | whine_about_self_centered_zombies (void *dummy1, void *dummy2, void *dummy3) |
| 469 | { |
| 470 | if (! SCM_NULLP (SCM_CDR (self_centered_zombies))) |
| 471 | { |
| 472 | SCM pair; |
| 473 | |
| 474 | scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:", |
| 475 | scm_cur_errp); |
| 476 | scm_newline (scm_cur_errp); |
| 477 | for (pair = SCM_CDR (self_centered_zombies); |
| 478 | ! SCM_NULLP (pair); pair = SCM_CDR (pair)) |
| 479 | { |
| 480 | scm_display (SCM_CAR (pair), scm_cur_errp); |
| 481 | scm_newline (scm_cur_errp); |
| 482 | } |
| 483 | |
| 484 | SCM_SETCDR (self_centered_zombies, SCM_EOL); |
| 485 | } |
| 486 | |
| 487 | return 0; |
| 488 | } |
| 489 | |
| 490 | void |
| 491 | scm_init_guardians () |
| 492 | { |
| 493 | tc16_guardian = scm_make_smob_type ("guardian", 0); |
| 494 | scm_set_smob_mark (tc16_guardian, guardian_mark); |
| 495 | scm_set_smob_free (tc16_guardian, guardian_free); |
| 496 | scm_set_smob_print (tc16_guardian, guardian_print); |
| 497 | scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0); |
| 498 | |
| 499 | scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0); |
| 500 | scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0); |
| 501 | |
| 502 | greedily_guarded_prop = |
| 503 | scm_permanent_object (scm_primitive_make_property (SCM_BOOL_F)); |
| 504 | |
| 505 | self_centered_zombies = |
| 506 | scm_permanent_object (scm_cons (SCM_UNDEFINED, SCM_EOL)); |
| 507 | scm_c_hook_add (&scm_after_gc_c_hook, |
| 508 | whine_about_self_centered_zombies, 0, 0); |
| 509 | |
| 510 | #ifndef SCM_MAGIC_SNARFER |
| 511 | #include "libguile/guardians.x" |
| 512 | #endif |
| 513 | } |
| 514 | |
| 515 | /* |
| 516 | Local Variables: |
| 517 | c-file-style: "gnu" |
| 518 | End: |
| 519 | */ |