libguile/weaks.c

   1 /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2006, 2008, 2009, 2010,
   2  *   2011, 2012, 2014 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include <stdio.h>
  27
  28 #include "libguile/_scm.h"
  29 #include "libguile/vectors.h"
  30 #include "libguile/hashtab.h"
  31
  32 #include "libguile/validate.h"
  33 #include "libguile/weaks.h"
  34
  35 #include "libguile/bdw-gc.h"
  36 #include <gc/gc_typed.h>
  37
  38
  39 \f
  40 /* Weak pairs for use in weak alist vectors and weak hash tables.
  41
  42    We have weal-car pairs, weak-cdr pairs, and doubly weak pairs.  In weak
  43    pairs, the weak component(s) are not scanned for pointers and are
  44    registered as disapperaring links; therefore, the weak component may be
  45    set to NULL by the garbage collector when no other reference to that word
  46    exist.  Thus, users should only access weak pairs via the
  47    `SCM_WEAK_PAIR_C[AD]R ()' macros.  See also `scm_fixup_weak_alist ()' in
  48    `hashtab.c'.  */
  49
  50 /* Type descriptors for weak-c[ad]r pairs.  */
  51 static GC_descr wcar_pair_descr, wcdr_pair_descr;
  52
  53
  54 SCM
  55 scm_weak_car_pair (SCM car, SCM cdr)
  56 {
  57   scm_t_cell *cell;
  58
  59   cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
  60                                                    wcar_pair_descr);
  61
  62   cell->word_0 = car;
  63   cell->word_1 = cdr;
  64
  65   if (SCM_NIMP (car))
  66     /* Weak car cells make sense iff the car is non-immediate.  */
  67     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car));
  68
  69   return (SCM_PACK (cell));
  70 }
  71
  72 SCM
  73 scm_weak_cdr_pair (SCM car, SCM cdr)
  74 {
  75   scm_t_cell *cell;
  76
  77   cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
  78                                                    wcdr_pair_descr);
  79
  80   cell->word_0 = car;
  81   cell->word_1 = cdr;
  82
  83   if (SCM_NIMP (cdr))
  84     /* Weak cdr cells make sense iff the cdr is non-immediate.  */
  85     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr));
  86
  87   return (SCM_PACK (cell));
  88 }
  89
  90 SCM
  91 scm_doubly_weak_pair (SCM car, SCM cdr)
  92 {
  93   /* Doubly weak cells shall not be scanned at all for pointers.  */
  94   scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell),
  95                                                               "weak cell");
  96
  97   cell->word_0 = car;
  98   cell->word_1 = cdr;
  99
 100   if (SCM_NIMP (car))
 101     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car));
 102   if (SCM_NIMP (cdr))
 103     SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr));
 104
 105   return (SCM_PACK (cell));
 106 }
 107
 108
 109 \f
 110
 111 /* 1. The current hash table implementation in hashtab.c uses weak alist
 112  *    vectors (formerly called weak hash tables) internally.
 113  *
 114  * 2. All hash table operations still work on alist vectors.
 115  *
 116  * 3. The weak vector and alist vector Scheme API is accessed through
 117  *    the module (ice-9 weak-vector).
 118  */
 119
 120
 121 /* {Weak Vectors}
 122  */
 123
 124
 125 #define SCM_VALIDATE_WEAK_VECTOR(pos, var) \
 126   SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_I_WVECTP, "weak vector")
 127
 128
 129 SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
 130             (SCM size, SCM fill),
 131             "Return a weak vector with @var{size} elements. If the optional\n"
 132             "argument @var{fill} is given, all entries in the vector will be\n"
 133             "set to @var{fill}. The default value for @var{fill} is the\n"
 134             "empty list.")
 135 #define FUNC_NAME s_scm_make_weak_vector
 136 {
 137   return scm_i_make_weak_vector (0, size, fill);
 138 }
 139 #undef FUNC_NAME
 140
 141
 142 SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
 143
 144 SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
 145            (SCM l),
 146             "@deffnx {Scheme Procedure} list->weak-vector l\n"
 147             "Construct a weak vector from a list: @code{weak-vector} uses\n"
 148             "the list of its arguments while @code{list->weak-vector} uses\n"
 149             "its only argument @var{l} (a list) to construct a weak vector\n"
 150             "the same way @code{list->vector} would.")
 151 #define FUNC_NAME s_scm_weak_vector
 152 {
 153   return scm_i_make_weak_vector_from_list (0, l);
 154 }
 155 #undef FUNC_NAME
 156
 157
 158 SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
 159             (SCM obj),
 160             "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
 161             "weak hashes are also weak vectors.")
 162 #define FUNC_NAME s_scm_weak_vector_p
 163 {
 164   return scm_from_bool (scm_is_weak_vector (obj));
 165 }
 166 #undef FUNC_NAME
 167
 168
 169 int
 170 scm_is_weak_vector (SCM obj)
 171 {
 172   return SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj);
 173 }
 174
 175
 176 SCM_DEFINE (scm_weak_vector_length, "weak-vector-length", 1, 0, 0,
 177             (SCM wvect),
 178             "Returns the number of elements in @var{wvect} as an exact integer.")
 179 #define FUNC_NAME s_scm_weak_vector_length
 180 {
 181   return scm_from_size_t (scm_c_weak_vector_length (wvect));
 182 }
 183 #undef FUNC_NAME
 184
 185
 186 size_t
 187 scm_c_weak_vector_length (SCM wvect)
 188 #define FUNC_NAME s_scm_weak_vector_length
 189 {
 190   SCM_VALIDATE_WEAK_VECTOR (1, wvect);
 191   return SCM_I_VECTOR_LENGTH (wvect);
 192 }
 193 #undef FUNC_NAME
 194
 195
 196 SCM_DEFINE (scm_weak_vector_ref, "weak-vector-ref", 2, 0, 0,
 197             (SCM wvect, SCM k),
 198             "Like @code{vector-ref}, but for weak vectors.")
 199 #define FUNC_NAME s_scm_weak_vector_ref
 200 {
 201   return scm_c_weak_vector_ref (wvect, scm_to_size_t (k));
 202 }
 203 #undef FUNC_NAME
 204
 205
 206 SCM
 207 scm_c_weak_vector_ref (SCM wvect, size_t k)
 208 #define FUNC_NAME s_scm_weak_vector_ref
 209 {
 210   SCM elt;
 211
 212   SCM_VALIDATE_WEAK_VECTOR (1, wvect);
 213
 214   if (k >= SCM_I_VECTOR_LENGTH (wvect))
 215     scm_out_of_range ("weak-vector-ref", scm_from_size_t (k));
 216   elt = (SCM_I_VECTOR_ELTS(wvect))[k];
 217
 218   if (SCM_UNPACK (elt) == 0)
 219     /* ELT was a weak pointer and got nullified by the GC.  */
 220     return SCM_BOOL_F;
 221
 222   return elt;
 223 }
 224 #undef FUNC_NAME
 225
 226
 227 SCM_DEFINE (scm_weak_vector_set_x, "weak-vector-set!", 3, 0, 0,
 228             (SCM wvect, SCM k, SCM elt),
 229             "Like @code{vector-set!}, but for weak vectors.")
 230 #define FUNC_NAME s_scm_weak_vector_set_x
 231 {
 232   scm_c_weak_vector_set_x (wvect, scm_to_size_t (k), elt);
 233
 234   return SCM_UNSPECIFIED;
 235 }
 236 #undef FUNC_NAME
 237
 238
 239 void
 240 scm_c_weak_vector_set_x (SCM wvect, size_t k, SCM elt)
 241 #define FUNC_NAME s_scm_weak_vector_set_x
 242 {
 243   SCM *loc;
 244
 245   SCM_VALIDATE_WEAK_VECTOR (1, wvect);
 246
 247   if (k >= SCM_I_VECTOR_LENGTH (wvect))
 248     scm_out_of_range ("weak-vector-set!", scm_from_size_t (k));
 249
 250   loc = & SCM_I_VECTOR_WELTS (wvect)[k];
 251   *loc = elt;
 252
 253   /* Make it a weak pointer.  */
 254   SCM_I_REGISTER_DISAPPEARING_LINK ((void **) loc, SCM2PTR (elt));
 255 }
 256 #undef FUNC_NAME
 257
 258
 259 \f
 260 /* Weak alist vectors, i.e., vectors of alists.
 261
 262    The alist vector themselves are _not_ weak.  The `car' (or `cdr', or both)
 263    of the pairs within it are weak.  See `hashtab.c' for details.  */
 264
 265
 266 /* FIXME: We used to have two implementations of weak hash tables: the one in
 267    here and the one in `hashtab.c'.  The difference is that weak alist
 268    vectors could be used as vectors while (weak) hash tables can't.  We need
 269    to unify that.  */
 270
 271 SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
 272             (SCM size),
 273             "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
 274             "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
 275             "Return a weak hash table with @var{size} buckets. As with any\n"
 276             "hash table, choosing a good size for the table requires some\n"
 277             "caution.\n"
 278             "\n"
 279             "You can modify weak hash tables in exactly the same way you\n"
 280             "would modify regular hash tables. (@pxref{Hash Tables})")
 281 #define FUNC_NAME s_scm_make_weak_key_alist_vector
 282 {
 283   return scm_make_weak_key_hash_table (size);
 284 }
 285 #undef FUNC_NAME
 286
 287
 288 SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
 289             (SCM size),
 290             "Return a hash table with weak values with @var{size} buckets.\n"
 291             "(@pxref{Hash Tables})")
 292 #define FUNC_NAME s_scm_make_weak_value_alist_vector
 293 {
 294   return scm_make_weak_value_hash_table (size);
 295 }
 296 #undef FUNC_NAME
 297
 298
 299 SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
 300             (SCM size),
 301             "Return a hash table with weak keys and values with @var{size}\n"
 302             "buckets.  (@pxref{Hash Tables})")
 303 #define FUNC_NAME s_scm_make_doubly_weak_alist_vector
 304 {
 305   return scm_make_doubly_weak_hash_table (size);
 306 }
 307 #undef FUNC_NAME
 308
 309
 310 SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
 311            (SCM obj),
 312             "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
 313             "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
 314             "Return @code{#t} if @var{obj} is the specified weak hash\n"
 315             "table. Note that a doubly weak hash table is neither a weak key\n"
 316             "nor a weak value hash table.")
 317 #define FUNC_NAME s_scm_weak_key_alist_vector_p
 318 {
 319   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
 320 }
 321 #undef FUNC_NAME
 322
 323
 324 SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
 325             (SCM obj),
 326             "Return @code{#t} if @var{obj} is a weak value hash table.")
 327 #define FUNC_NAME s_scm_weak_value_alist_vector_p
 328 {
 329   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
 330 }
 331 #undef FUNC_NAME
 332
 333
 334 SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
 335             (SCM obj),
 336             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
 337 #define FUNC_NAME s_scm_doubly_weak_alist_vector_p
 338 {
 339   return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
 340 }
 341 #undef FUNC_NAME
 342
 343
 344
 345 \f
 346 SCM
 347 scm_init_weaks_builtins ()
 348 {
 349 #include "libguile/weaks.x"
 350   return SCM_UNSPECIFIED;
 351 }
 352
 353 void
 354 scm_weaks_prehistory ()
 355 {
 356   /* Initialize weak pairs.  */
 357   GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
 358   GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
 359
 360   /* In a weak-car pair, only the second word must be scanned for
 361      pointers.  */
 362   GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1));
 363   wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap,
 364                                         GC_WORD_LEN (scm_t_cell));
 365
 366   /* Conversely, in a weak-cdr pair, only the first word must be scanned for
 367      pointers.  */
 368   GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0));
 369   wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap,
 370                                         GC_WORD_LEN (scm_t_cell));
 371
 372 }
 373
 374 void
 375 scm_init_weaks ()
 376 {
 377   scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
 378                       scm_init_weaks_builtins);
 379 }
 380
 381
 382 /*
 383   Local Variables:
 384   c-file-style: "gnu"
 385   End:
 386 */