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