libguile/guardians.c

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