libguile/guardians.c

   1 /* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
   2  *
   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.
   7  *
   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.
  12  *
  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
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  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  *
  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
  34  */
  35
  36
  37 #include "libguile/_scm.h"
  38 #include "libguile/async.h"
  39 #include "libguile/ports.h"
  40 #include "libguile/print.h"
  41 #include "libguile/smob.h"
  42 #include "libguile/validate.h"
  43 #include "libguile/root.h"
  44 #include "libguile/hashtab.h"
  45 #include "libguile/weaks.h"
  46
  47 #include "libguile/guardians.h"
  48
  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 */
  54
  55 typedef struct t_tconc
  56 {
  57   SCM head;
  58   SCM tail;
  59 } t_tconc;
  60
  61 #define TCONC_EMPTYP(tc) (scm_is_eq ((tc).head, (tc).tail))
  62
  63 #define TCONC_IN(tc, obj, pair) \
  64 do { \
  65   SCM_SETCAR ((tc).tail, obj); \
  66   SCM_SET_CELL_OBJECT_1 (pair, SCM_EOL); \
  67   SCM_SET_CELL_OBJECT_0 (pair, SCM_BOOL_F); \
  68   SCM_SETCDR ((tc).tail, pair); \
  69   (tc).tail = pair; \
  70 } while (0)
  71
  72 #define TCONC_OUT(tc, res) \
  73 do { \
  74   (res) = SCM_CAR ((tc).head); \
  75   (tc).head = SCM_CDR ((tc).head); \
  76 } while (0)
  77
  78
  79 static scm_t_bits tc16_guardian;
  80
  81 typedef struct t_guardian
  82 {
  83   t_tconc live;
  84   t_tconc zombies;
  85   struct t_guardian *next;
  86   unsigned long flags;
  87 } t_guardian;
  88
  89 #define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
  90 #define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
  91
  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)
 105
 106 /* during the gc mark phase, live guardians are linked into the lists
 107    here. */
 108 static t_guardian *greedy_guardians = NULL;
 109 static t_guardian *sharing_guardians = NULL;
 110
 111 static SCM greedily_guarded_whash = SCM_EOL;
 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
 118
 119 static void
 120 add_to_live_list (t_guardian *g)
 121 {
 122   if (LISTED_P (g))
 123     return;
 124
 125   if (GREEDY_P (g))
 126     {
 127       g->next = greedy_guardians;
 128       greedy_guardians = g;
 129     }
 130   else
 131     {
 132       g->next = sharing_guardians;
 133       sharing_guardians = g;
 134     }
 135
 136   SET_LISTED (g);
 137 }
 138
 139 /* mark a guardian by adding it to the live guardian list.  */
 140 static SCM
 141 guardian_mark (SCM ptr)
 142 {
 143   add_to_live_list (GUARDIAN_DATA (ptr));
 144
 145   /* the objects protected by the guardian are not marked here: that
 146      would prevent them from ever getting collected.  instead marking
 147      is done at the end of the mark phase by guardian_zombify.  */
 148   return SCM_BOOL_F;
 149 }
 150
 151
 152 static size_t
 153 guardian_free (SCM ptr)
 154 {
 155   scm_gc_free (GUARDIAN_DATA (ptr), sizeof (t_guardian), "guardian");
 156   return 0;
 157 }
 158
 159
 160 static int
 161 guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
 162 {
 163   t_guardian *g = GUARDIAN_DATA (guardian);
 164
 165   scm_puts ("#<", port);
 166
 167   if (DESTROYED_P (g))
 168     scm_puts ("destroyed ", port);
 169
 170   if (GREEDY_P (g))
 171     scm_puts ("greedy", port);
 172   else
 173     scm_puts ("sharing", port);
 174
 175   scm_puts (" guardian 0x", port);
 176   scm_uintprint ((scm_t_bits) g, 16, port);
 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);
 188
 189   return 1;
 190 }
 191
 192
 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.
 201  */
 202 static SCM
 203 guardian_apply (SCM guardian, SCM obj, SCM throw_p)
 204 {
 205   if (DESTROYED_P (GUARDIAN_DATA (guardian)))
 206     scm_misc_error ("guard", "attempted use of destroyed guardian: ~A",
 207                     scm_list_1 (guardian));
 208
 209   if (!SCM_UNBNDP (obj))
 210     return scm_guard (guardian, obj,
 211                       (SCM_UNBNDP (throw_p)
 212                        ? 1
 213                        : scm_is_true (throw_p)));
 214   else
 215     return scm_get_one_zombie (guardian);
 216 }
 217
 218
 219 SCM
 220 scm_guard (SCM guardian, SCM obj, int throw_p)
 221 {
 222   t_guardian *g = GUARDIAN_DATA (guardian);
 223
 224   if (!SCM_IMP (obj))
 225     {
 226       SCM z;
 227
 228       /* This critical section barrier will be replaced by a mutex. */
 229       /* njrev: per comment above, should use a mutex. */
 230       SCM_CRITICAL_SECTION_START;
 231
 232       if (GREEDY_P (g))
 233         {
 234           if (scm_is_true (scm_hashq_get_handle
 235                            (greedily_guarded_whash, obj)))
 236             {
 237               SCM_CRITICAL_SECTION_END;
 238
 239               if (throw_p)
 240                 scm_misc_error ("guard",
 241                                 "object is already greedily guarded: ~A",
 242                                 scm_list_1 (obj));
 243               else
 244                 return SCM_BOOL_F;
 245             }
 246           else
 247             scm_hashq_create_handle_x (greedily_guarded_whash,
 248                                        obj, guardian);
 249           /* njrev: this can throw a memory or out-of-range error. */
 250         }
 251
 252       z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
 253       TCONC_IN (g->live, obj, z);
 254
 255       SCM_CRITICAL_SECTION_END;
 256     }
 257
 258   return throw_p ? SCM_UNSPECIFIED : SCM_BOOL_T;
 259 }
 260
 261
 262 SCM
 263 scm_get_one_zombie (SCM guardian)
 264 {
 265   t_guardian *g = GUARDIAN_DATA (guardian);
 266   SCM res = SCM_BOOL_F;
 267
 268   /* This critical section barrier will be replaced by a mutex. */
 269   SCM_CRITICAL_SECTION_START;
 270   /* njrev: -> mutex */
 271
 272   if (!TCONC_EMPTYP (g->zombies))
 273     TCONC_OUT (g->zombies, res);
 274
 275   if (scm_is_true (res) && GREEDY_P (g))
 276     scm_hashq_remove_x (greedily_guarded_whash, res);
 277
 278   SCM_CRITICAL_SECTION_END;
 279
 280   return res;
 281 }
 282
 283
 284 SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0,
 285             (SCM greedy_p),
 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
 290             "@code{make-guardian} returns a procedure representing the guardian.\n"
 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"
 295             "collection, or @code{#f} if no such object is available.\n"
 296             "Objects which are returned in this way are removed from\n"
 297             "the guardian.\n\n"
 298
 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"
 301             "that any object protected by the guardian may be resurrected,\n"
 302             "then you should make the guardian greedy (this is the default).\n\n"
 303
 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"
 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).")
 311 #define FUNC_NAME s_scm_make_guardian
 312 {
 313   t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
 314   SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL);
 315   SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL);
 316   SCM z;
 317
 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;
 321
 322   g->next = NULL;
 323   g->flags = 0L;
 324
 325   /* [cmm] the UNBNDP check below is redundant but I like it. */
 326   if (SCM_UNBNDP (greedy_p) || scm_is_true (greedy_p))
 327     SET_GREEDY (g);
 328
 329   SCM_NEWSMOB (z, tc16_guardian, g);
 330
 331   return z;
 332 }
 333 #undef FUNC_NAME
 334
 335
 336 SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
 337             (SCM guardian),
 338             "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
 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. */
 344   SCM_CRITICAL_SECTION_START;
 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.) */
 348   res = scm_from_bool (DESTROYED_P (GUARDIAN_DATA (guardian)));
 349
 350   SCM_CRITICAL_SECTION_END;
 351
 352   return res;
 353 }
 354 #undef FUNC_NAME
 355
 356 SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
 357             (SCM guardian),
 358             "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
 359 #define FUNC_NAME s_scm_guardian_greedy_p
 360 {
 361   return scm_from_bool (GREEDY_P (GUARDIAN_DATA (guardian)));
 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 {
 372   t_guardian *g = GUARDIAN_DATA (guardian);
 373
 374   /* This critical section barrier will be replaced by a mutex. */
 375   SCM_CRITICAL_SECTION_START;
 376
 377   if (DESTROYED_P (g))
 378     {
 379       SCM_CRITICAL_SECTION_END;
 380       SCM_MISC_ERROR ("guardian is already destroyed: ~A",
 381                       scm_list_1 (guardian));
 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
 400   SCM_CRITICAL_SECTION_END;
 401
 402   return SCM_UNSPECIFIED;
 403 }
 404 #undef FUNC_NAME
 405
 406 /* called before gc mark phase begins to initialise the live guardian list. */
 407 static void *
 408 guardian_gc_init (void *dummy1 SCM_UNUSED,
 409                   void *dummy2 SCM_UNUSED,
 410                   void *dummy3 SCM_UNUSED)
 411 {
 412   greedy_guardians = sharing_guardians = NULL;
 413
 414   return 0;
 415 }
 416
 417 static void
 418 mark_dependencies_in_tconc (t_tconc *tc)
 419 {
 420   SCM pair, next_pair;
 421   SCM *prev_ptr;
 422
 423   /* scan the list for unmarked objects, and mark their
 424      dependencies */
 425   for (pair = tc->head, prev_ptr = &tc->head;
 426        !scm_is_eq (pair, tc->tail);
 427        pair = next_pair)
 428     {
 429       SCM obj = SCM_CAR (pair);
 430       next_pair = SCM_CDR (pair);
 431
 432       if (! SCM_GC_MARK_P (obj))
 433         {
 434           /* a candidate for finalizing */
 435           scm_gc_mark_dependencies (obj);
 436
 437           if (SCM_GC_MARK_P (obj))
 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;
 444               SCM_SET_GC_MARK (pair);
 445               SCM_SETCDR (pair, self_centered_zombies);
 446               self_centered_zombies = pair;
 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))
 453                 add_to_live_list (GUARDIAN_DATA (obj));
 454
 455               prev_ptr = SCM_CDRLOC (pair);
 456             }
 457         }
 458     }
 459 }
 460
 461 static void
 462 mark_dependencies (t_guardian *g)
 463 {
 464   mark_dependencies_in_tconc (&g->zombies);
 465   mark_dependencies_in_tconc (&g->live);
 466 }
 467
 468 static void
 469 mark_and_zombify (t_guardian *g)
 470 {
 471   SCM tconc_tail = g->live.tail;
 472   SCM *prev_ptr = &g->live.head;
 473   SCM pair = g->live.head;
 474
 475   while (!scm_is_eq (pair, tconc_tail))
 476     {
 477       SCM next_pair = SCM_CDR (pair);
 478
 479       if (!SCM_GC_MARK_P (SCM_CAR (pair)))
 480         {
 481           /* got you, zombie! */
 482
 483           /* out of the live list! */
 484           *prev_ptr = next_pair;
 485
 486           if (GREEDY_P (g))
 487             /* if the guardian is greedy, mark this zombie now.  this
 488                way it won't be zombified again this time around. */
 489             SCM_SET_GC_MARK (SCM_CAR (pair));
 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).  */
 503   for (pair = g->live.head; !scm_is_null (pair); pair = SCM_CDR (pair))
 504     SCM_SET_GC_MARK (pair);
 505 }
 506
 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).  */
 511 static void *
 512 guardian_zombify (void *dummy1 SCM_UNUSED,
 513                   void *dummy2 SCM_UNUSED,
 514                   void *dummy3 SCM_UNUSED)
 515 {
 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;
 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. */
 530
 531   do {
 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);
 546
 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);
 553       CLR_LISTED (g);
 554     }
 555   for (g = sharing_guardians; g; g = g->next)
 556     {
 557       mark_and_zombify (g);
 558       CLR_LISTED (g);
 559     }
 560
 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
 568   return 0;
 569 }
 570
 571 static void *
 572 whine_about_self_centered_zombies (void *dummy1 SCM_UNUSED,
 573                                    void *dummy2 SCM_UNUSED,
 574                                    void *dummy3 SCM_UNUSED)
 575 {
 576   if (!scm_is_null (self_centered_zombies))
 577     {
 578       SCM port = scm_current_error_port ();
 579       SCM pair;
 580
 581       scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:",
 582                 port);
 583       scm_newline (port);
 584       for (pair = self_centered_zombies;
 585            !scm_is_null (pair); pair = SCM_CDR (pair))
 586         {
 587           scm_display (SCM_CAR (pair), port);
 588           scm_newline (port);
 589         }
 590
 591       self_centered_zombies = SCM_EOL;
 592     }
 593
 594   return 0;
 595 }
 596
 597 void
 598 scm_init_guardians ()
 599 {
 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);
 604   scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
 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);
 608
 609   scm_gc_register_root (&self_centered_zombies);
 610   scm_c_hook_add (&scm_after_gc_c_hook,
 611                   whine_about_self_centered_zombies, 0, 0);
 612
 613   greedily_guarded_whash =
 614     scm_permanent_object (scm_make_doubly_weak_hash_table (scm_from_int (31)));
 615
 616 #include "libguile/guardians.x"
 617 }
 618
 619 /*
 620   Local Variables:
 621   c-file-style: "gnu"
 622   End:
 623 */