libguile/weaks.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008 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
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/vectors.h"
  28 #include "libguile/lang.h"
  29 #include "libguile/hashtab.h"
  30
  31 #include "libguile/validate.h"
  32 #include "libguile/weaks.h"
  33
  34 \f
  35
  36 /* 1. The current hash table implementation in hashtab.c uses weak alist
  37  *    vectors (formerly called weak hash tables) internally.
  38  *
  39  * 2. All hash table operations still work on alist vectors.
  40  *
  41  * 3. The weak vector and alist vector Scheme API is accessed through
  42  *    the module (ice-9 weak-vector).
  43  */
  44
  45
  46 /* {Weak Vectors}
  47  */
  48
  49
  50 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
  51             (SCM size, SCM fill),
  52             "Return a weak vector with @var{size} elements. If the optional\n"
  53             "argument @var{fill} is given, all entries in the vector will be\n"
  54             "set to @var{fill}. The default value for @var{fill} is the\n"
  55             "empty list.")
  56 #define FUNC_NAME s_scm_make_weak_vector
  57 {
  58   return scm_i_allocate_weak_vector (0, size, fill);
  59 }
  60 #undef FUNC_NAME
  61
  62
  63 SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
  64
  65 SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
  66            (SCM l),
  67             "@deffnx {Scheme Procedure} list->weak-vector l\n"
  68             "Construct a weak vector from a list: @code{weak-vector} uses\n"
  69             "the list of its arguments while @code{list->weak-vector} uses\n"
  70             "its only argument @var{l} (a list) to construct a weak vector\n"
  71             "the same way @code{list->vector} would.")
  72 #define FUNC_NAME s_scm_weak_vector
  73 {
  74   scm_t_array_handle handle;
  75   SCM res, *data;
  76   long i;
  77
  78   i = scm_ilength (l);
  79   SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
  80
  81   res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED);
  82   data = scm_vector_writable_elements (res, &handle, NULL, NULL);
  83
  84   while (scm_is_pair (l) && i > 0)
  85     {
  86       *data++ = SCM_CAR (l);
  87       l = SCM_CDR (l);
  88       i--;
  89     }
  90
  91   scm_array_handle_release (&handle);
  92
  93   return res;
  94 }
  95 #undef FUNC_NAME
  96
  97
  98 SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
  99             (SCM obj),
 100             "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
 101             "weak hashes are also weak vectors.")
 102 #define FUNC_NAME s_scm_weak_vector_p
 103 {
 104   return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
 105 }
 106 #undef FUNC_NAME
 107
 108 \f
 109
 110 SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
 111             (SCM size),
 112             "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
 113             "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
 114             "Return a weak hash table with @var{size} buckets. As with any\n"
 115             "hash table, choosing a good size for the table requires some\n"
 116             "caution.\n"
 117             "\n"
 118             "You can modify weak hash tables in exactly the same way you\n"
 119             "would modify regular hash tables. (@pxref{Hash Tables})")
 120 #define FUNC_NAME s_scm_make_weak_key_alist_vector
 121 {
 122   return scm_i_allocate_weak_vector
 123     (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
 124 }
 125 #undef FUNC_NAME
 126
 127
 128 SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
 129             (SCM size),
 130             "Return a hash table with weak values with @var{size} buckets.\n"
 131             "(@pxref{Hash Tables})")
 132 #define FUNC_NAME s_scm_make_weak_value_alist_vector
 133 {
 134   return scm_i_allocate_weak_vector
 135     (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
 136 }
 137 #undef FUNC_NAME
 138
 139
 140 SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
 141             (SCM size),
 142             "Return a hash table with weak keys and values with @var{size}\n"
 143             "buckets.  (@pxref{Hash Tables})")
 144 #define FUNC_NAME s_scm_make_doubly_weak_alist_vector
 145 {
 146   return scm_i_allocate_weak_vector
 147     (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
 148 }
 149 #undef FUNC_NAME
 150
 151
 152 SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
 153            (SCM obj),
 154             "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
 155             "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
 156             "Return @code{#t} if @var{obj} is the specified weak hash\n"
 157             "table. Note that a doubly weak hash table is neither a weak key\n"
 158             "nor a weak value hash table.")
 159 #define FUNC_NAME s_scm_weak_key_alist_vector_p
 160 {
 161   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
 162 }
 163 #undef FUNC_NAME
 164
 165
 166 SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
 167             (SCM obj),
 168             "Return @code{#t} if @var{obj} is a weak value hash table.")
 169 #define FUNC_NAME s_scm_weak_value_alist_vector_p
 170 {
 171   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
 172 }
 173 #undef FUNC_NAME
 174
 175
 176 SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
 177             (SCM obj),
 178             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
 179 #define FUNC_NAME s_scm_doubly_weak_alist_vector_p
 180 {
 181   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
 182 }
 183 #undef FUNC_NAME
 184
 185 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
 186
 187 static SCM weak_vectors;
 188
 189 void
 190 scm_i_init_weak_vectors_for_gc ()
 191 {
 192   weak_vectors = SCM_EOL;
 193 }
 194
 195 void
 196 scm_i_mark_weak_vector (SCM w)
 197 {
 198   SCM_I_SET_WVECT_GC_CHAIN (w, weak_vectors);
 199   weak_vectors = w;
 200 }
 201
 202 static int
 203 scm_i_mark_weak_vector_non_weaks (SCM w)
 204 {
 205   int again = 0;
 206
 207   if (SCM_IS_WHVEC_ANY (w))
 208     {
 209       SCM *ptr;
 210       long n = SCM_I_WVECT_LENGTH (w);
 211       long j;
 212       int weak_keys = SCM_IS_WHVEC (w) || SCM_IS_WHVEC_B (w);
 213       int weak_values = SCM_IS_WHVEC_V (w) || SCM_IS_WHVEC_B (w);
 214
 215       ptr = SCM_I_WVECT_GC_WVELTS (w);
 216
 217       for (j = 0; j < n; ++j)
 218         {
 219           SCM alist, slow_alist;
 220           int slow_toggle = 0;
 221
 222           /* We do not set the mark bits of the alist spine cells here
 223              since we do not want to ever create the situation where a
 224              marked cell references an unmarked cell (except in
 225              scm_gc_mark, where the referenced cells will be marked
 226              immediately).  Thus, we can not use mark bits to stop us
 227              from looping indefinitely over a cyclic alist.  Instead,
 228              we use the standard tortoise and hare trick to catch
 229              cycles.  The fast walker does the work, and stops when it
 230              catches the slow walker to ensure that the whole cycle
 231              has been worked on.
 232           */
 233
 234           alist = slow_alist = ptr[j];
 235
 236           while (scm_is_pair (alist))
 237             {
 238               SCM elt = SCM_CAR (alist);
 239
 240               if (UNMARKED_CELL_P (elt))
 241                 {
 242                   if (scm_is_pair (elt))
 243                     {
 244                       SCM key = SCM_CAR (elt);
 245                       SCM value = SCM_CDR (elt);
 246
 247                       if (!((weak_keys && UNMARKED_CELL_P (key))
 248                             || (weak_values && UNMARKED_CELL_P (value))))
 249                         {
 250                           /* The item should be kept.  We need to mark it
 251                              recursively.
 252                           */
 253                           scm_gc_mark (elt);
 254                           again = 1;
 255                         }
 256                     }
 257                   else
 258                     {
 259                       /* A non-pair cell element.  This should not
 260                          appear in a real alist, but when it does, we
 261                          need to keep it.
 262                       */
 263                       scm_gc_mark (elt);
 264                       again = 1;
 265                     }
 266                 }
 267
 268               alist = SCM_CDR (alist);
 269
 270               if (slow_toggle && scm_is_pair (slow_alist))
 271                 {
 272                   slow_alist = SCM_CDR (slow_alist);
 273                   slow_toggle = !slow_toggle;
 274                   if (scm_is_eq (slow_alist, alist))
 275                     break;
 276                 }
 277             }
 278           if (!scm_is_pair (alist))
 279             scm_gc_mark (alist);
 280         }
 281     }
 282
 283   return again;
 284 }
 285
 286 int
 287 scm_i_mark_weak_vectors_non_weaks ()
 288 {
 289   int again = 0;
 290   SCM w = weak_vectors;
 291   while (!scm_is_null (w))
 292     {
 293       if (scm_i_mark_weak_vector_non_weaks (w))
 294         again = 1;
 295       w = SCM_I_WVECT_GC_CHAIN (w);
 296     }
 297   return again;
 298 }
 299
 300 static void
 301 scm_i_remove_weaks (SCM w)
 302 {
 303   SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
 304   size_t n = SCM_I_WVECT_LENGTH (w);
 305   size_t i;
 306
 307   if (!SCM_IS_WHVEC_ANY (w))
 308     {
 309       for (i = 0; i < n; ++i)
 310         if (UNMARKED_CELL_P (ptr[i]))
 311           ptr[i] = SCM_BOOL_F;
 312     }
 313   else
 314     {
 315       size_t delta = 0;
 316
 317       for (i = 0; i < n; ++i)
 318         {
 319           SCM alist, *fixup;
 320
 321           fixup = ptr + i;
 322           alist = *fixup;
 323           while (scm_is_pair (alist) && !SCM_GC_MARK_P (alist))
 324             {
 325               if (UNMARKED_CELL_P (SCM_CAR (alist)))
 326                 {
 327                   *fixup = SCM_CDR (alist);
 328                   delta++;
 329                 }
 330               else
 331                 {
 332                   SCM_SET_GC_MARK (alist);
 333                   fixup = SCM_CDRLOC (alist);
 334                 }
 335               alist = *fixup;
 336             }
 337         }
 338 #if 0
 339       if (delta)
 340         fprintf (stderr, "vector %p, delta %d\n", w, delta);
 341 #endif
 342       SCM_I_SET_WVECT_DELTA (w, delta);
 343     }
 344 }
 345
 346 void
 347 scm_i_remove_weaks_from_weak_vectors ()
 348 {
 349   SCM w = weak_vectors;
 350   while (!scm_is_null (w))
 351     {
 352       scm_i_remove_weaks (w);
 353       w = SCM_I_WVECT_GC_CHAIN (w);
 354     }
 355 }
 356
 357 \f
 358
 359 SCM
 360 scm_init_weaks_builtins ()
 361 {
 362 #include "libguile/weaks.x"
 363   return SCM_UNSPECIFIED;
 364 }
 365
 366 void
 367 scm_init_weaks ()
 368 {
 369   scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
 370                       scm_init_weaks_builtins);
 371 }
 372
 373
 374 /*
 375   Local Variables:
 376   c-file-style: "gnu"
 377   End:
 378 */