libguile/weak-table.c

   1 /* Copyright (C) 2011, 2012 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 <assert.h>
  26
  27 #include "libguile/bdw-gc.h"
  28 #include <gc/gc_mark.h>
  29
  30 #include "libguile/_scm.h"
  31 #include "libguile/hash.h"
  32 #include "libguile/eval.h"
  33 #include "libguile/ports.h"
  34
  35 #include "libguile/validate.h"
  36 #include "libguile/weak-table.h"
  37
  38
  39 /* Weak Tables
  40
  41    This file implements weak hash tables.  Weak hash tables are
  42    generally used when you want to augment some object with additional
  43    data, but when you don't have space to store the data in the object.
  44    For example, procedure properties are implemented with weak tables.
  45
  46    Weak tables are implemented using an open-addressed hash table.
  47    Basically this means that there is an array of entries, and the item
  48    is expected to be found the slot corresponding to its hash code,
  49    modulo the length of the array.
  50
  51    Collisions are handled using linear probing with the Robin Hood
  52    technique.  See Pedro Celis' paper, "Robin Hood Hashing":
  53
  54      http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
  55
  56    The vector of entries is allocated in such a way that the GC doesn't
  57    trace the weak values.  For doubly-weak tables, this means that the
  58    entries are allocated as an "atomic" piece of memory.  Key-weak and
  59    value-weak tables use a special GC kind with a custom mark procedure.
  60    When items are added weakly into table, a disappearing link is
  61    registered to their locations.  If the referent is collected, then
  62    that link will be zeroed out.
  63
  64    An entry in the table consists of the key and the value, together
  65    with the hash code of the key.  We munge hash codes so that they are
  66    never 0.  In this way we can detect removed entries (key of zero but
  67    nonzero hash code), and can then reshuffle elements as needed to
  68    maintain the robin hood ordering.
  69
  70    Compared to buckets-and-chains hash tables, open addressing has the
  71    advantage that it is very cache-friendly.  It also uses less memory.
  72
  73    Implementation-wise, there are two things to note.
  74
  75      1. We assume that hash codes are evenly distributed across the
  76         range of unsigned longs.  The actual hash code stored in the
  77         entry is left-shifted by 1 bit (losing 1 bit of hash precision),
  78         and then or'd with 1.  In this way we ensure that the hash field
  79         of an occupied entry is nonzero.  To map to an index, we
  80         right-shift the hash by one, divide by the size, and take the
  81         remainder.
  82
  83      2. Since the weak references are stored in an atomic region with
  84         disappearing links, they need to be accessed with the GC alloc
  85         lock.  `copy_weak_entry' will do that for you.  The hash code
  86         itself can be read outside the lock, though.
  87   */
  88
  89
  90 typedef struct {
  91   unsigned long hash;
  92   scm_t_bits key;
  93   scm_t_bits value;
  94 } scm_t_weak_entry;
  95
  96
  97 struct weak_entry_data {
  98   scm_t_weak_entry *in;
  99   scm_t_weak_entry *out;
 100 };
 101
 102 static void*
 103 do_copy_weak_entry (void *data)
 104 {
 105   struct weak_entry_data *e = data;
 106
 107   e->out->hash = e->in->hash;
 108   e->out->key = e->in->key;
 109   e->out->value = e->in->value;
 110
 111   return NULL;
 112 }
 113
 114 static void
 115 copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
 116 {
 117   struct weak_entry_data data;
 118
 119   data.in = src;
 120   data.out = dst;
 121
 122   GC_call_with_alloc_lock (do_copy_weak_entry, &data);
 123 }
 124
 125 static void
 126 register_disappearing_links (scm_t_weak_entry *entry,
 127                              SCM k, SCM v,
 128                              scm_t_weak_table_kind kind)
 129 {
 130   if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
 131       && (kind == SCM_WEAK_TABLE_KIND_KEY
 132           || kind == SCM_WEAK_TABLE_KIND_BOTH))
 133     SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key,
 134                                       (GC_PTR) SCM2PTR (k));
 135
 136   if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
 137       && (kind == SCM_WEAK_TABLE_KIND_VALUE
 138           || kind == SCM_WEAK_TABLE_KIND_BOTH))
 139     SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value,
 140                                       (GC_PTR) SCM2PTR (v));
 141 }
 142
 143 static void
 144 unregister_disappearing_links (scm_t_weak_entry *entry,
 145                                scm_t_weak_table_kind kind)
 146 {
 147   if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
 148     GC_unregister_disappearing_link ((GC_PTR) &entry->key);
 149
 150   if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
 151     GC_unregister_disappearing_link ((GC_PTR) &entry->value);
 152 }
 153
 154 static void
 155 move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to,
 156                          SCM key, SCM value, scm_t_weak_table_kind kind)
 157 {
 158   if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
 159       && SCM_HEAP_OBJECT_P (key))
 160     {
 161 #ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
 162       GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
 163 #else
 164       GC_unregister_disappearing_link (&from->key);
 165       SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM2PTR (key));
 166 #endif
 167     }
 168
 169   if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
 170       && SCM_HEAP_OBJECT_P (value))
 171     {
 172 #ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
 173       GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value);
 174 #else
 175       GC_unregister_disappearing_link (&from->value);
 176       SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM2PTR (value));
 177 #endif
 178     }
 179 }
 180
 181 static void
 182 move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to,
 183                  scm_t_weak_table_kind kind)
 184 {
 185   if (from->hash)
 186     {
 187       scm_t_weak_entry copy;
 188
 189       copy_weak_entry (from, &copy);
 190       to->hash = copy.hash;
 191       to->key = copy.key;
 192       to->value = copy.value;
 193
 194       move_disappearing_links (from, to,
 195                                SCM_PACK (copy.key), SCM_PACK (copy.value),
 196                                kind);
 197     }
 198   else
 199     {
 200       to->hash = 0;
 201       to->key = 0;
 202       to->value = 0;
 203     }
 204 }
 205
 206
 207 typedef struct {
 208   scm_t_weak_entry *entries;    /* the data */
 209   scm_i_pthread_mutex_t lock;   /* the lock */
 210   scm_t_weak_table_kind kind;   /* what kind of table it is */
 211   unsigned long size;           /* total number of slots. */
 212   unsigned long n_items;        /* number of items in table */
 213   unsigned long lower;          /* when to shrink */
 214   unsigned long upper;          /* when to grow */
 215   int size_index;               /* index into hashtable_size */
 216   int min_size_index;           /* minimum size_index */
 217 } scm_t_weak_table;
 218
 219
 220 #define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table))
 221 #define SCM_VALIDATE_WEAK_TABLE(pos, arg) \
 222   SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table")
 223 #define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x))
 224
 225
 226 static unsigned long
 227 hash_to_index (unsigned long hash, unsigned long size)
 228 {
 229   return (hash >> 1) % size;
 230 }
 231
 232 static unsigned long
 233 entry_distance (unsigned long hash, unsigned long k, unsigned long size)
 234 {
 235   unsigned long origin = hash_to_index (hash, size);
 236
 237   if (k >= origin)
 238     return k - origin;
 239   else
 240     /* The other key was displaced and wrapped around.  */
 241     return size - origin + k;
 242 }
 243
 244 static void
 245 rob_from_rich (scm_t_weak_table *table, unsigned long k)
 246 {
 247   unsigned long empty, size;
 248
 249   size = table->size;
 250
 251   /* If we are to free up slot K in the table, we need room to do so.  */
 252   assert (table->n_items < size);
 253
 254   empty = k;
 255   do
 256     empty = (empty + 1) % size;
 257   while (table->entries[empty].hash);
 258
 259   do
 260     {
 261       unsigned long last = empty ? (empty - 1) : (size - 1);
 262       move_weak_entry (&table->entries[last], &table->entries[empty],
 263                        table->kind);
 264       empty = last;
 265     }
 266   while (empty != k);
 267
 268   table->entries[empty].hash = 0;
 269   table->entries[empty].key = 0;
 270   table->entries[empty].value = 0;
 271 }
 272
 273 static void
 274 give_to_poor (scm_t_weak_table *table, unsigned long k)
 275 {
 276   /* Slot K was just freed up; possibly shuffle others down.  */
 277   unsigned long size = table->size;
 278
 279   while (1)
 280     {
 281       unsigned long next = (k + 1) % size;
 282       unsigned long hash;
 283       scm_t_weak_entry copy;
 284
 285       hash = table->entries[next].hash;
 286
 287       if (!hash || hash_to_index (hash, size) == next)
 288         break;
 289
 290       copy_weak_entry (&table->entries[next], &copy);
 291
 292       if (!copy.key || !copy.value)
 293         /* Lost weak reference.  */
 294         {
 295           give_to_poor (table, next);
 296           table->n_items--;
 297           continue;
 298         }
 299
 300       move_weak_entry (&table->entries[next], &table->entries[k],
 301                        table->kind);
 302
 303       k = next;
 304     }
 305
 306   /* We have shuffled down any entries that should be shuffled down; now
 307      free the end.  */
 308   table->entries[k].hash = 0;
 309   table->entries[k].key = 0;
 310   table->entries[k].value = 0;
 311 }
 312
 313
 314 \f
 315
 316 /* The GC "kinds" for singly-weak tables.  */
 317 static int weak_key_gc_kind;
 318 static int weak_value_gc_kind;
 319
 320 static struct GC_ms_entry *
 321 mark_weak_key_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 322                      struct GC_ms_entry *mark_stack_limit, GC_word env)
 323 {
 324   scm_t_weak_entry *entries = (scm_t_weak_entry*) addr;
 325   unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry);
 326
 327   for (k = 0; k < size; k++)
 328     if (entries[k].hash && entries[k].key)
 329       {
 330         SCM value = SCM_PACK (entries[k].value);
 331         mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (value),
 332                                            mark_stack_ptr, mark_stack_limit,
 333                                            NULL);
 334       }
 335
 336   return mark_stack_ptr;
 337 }
 338
 339 static struct GC_ms_entry *
 340 mark_weak_value_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 341                        struct GC_ms_entry *mark_stack_limit, GC_word env)
 342 {
 343   scm_t_weak_entry *entries = (scm_t_weak_entry*) addr;
 344   unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry);
 345
 346   for (k = 0; k < size; k++)
 347     if (entries[k].hash && entries[k].value)
 348       {
 349         SCM key = SCM_PACK (entries[k].key);
 350         mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key),
 351                                            mark_stack_ptr, mark_stack_limit,
 352                                            NULL);
 353       }
 354
 355   return mark_stack_ptr;
 356 }
 357
 358 static scm_t_weak_entry *
 359 allocate_entries (unsigned long size, scm_t_weak_table_kind kind)
 360 {
 361   scm_t_weak_entry *ret;
 362   size_t bytes = size * sizeof (*ret);
 363
 364   switch (kind)
 365     {
 366     case SCM_WEAK_TABLE_KIND_KEY:
 367       ret = GC_generic_malloc (bytes, weak_key_gc_kind);
 368       break;
 369     case SCM_WEAK_TABLE_KIND_VALUE:
 370       ret = GC_generic_malloc (bytes, weak_value_gc_kind);
 371       break;
 372     case SCM_WEAK_TABLE_KIND_BOTH:
 373       ret = scm_gc_malloc_pointerless (bytes, "weak-table");
 374       break;
 375     default:
 376       abort ();
 377     }
 378
 379   memset (ret, 0, bytes);
 380
 381   return ret;
 382 }
 383
 384 \f
 385
 386 /* Growing or shrinking is triggered when the load factor
 387  *
 388  *   L = N / S    (N: number of items in table, S: bucket vector length)
 389  *
 390  * passes an upper limit of 0.9 or a lower limit of 0.2.
 391  *
 392  * The implementation stores the upper and lower number of items which
 393  * trigger a resize in the hashtable object.
 394  *
 395  * Possible hash table sizes (primes) are stored in the array
 396  * hashtable_size.
 397  */
 398
 399 static unsigned long hashtable_size[] = {
 400   31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
 401   224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081,
 402   57524111, 115048217, 230096423
 403 };
 404
 405 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
 406
 407 static int
 408 compute_size_index (scm_t_weak_table *table)
 409 {
 410   int i = table->size_index;
 411
 412   if (table->n_items < table->lower)
 413     {
 414       /* rehashing is not triggered when i <= min_size */
 415       do
 416         --i;
 417       while (i > table->min_size_index
 418              && table->n_items < hashtable_size[i] / 5);
 419     }
 420   else if (table->n_items > table->upper)
 421     {
 422       ++i;
 423       if (i >= HASHTABLE_SIZE_N)
 424         /* The biggest size currently is 230096423, which for a 32-bit
 425            machine will occupy 2.3GB of memory at a load of 80%.  There
 426            is probably something better to do here, but if you have a
 427            weak map of that size, you are hosed in any case.  */
 428         abort ();
 429     }
 430
 431   return i;
 432 }
 433
 434 static void
 435 resize_table (scm_t_weak_table *table)
 436 {
 437   scm_t_weak_entry *old_entries, *new_entries;
 438   int new_size_index;
 439   unsigned long old_size, new_size, old_k;
 440
 441   do
 442     {
 443       new_size_index = compute_size_index (table);
 444       if (new_size_index == table->size_index)
 445         return;
 446       new_size = hashtable_size[new_size_index];
 447       scm_i_pthread_mutex_unlock (&table->lock);
 448       /* Allocating memory might cause finalizers to run, which could
 449          run anything, so drop our lock to avoid deadlocks.  */
 450       new_entries = allocate_entries (new_size, table->kind);
 451       scm_i_pthread_mutex_unlock (&table->lock);
 452     }
 453   while (new_size_index != compute_size_index (table));
 454
 455   old_entries = table->entries;
 456   old_size = table->size;
 457
 458   table->size_index = new_size_index;
 459   table->size = new_size;
 460   if (new_size_index <= table->min_size_index)
 461     table->lower = 0;
 462   else
 463     table->lower = new_size / 5;
 464   table->upper = 9 * new_size / 10;
 465   table->n_items = 0;
 466   table->entries = new_entries;
 467
 468   for (old_k = 0; old_k < old_size; old_k++)
 469     {
 470       scm_t_weak_entry copy;
 471       unsigned long new_k, distance;
 472
 473       if (!old_entries[old_k].hash)
 474         continue;
 475
 476       copy_weak_entry (&old_entries[old_k], &copy);
 477
 478       if (!copy.key || !copy.value)
 479         continue;
 480
 481       new_k = hash_to_index (copy.hash, new_size);
 482
 483       for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
 484         {
 485           unsigned long other_hash = new_entries[new_k].hash;
 486
 487           if (!other_hash)
 488             /* Found an empty entry. */
 489             break;
 490
 491           /* Displace the entry if our distance is less, otherwise keep
 492              looking. */
 493           if (entry_distance (other_hash, new_k, new_size) < distance)
 494             {
 495               rob_from_rich (table, new_k);
 496               break;
 497             }
 498         }
 499
 500       table->n_items++;
 501       new_entries[new_k].hash = copy.hash;
 502       new_entries[new_k].key = copy.key;
 503       new_entries[new_k].value = copy.value;
 504
 505       register_disappearing_links (&new_entries[new_k],
 506                                    SCM_PACK (copy.key), SCM_PACK (copy.value),
 507                                    table->kind);
 508     }
 509 }
 510
 511 /* Run after GC via do_vacuum_weak_table, this function runs over the
 512    whole table, removing lost weak references, reshuffling the table as it
 513    goes.  It might resize the table if it reaps enough entries.  */
 514 static void
 515 vacuum_weak_table (scm_t_weak_table *table)
 516 {
 517   scm_t_weak_entry *entries = table->entries;
 518   unsigned long size = table->size;
 519   unsigned long k;
 520
 521   for (k = 0; k < size; k++)
 522     {
 523       unsigned long hash = entries[k].hash;
 524
 525       if (hash)
 526         {
 527           scm_t_weak_entry copy;
 528
 529           copy_weak_entry (&entries[k], &copy);
 530
 531           if (!copy.key || !copy.value)
 532             /* Lost weak reference; reshuffle.  */
 533             {
 534               give_to_poor (table, k);
 535               table->n_items--;
 536             }
 537         }
 538     }
 539
 540   if (table->n_items < table->lower)
 541     resize_table (table);
 542 }
 543
 544
 545 \f
 546
 547 static SCM
 548 weak_table_ref (scm_t_weak_table *table, unsigned long hash,
 549                 scm_t_table_predicate_fn pred, void *closure,
 550                 SCM dflt)
 551 {
 552   unsigned long k, distance, size;
 553   scm_t_weak_entry *entries;
 554
 555   size = table->size;
 556   entries = table->entries;
 557
 558   hash = (hash << 1) | 0x1;
 559   k = hash_to_index (hash, size);
 560
 561   for (distance = 0; distance < size; distance++, k = (k + 1) % size)
 562     {
 563       unsigned long other_hash;
 564
 565     retry:
 566       other_hash = entries[k].hash;
 567
 568       if (!other_hash)
 569         /* Not found. */
 570         return dflt;
 571
 572       if (hash == other_hash)
 573         {
 574           scm_t_weak_entry copy;
 575
 576           copy_weak_entry (&entries[k], &copy);
 577
 578           if (!copy.key || !copy.value)
 579             /* Lost weak reference; reshuffle.  */
 580             {
 581               give_to_poor (table, k);
 582               table->n_items--;
 583               goto retry;
 584             }
 585
 586           if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
 587             /* Found. */
 588             return SCM_PACK (copy.value);
 589         }
 590
 591       /* If the entry's distance is less, our key is not in the table.  */
 592       if (entry_distance (other_hash, k, size) < distance)
 593         return dflt;
 594     }
 595
 596   /* If we got here, then we were unfortunate enough to loop through the
 597      whole table.  Shouldn't happen, but hey.  */
 598   return dflt;
 599 }
 600
 601
 602 static void
 603 weak_table_put_x (scm_t_weak_table *table, unsigned long hash,
 604                   scm_t_table_predicate_fn pred, void *closure,
 605                   SCM key, SCM value)
 606 {
 607   unsigned long k, distance, size;
 608   scm_t_weak_entry *entries;
 609
 610   size = table->size;
 611   entries = table->entries;
 612
 613   hash = (hash << 1) | 0x1;
 614   k = hash_to_index (hash, size);
 615
 616   for (distance = 0; ; distance++, k = (k + 1) % size)
 617     {
 618       unsigned long other_hash;
 619
 620     retry:
 621       other_hash = entries[k].hash;
 622
 623       if (!other_hash)
 624         /* Found an empty entry. */
 625         break;
 626
 627       if (other_hash == hash)
 628         {
 629           scm_t_weak_entry copy;
 630
 631           copy_weak_entry (&entries[k], &copy);
 632
 633           if (!copy.key || !copy.value)
 634             /* Lost weak reference; reshuffle.  */
 635             {
 636               give_to_poor (table, k);
 637               table->n_items--;
 638               goto retry;
 639             }
 640
 641           if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
 642             /* Found an entry with this key. */
 643             break;
 644         }
 645
 646       if (table->n_items > table->upper)
 647         /* Full table, time to resize.  */
 648         {
 649           resize_table (table);
 650           return weak_table_put_x (table, hash >> 1, pred, closure, key, value);
 651         }
 652
 653       /* Displace the entry if our distance is less, otherwise keep
 654          looking. */
 655       if (entry_distance (other_hash, k, size) < distance)
 656         {
 657           rob_from_rich (table, k);
 658           break;
 659         }
 660     }
 661
 662   if (entries[k].hash)
 663     unregister_disappearing_links (&entries[k], table->kind);
 664   else
 665     table->n_items++;
 666
 667   entries[k].hash = hash;
 668   entries[k].key = SCM_UNPACK (key);
 669   entries[k].value = SCM_UNPACK (value);
 670
 671   register_disappearing_links (&entries[k], key, value, table->kind);
 672 }
 673
 674
 675 static void
 676 weak_table_remove_x (scm_t_weak_table *table, unsigned long hash,
 677                    scm_t_table_predicate_fn pred, void *closure)
 678 {
 679   unsigned long k, distance, size;
 680   scm_t_weak_entry *entries;
 681
 682   size = table->size;
 683   entries = table->entries;
 684
 685   hash = (hash << 1) | 0x1;
 686   k = hash_to_index (hash, size);
 687
 688   for (distance = 0; distance < size; distance++, k = (k + 1) % size)
 689     {
 690       unsigned long other_hash;
 691
 692     retry:
 693       other_hash = entries[k].hash;
 694
 695       if (!other_hash)
 696         /* Not found. */
 697         return;
 698
 699       if (other_hash == hash)
 700         {
 701           scm_t_weak_entry copy;
 702
 703           copy_weak_entry (&entries[k], &copy);
 704
 705           if (!copy.key || !copy.value)
 706             /* Lost weak reference; reshuffle.  */
 707             {
 708               give_to_poor (table, k);
 709               table->n_items--;
 710               goto retry;
 711             }
 712
 713           if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
 714             /* Found an entry with this key. */
 715             {
 716               entries[k].hash = 0;
 717               entries[k].key = 0;
 718               entries[k].value = 0;
 719
 720               unregister_disappearing_links (&entries[k], table->kind);
 721
 722               if (--table->n_items < table->lower)
 723                 resize_table (table);
 724               else
 725                 give_to_poor (table, k);
 726
 727               return;
 728             }
 729         }
 730
 731       /* If the entry's distance is less, our key is not in the table.  */
 732       if (entry_distance (other_hash, k, size) < distance)
 733         return;
 734     }
 735 }
 736
 737
 738 \f
 739 static SCM
 740 make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
 741 {
 742   scm_t_weak_table *table;
 743
 744   int i = 0, n = k ? k : 31;
 745   while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
 746     ++i;
 747   n = hashtable_size[i];
 748
 749   table = scm_gc_malloc (sizeof (*table), "weak-table");
 750   table->entries = allocate_entries (n, kind);
 751   table->kind = kind;
 752   table->n_items = 0;
 753   table->size = n;
 754   table->lower = 0;
 755   table->upper = 9 * n / 10;
 756   table->size_index = i;
 757   table->min_size_index = i;
 758   scm_i_pthread_mutex_init (&table->lock, NULL);
 759
 760   return scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
 761 }
 762
 763 void
 764 scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate)
 765 {
 766   scm_puts_unlocked ("#<", port);
 767   scm_puts_unlocked ("weak-table ", port);
 768   scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port);
 769   scm_putc_unlocked ('/', port);
 770   scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port);
 771   scm_puts_unlocked (">", port);
 772 }
 773
 774 static void
 775 do_vacuum_weak_table (SCM table)
 776 {
 777   scm_t_weak_table *t;
 778
 779   t = SCM_WEAK_TABLE (table);
 780
 781   if (scm_i_pthread_mutex_trylock (&t->lock) == 0)
 782     {
 783       vacuum_weak_table (t);
 784       scm_i_pthread_mutex_unlock (&t->lock);
 785     }
 786
 787   return;
 788 }
 789
 790 /* The before-gc C hook only runs if GC_table_start_callback is available,
 791    so if not, fall back on a finalizer-based implementation.  */
 792 static int
 793 weak_gc_callback (void **weak)
 794 {
 795   void *val = weak[0];
 796   void (*callback) (SCM) = weak[1];
 797
 798   if (!val)
 799     return 0;
 800
 801   callback (SCM_PACK_POINTER (val));
 802
 803   return 1;
 804 }
 805
 806 #ifdef HAVE_GC_TABLE_START_CALLBACK
 807 static void*
 808 weak_gc_hook (void *hook_data, void *fn_data, void *data)
 809 {
 810   if (!weak_gc_callback (fn_data))
 811     scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
 812
 813   return NULL;
 814 }
 815 #else
 816 static void
 817 weak_gc_finalizer (void *ptr, void *data)
 818 {
 819   if (weak_gc_callback (ptr))
 820     GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL);
 821 }
 822 #endif
 823
 824 static void
 825 scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
 826 {
 827   void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
 828
 829   weak[0] = SCM_UNPACK_POINTER (obj);
 830   weak[1] = (void*)callback;
 831   GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
 832
 833 #ifdef HAVE_GC_TABLE_START_CALLBACK
 834   scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0);
 835 #else
 836   GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
 837 #endif
 838 }
 839
 840 SCM
 841 scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
 842 {
 843   SCM ret;
 844
 845   ret = make_weak_table (k, kind);
 846
 847   scm_c_register_weak_gc_callback (ret, do_vacuum_weak_table);
 848
 849   return ret;
 850 }
 851
 852 SCM
 853 scm_weak_table_p (SCM obj)
 854 {
 855   return scm_from_bool (SCM_WEAK_TABLE_P (obj));
 856 }
 857
 858 SCM
 859 scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
 860                       scm_t_table_predicate_fn pred,
 861                       void *closure, SCM dflt)
 862 #define FUNC_NAME "weak-table-ref"
 863 {
 864   SCM ret;
 865   scm_t_weak_table *t;
 866
 867   SCM_VALIDATE_WEAK_TABLE (1, table);
 868
 869   t = SCM_WEAK_TABLE (table);
 870
 871   scm_i_pthread_mutex_lock (&t->lock);
 872
 873   ret = weak_table_ref (t, raw_hash, pred, closure, dflt);
 874
 875   scm_i_pthread_mutex_unlock (&t->lock);
 876
 877   return ret;
 878 }
 879 #undef FUNC_NAME
 880
 881 void
 882 scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
 883                         scm_t_table_predicate_fn pred,
 884                         void *closure, SCM key, SCM value)
 885 #define FUNC_NAME "weak-table-put!"
 886 {
 887   scm_t_weak_table *t;
 888
 889   SCM_VALIDATE_WEAK_TABLE (1, table);
 890
 891   t = SCM_WEAK_TABLE (table);
 892
 893   scm_i_pthread_mutex_lock (&t->lock);
 894
 895   weak_table_put_x (t, raw_hash, pred, closure, key, value);
 896
 897   scm_i_pthread_mutex_unlock (&t->lock);
 898 }
 899 #undef FUNC_NAME
 900
 901 void
 902 scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
 903                            scm_t_table_predicate_fn pred,
 904                            void *closure)
 905 #define FUNC_NAME "weak-table-remove!"
 906 {
 907   scm_t_weak_table *t;
 908
 909   SCM_VALIDATE_WEAK_TABLE (1, table);
 910
 911   t = SCM_WEAK_TABLE (table);
 912
 913   scm_i_pthread_mutex_lock (&t->lock);
 914
 915   weak_table_remove_x (t, raw_hash, pred, closure);
 916
 917   scm_i_pthread_mutex_unlock (&t->lock);
 918 }
 919 #undef FUNC_NAME
 920
 921 static int
 922 assq_predicate (SCM x, SCM y, void *closure)
 923 {
 924   return scm_is_eq (x, SCM_PACK_POINTER (closure));
 925 }
 926
 927 SCM
 928 scm_weak_table_refq (SCM table, SCM key, SCM dflt)
 929 {
 930   if (SCM_UNBNDP (dflt))
 931     dflt = SCM_BOOL_F;
 932
 933   return scm_c_weak_table_ref (table, scm_ihashq (key, -1),
 934                                assq_predicate, SCM_UNPACK_POINTER (key),
 935                                dflt);
 936 }
 937
 938 SCM
 939 scm_weak_table_putq_x (SCM table, SCM key, SCM value)
 940 {
 941   scm_c_weak_table_put_x (table, scm_ihashq (key, -1),
 942                           assq_predicate, SCM_UNPACK_POINTER (key),
 943                           key, value);
 944   return SCM_UNSPECIFIED;
 945 }
 946
 947 SCM
 948 scm_weak_table_remq_x (SCM table, SCM key)
 949 {
 950   scm_c_weak_table_remove_x (table, scm_ihashq (key, -1),
 951                              assq_predicate, SCM_UNPACK_POINTER (key));
 952   return SCM_UNSPECIFIED;
 953 }
 954
 955 SCM
 956 scm_weak_table_clear_x (SCM table)
 957 #define FUNC_NAME "weak-table-clear!"
 958 {
 959   scm_t_weak_table *t;
 960
 961   SCM_VALIDATE_WEAK_TABLE (1, table);
 962
 963   t = SCM_WEAK_TABLE (table);
 964
 965   scm_i_pthread_mutex_lock (&t->lock);
 966
 967   memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size);
 968   t->n_items = 0;
 969
 970   scm_i_pthread_mutex_unlock (&t->lock);
 971
 972   return SCM_UNSPECIFIED;
 973 }
 974 #undef FUNC_NAME
 975
 976 SCM
 977 scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
 978                        SCM init, SCM table)
 979 {
 980   scm_t_weak_table *t;
 981   scm_t_weak_entry *entries;
 982   unsigned long k, size;
 983
 984   t = SCM_WEAK_TABLE (table);
 985
 986   scm_i_pthread_mutex_lock (&t->lock);
 987
 988   size = t->size;
 989   entries = t->entries;
 990
 991   for (k = 0; k < size; k++)
 992     {
 993       if (entries[k].hash)
 994         {
 995           scm_t_weak_entry copy;
 996
 997           copy_weak_entry (&entries[k], &copy);
 998
 999           if (copy.key && copy.value)
1000             {
1001               /* Release table lock while we call the function.  */
1002               scm_i_pthread_mutex_unlock (&t->lock);
1003               init = proc (closure,
1004                            SCM_PACK (copy.key), SCM_PACK (copy.value),
1005                            init);
1006               scm_i_pthread_mutex_lock (&t->lock);
1007             }
1008         }
1009     }
1010
1011   scm_i_pthread_mutex_unlock (&t->lock);
1012
1013   return init;
1014 }
1015
1016 static SCM
1017 fold_trampoline (void *closure, SCM k, SCM v, SCM init)
1018 {
1019   return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init);
1020 }
1021
1022 SCM
1023 scm_weak_table_fold (SCM proc, SCM init, SCM table)
1024 #define FUNC_NAME "weak-table-fold"
1025 {
1026   SCM_VALIDATE_WEAK_TABLE (3, table);
1027   SCM_VALIDATE_PROC (1, proc);
1028
1029   return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table);
1030 }
1031 #undef FUNC_NAME
1032
1033 static SCM
1034 for_each_trampoline (void *closure, SCM k, SCM v, SCM seed)
1035 {
1036   scm_call_2 (SCM_PACK_POINTER (closure), k, v);
1037   return seed;
1038 }
1039
1040 SCM
1041 scm_weak_table_for_each (SCM proc, SCM table)
1042 #define FUNC_NAME "weak-table-for-each"
1043 {
1044   SCM_VALIDATE_WEAK_TABLE (2, table);
1045   SCM_VALIDATE_PROC (1, proc);
1046
1047   scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table);
1048
1049   return SCM_UNSPECIFIED;
1050 }
1051 #undef FUNC_NAME
1052
1053 static SCM
1054 map_trampoline (void *closure, SCM k, SCM v, SCM seed)
1055 {
1056   return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed);
1057 }
1058
1059 SCM
1060 scm_weak_table_map_to_list (SCM proc, SCM table)
1061 #define FUNC_NAME "weak-table-map->list"
1062 {
1063   SCM_VALIDATE_WEAK_TABLE (2, table);
1064   SCM_VALIDATE_PROC (1, proc);
1065
1066   return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table);
1067 }
1068 #undef FUNC_NAME
1069
1070
1071 \f
1072
1073 /* Legacy interface.  */
1074
1075 SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
1076             (SCM n),
1077             "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
1078             "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
1079             "Return a weak hash table with @var{size} buckets.\n"
1080             "\n"
1081             "You can modify weak hash tables in exactly the same way you\n"
1082             "would modify regular hash tables. (@pxref{Hash Tables})")
1083 #define FUNC_NAME s_scm_make_weak_key_hash_table
1084 {
1085   return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
1086                                 SCM_WEAK_TABLE_KIND_KEY);
1087 }
1088 #undef FUNC_NAME
1089
1090
1091 SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
1092             (SCM n),
1093             "Return a hash table with weak values with @var{size} buckets.\n"
1094             "(@pxref{Hash Tables})")
1095 #define FUNC_NAME s_scm_make_weak_value_hash_table
1096 {
1097   return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
1098                                 SCM_WEAK_TABLE_KIND_VALUE);
1099 }
1100 #undef FUNC_NAME
1101
1102
1103 SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
1104             (SCM n),
1105             "Return a hash table with weak keys and values with @var{size}\n"
1106             "buckets.  (@pxref{Hash Tables})")
1107 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
1108 {
1109   return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
1110                                 SCM_WEAK_TABLE_KIND_BOTH);
1111 }
1112 #undef FUNC_NAME
1113
1114
1115 SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
1116            (SCM obj),
1117             "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
1118             "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
1119             "Return @code{#t} if @var{obj} is the specified weak hash\n"
1120             "table. Note that a doubly weak hash table is neither a weak key\n"
1121             "nor a weak value hash table.")
1122 #define FUNC_NAME s_scm_weak_key_hash_table_p
1123 {
1124   return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
1125                         SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY);
1126 }
1127 #undef FUNC_NAME
1128
1129
1130 SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
1131             (SCM obj),
1132             "Return @code{#t} if @var{obj} is a weak value hash table.")
1133 #define FUNC_NAME s_scm_weak_value_hash_table_p
1134 {
1135   return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
1136                         SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE);
1137 }
1138 #undef FUNC_NAME
1139
1140
1141 SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
1142             (SCM obj),
1143             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
1144 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
1145 {
1146   return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
1147                         SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH);
1148 }
1149 #undef FUNC_NAME
1150
1151
1152
1153 \f
1154
1155 void
1156 scm_weak_table_prehistory (void)
1157 {
1158   weak_key_gc_kind =
1159     GC_new_kind (GC_new_free_list (),
1160                  GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0),
1161                  0, 0);
1162   weak_value_gc_kind =
1163     GC_new_kind (GC_new_free_list (),
1164                  GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0),
1165                  0, 0);
1166 }
1167
1168 void
1169 scm_init_weak_table ()
1170 {
1171 #include "libguile/weak-table.x"
1172 }
1173
1174 /*
1175   Local Variables:
1176   c-file-style: "gnu"
1177   End:
1178 */