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