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