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/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       SCM_CRITICAL_SECTION_START;
 230
 231       if (GREEDY_P (g))
 232         {
 233           if (scm_is_true (scm_hashq_get_handle
 234                            (greedily_guarded_whash, obj)))
 235             {
 236               SCM_CRITICAL_SECTION_END;
 237
 238               if (throw_p)
 239                 scm_misc_error ("guard",
 240                                 "object is already greedily guarded: ~A",
 241                                 scm_list_1 (obj));
 242               else
 243                 return SCM_BOOL_F;
 244             }
 245           else
 246             scm_hashq_create_handle_x (greedily_guarded_whash,
 247                                        obj, guardian);
 248         }
 249
 250       z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
 251       TCONC_IN (g->live, obj, z);
 252
 253       SCM_CRITICAL_SECTION_END;
 254     }
 255
 256   return throw_p ? SCM_UNSPECIFIED : SCM_BOOL_T;
 257 }
 258
 259
 260 SCM
 261 scm_get_one_zombie (SCM guardian)
 262 {
 263   t_guardian *g = GUARDIAN_DATA (guardian);
 264   SCM res = SCM_BOOL_F;
 265
 266   /* This critical section barrier will be replaced by a mutex. */
 267   SCM_CRITICAL_SECTION_START;
 268
 269   if (!TCONC_EMPTYP (g->zombies))
 270     TCONC_OUT (g->zombies, res);
 271
 272   if (scm_is_true (res) && GREEDY_P (g))
 273     scm_hashq_remove_x (greedily_guarded_whash, res);
 274
 275   SCM_CRITICAL_SECTION_END;
 276
 277   return res;
 278 }
 279
 280
 281 SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0,
 282             (SCM greedy_p),
 283             "Create a new guardian.\n"
 284             "A guardian protects a set of objects from garbage collection,\n"
 285             "allowing a program to apply cleanup or other actions.\n\n"
 286
 287             "@code{make-guardian} returns a procedure representing the guardian.\n"
 288             "Calling the guardian procedure with an argument adds the\n"
 289             "argument to the guardian's set of protected objects.\n"
 290             "Calling the guardian procedure without an argument returns\n"
 291             "one of the protected objects which are ready for garbage\n"
 292             "collection, or @code{#f} if no such object is available.\n"
 293             "Objects which are returned in this way are removed from\n"
 294             "the guardian.\n\n"
 295
 296             "@code{make-guardian} takes one optional argument that says whether the\n"
 297             "new guardian should be greedy or sharing.  If there is any chance\n"
 298             "that any object protected by the guardian may be resurrected,\n"
 299             "then you should make the guardian greedy (this is the default).\n\n"
 300
 301             "See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993)\n"
 302             "\"Guardians in a Generation-Based Garbage Collector\".\n"
 303             "ACM SIGPLAN Conference on Programming Language Design\n"
 304             "and Implementation, June 1993.\n\n"
 305
 306             "(the semantics are slightly different at this point, but the\n"
 307             "paper still (mostly) accurately describes the interface).")
 308 #define FUNC_NAME s_scm_make_guardian
 309 {
 310   t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
 311   SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL);
 312   SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL);
 313   SCM z;
 314
 315   /* A tconc starts out with one tail pair. */
 316   g->live.head = g->live.tail = z1;
 317   g->zombies.head = g->zombies.tail = z2;
 318
 319   g->next = NULL;
 320   g->flags = 0L;
 321
 322   /* [cmm] the UNBNDP check below is redundant but I like it. */
 323   if (SCM_UNBNDP (greedy_p) || scm_is_true (greedy_p))
 324     SET_GREEDY (g);
 325
 326   SCM_NEWSMOB (z, tc16_guardian, g);
 327
 328   return z;
 329 }
 330 #undef FUNC_NAME
 331
 332
 333 SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
 334             (SCM guardian),
 335             "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
 336 #define FUNC_NAME s_scm_guardian_destroyed_p
 337 {
 338   SCM res = SCM_BOOL_F;
 339
 340   /* This critical section barrier will be replaced by a mutex. */
 341   SCM_CRITICAL_SECTION_START;
 342
 343   res = scm_from_bool (DESTROYED_P (GUARDIAN_DATA (guardian)));
 344
 345   SCM_CRITICAL_SECTION_END;
 346
 347   return res;
 348 }
 349 #undef FUNC_NAME
 350
 351 SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
 352             (SCM guardian),
 353             "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
 354 #define FUNC_NAME s_scm_guardian_greedy_p
 355 {
 356   return scm_from_bool (GREEDY_P (GUARDIAN_DATA (guardian)));
 357 }
 358 #undef FUNC_NAME
 359
 360 SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
 361             (SCM guardian),
 362             "Destroys @var{guardian}, by making it impossible to put any more\n"
 363             "objects in it or get any objects from it.  It also unguards any\n"
 364             "objects guarded by @var{guardian}.")
 365 #define FUNC_NAME s_scm_destroy_guardian_x
 366 {
 367   t_guardian *g = GUARDIAN_DATA (guardian);
 368
 369   /* This critical section barrier will be replaced by a mutex. */
 370   SCM_CRITICAL_SECTION_START;
 371
 372   if (DESTROYED_P (g))
 373     {
 374       SCM_CRITICAL_SECTION_END;
 375       SCM_MISC_ERROR ("guardian is already destroyed: ~A",
 376                       scm_list_1 (guardian));
 377     }
 378
 379   if (GREEDY_P (g))
 380     {
 381       /* clear the "greedily guarded" property of the objects */
 382       SCM pair;
 383       for (pair = g->live.head; pair != g->live.tail; pair = SCM_CDR (pair))
 384         scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair));
 385       for (pair = g->zombies.head; pair != g->zombies.tail; pair = SCM_CDR (pair))
 386         scm_hashq_remove_x (greedily_guarded_whash, SCM_CAR (pair));
 387     }
 388
 389   /* empty the lists */
 390   g->live.head = g->live.tail;
 391   g->zombies.head = g->zombies.tail;
 392
 393   SET_DESTROYED (g);
 394
 395   SCM_CRITICAL_SECTION_END;
 396
 397   return SCM_UNSPECIFIED;
 398 }
 399 #undef FUNC_NAME
 400
 401 /* called before gc mark phase begins to initialise the live guardian list. */
 402 static void *
 403 guardian_gc_init (void *dummy1 SCM_UNUSED,
 404                   void *dummy2 SCM_UNUSED,
 405                   void *dummy3 SCM_UNUSED)
 406 {
 407   greedy_guardians = sharing_guardians = NULL;
 408
 409   return 0;
 410 }
 411
 412 static void
 413 mark_dependencies_in_tconc (t_tconc *tc)
 414 {
 415   SCM pair, next_pair;
 416   SCM *prev_ptr;
 417
 418   /* scan the list for unmarked objects, and mark their
 419      dependencies */
 420   for (pair = tc->head, prev_ptr = &tc->head;
 421        !scm_is_eq (pair, tc->tail);
 422        pair = next_pair)
 423     {
 424       SCM obj = SCM_CAR (pair);
 425       next_pair = SCM_CDR (pair);
 426
 427       if (! SCM_GC_MARK_P (obj))
 428         {
 429           /* a candidate for finalizing */
 430           scm_gc_mark_dependencies (obj);
 431
 432           if (SCM_GC_MARK_P (obj))
 433             {
 434               /* uh oh.  a cycle.  transfer this object (the
 435                  spine cell, to be exact) to
 436                  self_centered_zombies, so we'll be able to
 437                  complain about it later. */
 438               *prev_ptr = next_pair;
 439               SCM_SET_GC_MARK (pair);
 440               SCM_SETCDR (pair, self_centered_zombies);
 441               self_centered_zombies = pair;
 442             }
 443           else
 444             {
 445               /* see if this is a guardian.  if yes, list it (but don't
 446                  mark it yet). */
 447               if (GUARDIAN_P (obj))
 448                 add_to_live_list (GUARDIAN_DATA (obj));
 449
 450               prev_ptr = SCM_CDRLOC (pair);
 451             }
 452         }
 453     }
 454 }
 455
 456 static void
 457 mark_dependencies (t_guardian *g)
 458 {
 459   mark_dependencies_in_tconc (&g->zombies);
 460   mark_dependencies_in_tconc (&g->live);
 461 }
 462
 463 static void
 464 mark_and_zombify (t_guardian *g)
 465 {
 466   SCM tconc_tail = g->live.tail;
 467   SCM *prev_ptr = &g->live.head;
 468   SCM pair = g->live.head;
 469
 470   while (!scm_is_eq (pair, tconc_tail))
 471     {
 472       SCM next_pair = SCM_CDR (pair);
 473
 474       if (!SCM_GC_MARK_P (SCM_CAR (pair)))
 475         {
 476           /* got you, zombie! */
 477
 478           /* out of the live list! */
 479           *prev_ptr = next_pair;
 480
 481           if (GREEDY_P (g))
 482             /* if the guardian is greedy, mark this zombie now.  this
 483                way it won't be zombified again this time around. */
 484             SCM_SET_GC_MARK (SCM_CAR (pair));
 485
 486           /* into the zombie list! */
 487           TCONC_IN (g->zombies, SCM_CAR (pair), pair);
 488         }
 489       else
 490         prev_ptr = SCM_CDRLOC (pair);
 491
 492       pair = next_pair;
 493     }
 494
 495   /* Mark the cells of the live list (yes, the cells in the list, we
 496      don't care about objects pointed to by the list cars, since we
 497      know they are already marked).  */
 498   for (pair = g->live.head; !scm_is_null (pair); pair = SCM_CDR (pair))
 499     SCM_SET_GC_MARK (pair);
 500 }
 501
 502
 503 /* this is called by the garbage collector between the mark and sweep
 504    phases.  for each marked guardian, it moves any unmarked object in
 505    its live list (tconc) to its zombie list (tconc).  */
 506 static void *
 507 guardian_zombify (void *dummy1 SCM_UNUSED,
 508                   void *dummy2 SCM_UNUSED,
 509                   void *dummy3 SCM_UNUSED)
 510 {
 511   t_guardian *last_greedy_guardian = NULL;
 512   t_guardian *last_sharing_guardian = NULL;
 513   t_guardian *first_greedy_guardian = NULL;
 514   t_guardian *first_sharing_guardian = NULL;
 515   t_guardian *g;
 516
 517   /* First, find all newly unreachable objects and mark their
 518      dependencies.
 519
 520      Note that new guardians may be stuck on the end of the live
 521      guardian lists as we run this loop, since guardians might be
 522      guarded too.  When we mark a guarded guardian, its mark function
 523      sticks in the appropriate live guardian list.  The loop
 524      terminates when no new guardians are found. */
 525
 526   do {
 527     first_greedy_guardian = greedy_guardians;
 528     first_sharing_guardian = sharing_guardians;
 529
 530     for (g = greedy_guardians; g != last_greedy_guardian;
 531          g = g->next)
 532       mark_dependencies (g);
 533     for (g = sharing_guardians; g != last_sharing_guardian;
 534          g = g->next)
 535       mark_dependencies (g);
 536
 537     last_greedy_guardian = first_greedy_guardian;
 538     last_sharing_guardian = first_sharing_guardian;
 539   } while (first_greedy_guardian != greedy_guardians
 540            || first_sharing_guardian != sharing_guardians);
 541
 542   /* now, scan all the guardians that are currently known to be live
 543      and move their unmarked objects to zombie lists. */
 544
 545   for (g = greedy_guardians; g; g = g->next)
 546     {
 547       mark_and_zombify (g);
 548       CLR_LISTED (g);
 549     }
 550   for (g = sharing_guardians; g; g = g->next)
 551     {
 552       mark_and_zombify (g);
 553       CLR_LISTED (g);
 554     }
 555
 556   /* Preserve the zombies in their undead state, by marking to prevent
 557      collection. */
 558   for (g = greedy_guardians; g; g = g->next)
 559     scm_gc_mark (g->zombies.head);
 560   for (g = sharing_guardians; g; g = g->next)
 561     scm_gc_mark (g->zombies.head);
 562
 563   return 0;
 564 }
 565
 566 static void *
 567 whine_about_self_centered_zombies (void *dummy1 SCM_UNUSED,
 568                                    void *dummy2 SCM_UNUSED,
 569                                    void *dummy3 SCM_UNUSED)
 570 {
 571   if (!scm_is_null (self_centered_zombies))
 572     {
 573       SCM port = scm_current_error_port ();
 574       SCM pair;
 575
 576       scm_puts ("** WARNING: the following guarded objects were unguarded due to cycles:",
 577                 port);
 578       scm_newline (port);
 579       for (pair = self_centered_zombies;
 580            !scm_is_null (pair); pair = SCM_CDR (pair))
 581         {
 582           scm_display (SCM_CAR (pair), port);
 583           scm_newline (port);
 584         }
 585
 586       self_centered_zombies = SCM_EOL;
 587     }
 588
 589   return 0;
 590 }
 591
 592 void
 593 scm_init_guardians ()
 594 {
 595   tc16_guardian = scm_make_smob_type ("guardian", 0);
 596   scm_set_smob_mark (tc16_guardian, guardian_mark);
 597   scm_set_smob_free (tc16_guardian, guardian_free);
 598   scm_set_smob_print (tc16_guardian, guardian_print);
 599   scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
 600
 601   scm_c_hook_add (&scm_before_mark_c_hook, guardian_gc_init, 0, 0);
 602   scm_c_hook_add (&scm_before_sweep_c_hook, guardian_zombify, 0, 0);
 603
 604   scm_gc_register_root (&self_centered_zombies);
 605   scm_c_hook_add (&scm_after_gc_c_hook,
 606                   whine_about_self_centered_zombies, 0, 0);
 607
 608   greedily_guarded_whash =
 609     scm_permanent_object (scm_make_doubly_weak_hash_table (scm_from_int (31)));
 610
 611 #include "libguile/guardians.x"
 612 }
 613
 614 /*
 615   Local Variables:
 616   c-file-style: "gnu"
 617   End:
 618 */