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