libguile/guardians.c

   1 /*      Copyright (C) 1998 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 \f
  42
  43 /* This is an implementation of guardians as described in
  44  * R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
  45  * a Generation-Based Garbage Collector" ACM SIGPLAN Conference on
  46  * Programming Language Design and Implementation, June 1993
  47  * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
  48  *
  49  * Author:      Michael N. Livshin
  50  * Modified by: Mikael Djurfeldt
  51  */
  52
  53 #include <stdio.h>
  54 #include <assert.h>
  55
  56 #include "_scm.h"
  57 #include "print.h"
  58 #include "smob.h"
  59 #include "genio.h"
  60
  61 #include "guardians.h"
  62
  63 static long scm_tc16_guardian;
  64
  65 /* The live and zombies FIFOs are implemented as tconcs as described
  66    in Dybvig's paper.  This decouples addition and removal of elements
  67    so that no synchronization between these needs to take place.
  68 */
  69 #define TCONC_IN(tc, obj, pair) \
  70 { \
  71   SCM_SETCAR ((tc).tail, obj); \
  72   SCM_SETCAR (pair, SCM_BOOL_F); \
  73   SCM_SETCDR (pair, SCM_BOOL_F); \
  74   SCM_SETCDR ((tc).tail, pair); \
  75   (tc).tail = pair; \
  76 } \
  77
  78 #define TCONC_OUT(tc, res) \
  79 { \
  80   (res) = SCM_CAR ((tc).head); \
  81   (tc).head = SCM_CDR ((tc).head); \
  82 } \
  83
  84 #define TCONC_EMPTYP(tc) ((tc).head == (tc).tail)
  85
  86 typedef struct tconc_t
  87 {
  88   SCM head;
  89   SCM tail;
  90 } tconc_t;
  91
  92 typedef struct guardian_t
  93 {
  94   tconc_t live;
  95   tconc_t zombies;
  96 } guardian_t;
  97
  98 #define GUARDIAN(x) ((guardian_t *) SCM_CDR (x))
  99 #define GUARDIAN_LIVE(x) (GUARDIAN (x)->live)
 100 #define GUARDIAN_ZOMBIES(x) (GUARDIAN (x)->zombies)
 101
 102 static SCM *guardians = NULL;
 103 static scm_sizet guardians_size = 0;
 104 static scm_sizet n_guardians;
 105
 106 static SCM
 107 g_mark (SCM ptr)
 108 {
 109   if (n_guardians >= guardians_size)
 110     {
 111       SCM_SYSCALL (guardians =
 112                    (SCM *) realloc((char *) guardians,
 113                                    sizeof (SCM) * (guardians_size *= 2)));
 114       if (!guardians)
 115         {
 116           scm_puts ("active guardian table", scm_cur_errp);
 117           scm_puts ("\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
 118                     scm_cur_errp);
 119           exit (SCM_EXIT_FAILURE);
 120         }
 121     }
 122   guardians[n_guardians++] = ptr;
 123   /* Can't mark zombies here since they can refer to objects which are
 124      living dead, thereby preventing them to join the zombies. */
 125   return SCM_BOOL_F;
 126 }
 127
 128 static scm_sizet
 129 g_free (SCM ptr)
 130 {
 131   scm_must_free ((char *) GUARDIAN (ptr));
 132   return sizeof (guardian_t);
 133 }
 134
 135 static int
 136 g_print (SCM exp, SCM port, scm_print_state *pstate)
 137 {
 138   char buf[256];
 139   sprintf (buf, "#<guardian live objs: %lu zombies: %lu>",
 140            scm_ilength (SCM_CDR (GUARDIAN_LIVE (exp).head)),
 141            scm_ilength (SCM_CDR (GUARDIAN_ZOMBIES (exp).head)));
 142   scm_puts (buf, port);
 143
 144   return 1;
 145 }
 146
 147 static scm_smobfuns g_smob = {
 148   g_mark,
 149   g_free,
 150   g_print,
 151   0 /* g_equalp */
 152 };
 153
 154 #define CCLO_G(cclo) (SCM_VELTS (cclo)[1])
 155
 156 static SCM
 157 guard (SCM cclo, SCM arg)
 158 {
 159   if (!SCM_UNBNDP (arg))
 160     {
 161       scm_guard (cclo, arg);
 162       return SCM_UNSPECIFIED;
 163     }
 164   else
 165     return scm_get_one_zombie (cclo);
 166 }
 167
 168 static SCM guard1;
 169
 170 SCM_PROC (s_make_guardian, "make-guardian", 0, 0, 0, scm_make_guardian);
 171 SCM
 172 scm_make_guardian ()
 173 {
 174   SCM cclo = scm_makcclo (guard1, 2L);
 175   guardian_t *g = (guardian_t *) scm_must_malloc (sizeof (guardian_t),
 176                                                   s_make_guardian);
 177   SCM z1 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
 178   SCM z2 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
 179   SCM z;
 180   SCM_NEWCELL (z);
 181
 182   SCM_DEFER_INTS;
 183   /* A tconc starts out with one tail pair. */
 184   g->live.head = g->live.tail = z1;
 185   g->zombies.head = g->zombies.tail = z2;
 186   SCM_SETCDR (z, g);
 187   SCM_SETCAR (z, scm_tc16_guardian);
 188   SCM_ALLOW_INTS;
 189
 190   CCLO_G (cclo) = z;
 191
 192   return cclo;
 193 }
 194
 195 void
 196 scm_guardian_gc_init()
 197 {
 198   n_guardians = 0;
 199 }
 200
 201 void
 202 scm_guardian_zombify ()
 203 {
 204   int i;
 205   for (i = 0; i < n_guardians; ++i)
 206     {
 207       SCM g = guardians[i];
 208       /* Loop through the live list and
 209          1. move unmarked objects to the zombies tconc
 210          2. mark the live tconc.
 211       */
 212       SCM tconc_tail = GUARDIAN_LIVE (g).tail;
 213       SCM prev_pair = SCM_BOOL_F;
 214       SCM pair = GUARDIAN_LIVE (g).head;
 215       while (pair != tconc_tail)
 216         {
 217           SCM next_pair = SCM_CDR (pair);
 218
 219           if (SCM_NMARKEDP (SCM_CAR (pair)))
 220             {
 221               /* got you, zombie! */
 222
 223               /* out of the live list! */
 224               if (SCM_FALSEP (prev_pair))
 225                 GUARDIAN_LIVE (g).head = next_pair;
 226               else
 227                 /* mark previous pair */
 228                 SCM_SETCDR (prev_pair, next_pair | 1);
 229
 230               /* to the zombie list! */
 231               TCONC_IN (GUARDIAN_ZOMBIES (g), SCM_CAR (pair), pair);
 232             }
 233           else
 234             {
 235               if (SCM_NFALSEP (prev_pair))
 236                 /* mark previous pair */
 237                 SCM_SETCDR (prev_pair, pair | 1);
 238               prev_pair = pair;
 239             }
 240
 241           pair = next_pair;
 242         }
 243       if (SCM_NFALSEP (prev_pair))
 244         /* mark previous pair */
 245         SCM_SETCDR (prev_pair, pair | 1);
 246       /* mark live list tail */
 247       SCM_SETOR_CDR (tconc_tail, 1);
 248
 249       scm_gc_mark (GUARDIAN_ZOMBIES (g).head);
 250     }
 251 }
 252
 253 void
 254 scm_guard (SCM guardian, SCM obj)
 255 {
 256   SCM g = CCLO_G (guardian);
 257
 258   if (SCM_NIMP (obj))
 259     {
 260       SCM z;
 261
 262       SCM_NEWCELL (z);
 263
 264       /* This critical section barrier will be replaced by a mutex. */
 265       SCM_DEFER_INTS;
 266       TCONC_IN (GUARDIAN_LIVE (g), obj, z);
 267       SCM_ALLOW_INTS;
 268     }
 269 }
 270
 271 SCM
 272 scm_get_one_zombie (SCM guardian)
 273 {
 274   SCM g = CCLO_G (guardian);
 275   SCM res = SCM_BOOL_F;
 276
 277   /* This critical section barrier will be replaced by a mutex. */
 278   SCM_DEFER_INTS;
 279   if (!TCONC_EMPTYP (GUARDIAN_ZOMBIES (g)))
 280     TCONC_OUT (GUARDIAN_ZOMBIES (g), res);
 281   SCM_ALLOW_INTS;
 282
 283   return res;
 284 }
 285
 286 void
 287 scm_init_guardian()
 288 {
 289   scm_tc16_guardian = scm_newsmob (&g_smob);
 290   if (!(guardians = (SCM *) malloc ((guardians_size = 32) * sizeof (SCM))))
 291     {
 292       fprintf (stderr, "trouble!\n");
 293       exit (SCM_EXIT_FAILURE);
 294     }
 295   guard1 = scm_make_subr_opt ("guardian", scm_tc7_subr_2o, guard, 0);
 296
 297 #include "guardians.x"
 298 }