libguile/weak-table.c

   1 /* Copyright (C) 2011 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) SCM_HEAP_OBJECT_BASE (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) SCM_HEAP_OBJECT_BASE (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, SCM_HEAP_OBJECT_BASE (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, SCM_HEAP_OBJECT_BASE (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*) SCM_HEAP_OBJECT_BASE (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*) SCM_HEAP_OBJECT_BASE (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 void
 408 resize_table (scm_t_weak_table *table)
 409 {
 410   scm_t_weak_entry *old_entries, *new_entries;
 411   int i;
 412   unsigned long old_size, new_size, old_k;
 413
 414   old_entries = table->entries;
 415   old_size = table->size;
 416
 417   if (table->n_items < table->lower)
 418     {
 419       /* rehashing is not triggered when i <= min_size */
 420       i = table->size_index;
 421       do
 422         --i;
 423       while (i > table->min_size_index
 424              && table->n_items < hashtable_size[i] / 4);
 425     }
 426   else
 427     {
 428       i = table->size_index + 1;
 429       if (i >= HASHTABLE_SIZE_N)
 430         /* The biggest size currently is 230096423, which for a 32-bit
 431            machine will occupy 2.3GB of memory at a load of 80%.  There
 432            is probably something better to do here, but if you have a
 433            weak map of that size, you are hosed in any case.  */
 434         abort ();
 435     }
 436
 437   new_size = hashtable_size[i];
 438   new_entries = allocate_entries (new_size, table->kind);
 439
 440   table->size_index = i;
 441   table->size = new_size;
 442   if (i <= table->min_size_index)
 443     table->lower = 0;
 444   else
 445     table->lower = new_size / 5;
 446   table->upper = 9 * new_size / 10;
 447   table->n_items = 0;
 448   table->entries = new_entries;
 449
 450   for (old_k = 0; old_k < old_size; old_k++)
 451     {
 452       scm_t_weak_entry copy;
 453       unsigned long new_k, distance;
 454
 455       if (!old_entries[old_k].hash)
 456         continue;
 457
 458       copy_weak_entry (&old_entries[old_k], &copy);
 459
 460       if (!copy.key || !copy.value)
 461         continue;
 462
 463       new_k = hash_to_index (copy.hash, new_size);
 464
 465       for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
 466         {
 467           unsigned long other_hash = new_entries[new_k].hash;
 468
 469           if (!other_hash)
 470             /* Found an empty entry. */
 471             break;
 472
 473           /* Displace the entry if our distance is less, otherwise keep
 474              looking. */
 475           if (entry_distance (other_hash, new_k, new_size) < distance)
 476             {
 477               rob_from_rich (table, new_k);
 478               break;
 479             }
 480         }
 481
 482       table->n_items++;
 483       new_entries[new_k].hash = copy.hash;
 484       new_entries[new_k].key = copy.key;
 485       new_entries[new_k].value = copy.value;
 486
 487       register_disappearing_links (&new_entries[new_k],
 488                                    SCM_PACK (copy.key), SCM_PACK (copy.value),
 489                                    table->kind);
 490     }
 491 }
 492
 493 /* Run after GC via do_vacuum_weak_table, this function runs over the
 494    whole table, removing lost weak references, reshuffling the table as it
 495    goes.  It might resize the table if it reaps enough entries.  */
 496 static void
 497 vacuum_weak_table (scm_t_weak_table *table)
 498 {
 499   scm_t_weak_entry *entries = table->entries;
 500   unsigned long size = table->size;
 501   unsigned long k;
 502
 503   for (k = 0; k < size; k++)
 504     {
 505       unsigned long hash = entries[k].hash;
 506
 507       if (hash)
 508         {
 509           scm_t_weak_entry copy;
 510
 511           copy_weak_entry (&entries[k], &copy);
 512
 513           if (!copy.key || !copy.value)
 514             /* Lost weak reference; reshuffle.  */
 515             {
 516               give_to_poor (table, k);
 517               table->n_items--;
 518             }
 519         }
 520     }
 521
 522   if (table->n_items < table->lower)
 523     resize_table (table);
 524 }
 525
 526
 527 \f
 528
 529 static SCM
 530 weak_table_ref (scm_t_weak_table *table, unsigned long hash,
 531                 scm_t_table_predicate_fn pred, void *closure,
 532                 SCM dflt)
 533 {
 534   unsigned long k, distance, size;
 535   scm_t_weak_entry *entries;
 536
 537   size = table->size;
 538   entries = table->entries;
 539
 540   hash = (hash << 1) | 0x1;
 541   k = hash_to_index (hash, size);
 542
 543   for (distance = 0; distance < size; distance++, k = (k + 1) % size)
 544     {
 545       unsigned long other_hash;
 546
 547     retry:
 548       other_hash = entries[k].hash;
 549
 550       if (!other_hash)
 551         /* Not found. */
 552         return dflt;
 553
 554       if (hash == other_hash)
 555         {
 556           scm_t_weak_entry copy;
 557
 558           copy_weak_entry (&entries[k], &copy);
 559
 560           if (!copy.key || !copy.value)
 561             /* Lost weak reference; reshuffle.  */
 562             {
 563               give_to_poor (table, k);
 564               table->n_items--;
 565               goto retry;
 566             }
 567
 568           if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
 569             /* Found. */
 570             return SCM_PACK (copy.value);
 571         }
 572
 573       /* If the entry's distance is less, our key is not in the table.  */
 574       if (entry_distance (other_hash, k, size) < distance)
 575         return dflt;
 576     }
 577
 578   /* If we got here, then we were unfortunate enough to loop through the
 579      whole table.  Shouldn't happen, but hey.  */
 580   return dflt;
 581 }
 582
 583
 584 static void
 585 weak_table_put_x (scm_t_weak_table *table, unsigned long hash,
 586                   scm_t_table_predicate_fn pred, void *closure,
 587                   SCM key, SCM value)
 588 {
 589   unsigned long k, distance, size;
 590   scm_t_weak_entry *entries;
 591
 592   size = table->size;
 593   entries = table->entries;
 594
 595   hash = (hash << 1) | 0x1;
 596   k = hash_to_index (hash, size);
 597
 598   for (distance = 0; ; distance++, k = (k + 1) % size)
 599     {
 600       unsigned long other_hash;
 601
 602     retry:
 603       other_hash = entries[k].hash;
 604
 605       if (!other_hash)
 606         /* Found an empty entry. */
 607         break;
 608
 609       if (other_hash == hash)
 610         {
 611           scm_t_weak_entry copy;
 612
 613           copy_weak_entry (&entries[k], &copy);
 614
 615           if (!copy.key || !copy.value)
 616             /* Lost weak reference; reshuffle.  */
 617             {
 618               give_to_poor (table, k);
 619               table->n_items--;
 620               goto retry;
 621             }
 622
 623           if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
 624             /* Found an entry with this key. */
 625             break;
 626         }
 627
 628       if (table->n_items > table->upper)
 629         /* Full table, time to resize.  */
 630         {
 631           resize_table (table);
 632           return weak_table_put_x (table, hash >> 1, pred, closure, key, value);
 633         }
 634
 635       /* Displace the entry if our distance is less, otherwise keep
 636          looking. */
 637       if (entry_distance (other_hash, k, size) < distance)
 638         {
 639           rob_from_rich (table, k);
 640           break;
 641         }
 642     }
 643
 644   if (entries[k].hash)
 645     unregister_disappearing_links (&entries[k], table->kind);
 646   else
 647     table->n_items++;
 648
 649   entries[k].hash = hash;
 650   entries[k].key = SCM_UNPACK (key);
 651   entries[k].value = SCM_UNPACK (value);
 652
 653   register_disappearing_links (&entries[k], key, value, table->kind);
 654 }
 655
 656
 657 static void
 658 weak_table_remove_x (scm_t_weak_table *table, unsigned long hash,
 659                    scm_t_table_predicate_fn pred, void *closure)
 660 {
 661   unsigned long k, distance, size;
 662   scm_t_weak_entry *entries;
 663
 664   size = table->size;
 665   entries = table->entries;
 666
 667   hash = (hash << 1) | 0x1;
 668   k = hash_to_index (hash, size);
 669
 670   for (distance = 0; distance < size; distance++, k = (k + 1) % size)
 671     {
 672       unsigned long other_hash;
 673
 674     retry:
 675       other_hash = entries[k].hash;
 676
 677       if (!other_hash)
 678         /* Not found. */
 679         return;
 680
 681       if (other_hash == hash)
 682         {
 683           scm_t_weak_entry copy;
 684
 685           copy_weak_entry (&entries[k], &copy);
 686
 687           if (!copy.key || !copy.value)
 688             /* Lost weak reference; reshuffle.  */
 689             {
 690               give_to_poor (table, k);
 691               table->n_items--;
 692               goto retry;
 693             }
 694
 695           if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
 696             /* Found an entry with this key. */
 697             {
 698               entries[k].hash = 0;
 699               entries[k].key = 0;
 700               entries[k].value = 0;
 701
 702               unregister_disappearing_links (&entries[k], table->kind);
 703
 704               if (--table->n_items < table->lower)
 705                 resize_table (table);
 706               else
 707                 give_to_poor (table, k);
 708
 709               return;
 710             }
 711         }
 712
 713       /* If the entry's distance is less, our key is not in the table.  */
 714       if (entry_distance (other_hash, k, size) < distance)
 715         return;
 716     }
 717 }
 718
 719
 720 \f
 721 static SCM
 722 make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
 723 {
 724   scm_t_weak_table *table;
 725
 726   int i = 0, n = k ? k : 31;
 727   while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
 728     ++i;
 729   n = hashtable_size[i];
 730
 731   table = scm_gc_malloc (sizeof (*table), "weak-table");
 732   table->entries = allocate_entries (n, kind);
 733   table->kind = kind;
 734   table->n_items = 0;
 735   table->size = n;
 736   table->lower = 0;
 737   table->upper = 9 * n / 10;
 738   table->size_index = i;
 739   table->min_size_index = i;
 740   scm_i_pthread_mutex_init (&table->lock, NULL);
 741
 742   return scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
 743 }
 744
 745 void
 746 scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate)
 747 {
 748   scm_puts_unlocked ("#<", port);
 749   scm_puts_unlocked ("weak-table ", port);
 750   scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port);
 751   scm_putc_unlocked ('/', port);
 752   scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port);
 753   scm_puts_unlocked (">", port);
 754 }
 755
 756 static void
 757 do_vacuum_weak_table (SCM table)
 758 {
 759   scm_t_weak_table *t;
 760
 761   t = SCM_WEAK_TABLE (table);
 762
 763   if (scm_i_pthread_mutex_trylock (&t->lock) == 0)
 764     {
 765       vacuum_weak_table (t);
 766       scm_i_pthread_mutex_unlock (&t->lock);
 767     }
 768
 769   return;
 770 }
 771
 772 /* The before-gc C hook only runs if GC_table_start_callback is available,
 773    so if not, fall back on a finalizer-based implementation.  */
 774 static int
 775 weak_gc_callback (void **weak)
 776 {
 777   void *val = weak[0];
 778   void (*callback) (SCM) = weak[1];
 779
 780   if (!val)
 781     return 0;
 782
 783   callback (SCM_PACK_POINTER (val));
 784
 785   return 1;
 786 }
 787
 788 #ifdef HAVE_GC_TABLE_START_CALLBACK
 789 static void*
 790 weak_gc_hook (void *hook_data, void *fn_data, void *data)
 791 {
 792   if (!weak_gc_callback (fn_data))
 793     scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
 794
 795   return NULL;
 796 }
 797 #else
 798 static void
 799 weak_gc_finalizer (void *ptr, void *data)
 800 {
 801   if (weak_gc_callback (ptr))
 802     GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL);
 803 }
 804 #endif
 805
 806 static void
 807 scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
 808 {
 809   void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
 810
 811   weak[0] = SCM_UNPACK_POINTER (obj);
 812   weak[1] = (void*)callback;
 813   GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM_HEAP_OBJECT_BASE (obj));
 814
 815 #ifdef HAVE_GC_TABLE_START_CALLBACK
 816   scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0);
 817 #else
 818   GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
 819 #endif
 820 }
 821
 822 SCM
 823 scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
 824 {
 825   SCM ret;
 826
 827   ret = make_weak_table (k, kind);
 828
 829   scm_c_register_weak_gc_callback (ret, do_vacuum_weak_table);
 830
 831   return ret;
 832 }
 833
 834 SCM
 835 scm_weak_table_p (SCM obj)
 836 {
 837   return scm_from_bool (SCM_WEAK_TABLE_P (obj));
 838 }
 839
 840 SCM
 841 scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
 842                       scm_t_table_predicate_fn pred,
 843                       void *closure, SCM dflt)
 844 #define FUNC_NAME "weak-table-ref"
 845 {
 846   SCM ret;
 847   scm_t_weak_table *t;
 848
 849   SCM_VALIDATE_WEAK_TABLE (1, table);
 850
 851   t = SCM_WEAK_TABLE (table);
 852
 853   scm_i_pthread_mutex_lock (&t->lock);
 854
 855   ret = weak_table_ref (t, raw_hash, pred, closure, dflt);
 856
 857   scm_i_pthread_mutex_unlock (&t->lock);
 858
 859   return ret;
 860 }
 861 #undef FUNC_NAME
 862
 863 void
 864 scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
 865                         scm_t_table_predicate_fn pred,
 866                         void *closure, SCM key, SCM value)
 867 #define FUNC_NAME "weak-table-put!"
 868 {
 869   scm_t_weak_table *t;
 870
 871   SCM_VALIDATE_WEAK_TABLE (1, table);
 872
 873   t = SCM_WEAK_TABLE (table);
 874
 875   scm_i_pthread_mutex_lock (&t->lock);
 876
 877   weak_table_put_x (t, raw_hash, pred, closure, key, value);
 878
 879   scm_i_pthread_mutex_unlock (&t->lock);
 880 }
 881 #undef FUNC_NAME
 882
 883 void
 884 scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
 885                            scm_t_table_predicate_fn pred,
 886                            void *closure)
 887 #define FUNC_NAME "weak-table-remove!"
 888 {
 889   scm_t_weak_table *t;
 890
 891   SCM_VALIDATE_WEAK_TABLE (1, table);
 892
 893   t = SCM_WEAK_TABLE (table);
 894
 895   scm_i_pthread_mutex_lock (&t->lock);
 896
 897   weak_table_remove_x (t, raw_hash, pred, closure);
 898
 899   scm_i_pthread_mutex_unlock (&t->lock);
 900 }
 901 #undef FUNC_NAME
 902
 903 static int
 904 assq_predicate (SCM x, SCM y, void *closure)
 905 {
 906   return scm_is_eq (x, SCM_PACK_POINTER (closure));
 907 }
 908
 909 SCM
 910 scm_weak_table_refq (SCM table, SCM key, SCM dflt)
 911 {
 912   if (SCM_UNBNDP (dflt))
 913     dflt = SCM_BOOL_F;
 914
 915   return scm_c_weak_table_ref (table, scm_ihashq (key, -1),
 916                                assq_predicate, SCM_UNPACK_POINTER (key),
 917                                dflt);
 918 }
 919
 920 SCM
 921 scm_weak_table_putq_x (SCM table, SCM key, SCM value)
 922 {
 923   scm_c_weak_table_put_x (table, scm_ihashq (key, -1),
 924                           assq_predicate, SCM_UNPACK_POINTER (key),
 925                           key, value);
 926   return SCM_UNSPECIFIED;
 927 }
 928
 929 SCM
 930 scm_weak_table_remq_x (SCM table, SCM key)
 931 {
 932   scm_c_weak_table_remove_x (table, scm_ihashq (key, -1),
 933                              assq_predicate, SCM_UNPACK_POINTER (key));
 934   return SCM_UNSPECIFIED;
 935 }
 936
 937 SCM
 938 scm_weak_table_clear_x (SCM table)
 939 #define FUNC_NAME "weak-table-clear!"
 940 {
 941   scm_t_weak_table *t;
 942
 943   SCM_VALIDATE_WEAK_TABLE (1, table);
 944
 945   t = SCM_WEAK_TABLE (table);
 946
 947   scm_i_pthread_mutex_lock (&t->lock);
 948
 949   memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size);
 950   t->n_items = 0;
 951
 952   scm_i_pthread_mutex_unlock (&t->lock);
 953
 954   return SCM_UNSPECIFIED;
 955 }
 956 #undef FUNC_NAME
 957
 958 SCM
 959 scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
 960                        SCM init, SCM table)
 961 {
 962   scm_t_weak_table *t;
 963   scm_t_weak_entry *entries;
 964   unsigned long k, size;
 965
 966   t = SCM_WEAK_TABLE (table);
 967
 968   scm_i_pthread_mutex_lock (&t->lock);
 969
 970   size = t->size;
 971   entries = t->entries;
 972
 973   for (k = 0; k < size; k++)
 974     {
 975       if (entries[k].hash)
 976         {
 977           scm_t_weak_entry copy;
 978
 979           copy_weak_entry (&entries[k], &copy);
 980
 981           if (copy.key && copy.value)
 982             {
 983               /* Release table lock while we call the function.  */
 984               scm_i_pthread_mutex_unlock (&t->lock);
 985               init = proc (closure,
 986                            SCM_PACK (copy.key), SCM_PACK (copy.value),
 987                            init);
 988               scm_i_pthread_mutex_lock (&t->lock);
 989             }
 990         }
 991     }
 992
 993   scm_i_pthread_mutex_unlock (&t->lock);
 994
 995   return init;
 996 }
 997
 998 static SCM
 999 fold_trampoline (void *closure, SCM k, SCM v, SCM init)
1000 {
1001   return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init);
1002 }
1003
1004 SCM
1005 scm_weak_table_fold (SCM proc, SCM init, SCM table)
1006 #define FUNC_NAME "weak-table-fold"
1007 {
1008   SCM_VALIDATE_WEAK_TABLE (3, table);
1009   SCM_VALIDATE_PROC (1, proc);
1010
1011   return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table);
1012 }
1013 #undef FUNC_NAME
1014
1015 static SCM
1016 for_each_trampoline (void *closure, SCM k, SCM v, SCM seed)
1017 {
1018   scm_call_2 (SCM_PACK_POINTER (closure), k, v);
1019   return seed;
1020 }
1021
1022 SCM
1023 scm_weak_table_for_each (SCM proc, SCM table)
1024 #define FUNC_NAME "weak-table-for-each"
1025 {
1026   SCM_VALIDATE_WEAK_TABLE (2, table);
1027   SCM_VALIDATE_PROC (1, proc);
1028
1029   scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table);
1030
1031   return SCM_UNSPECIFIED;
1032 }
1033 #undef FUNC_NAME
1034
1035 static SCM
1036 map_trampoline (void *closure, SCM k, SCM v, SCM seed)
1037 {
1038   return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed);
1039 }
1040
1041 SCM
1042 scm_weak_table_map_to_list (SCM proc, SCM table)
1043 #define FUNC_NAME "weak-table-map->list"
1044 {
1045   SCM_VALIDATE_WEAK_TABLE (2, table);
1046   SCM_VALIDATE_PROC (1, proc);
1047
1048   return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table);
1049 }
1050 #undef FUNC_NAME
1051
1052
1053 \f
1054
1055 /* Legacy interface.  */
1056
1057 SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
1058             (SCM n),
1059             "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
1060             "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
1061             "Return a weak hash table with @var{size} buckets.\n"
1062             "\n"
1063             "You can modify weak hash tables in exactly the same way you\n"
1064             "would modify regular hash tables. (@pxref{Hash Tables})")
1065 #define FUNC_NAME s_scm_make_weak_key_hash_table
1066 {
1067   return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
1068                                 SCM_WEAK_TABLE_KIND_KEY);
1069 }
1070 #undef FUNC_NAME
1071
1072
1073 SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
1074             (SCM n),
1075             "Return a hash table with weak values with @var{size} buckets.\n"
1076             "(@pxref{Hash Tables})")
1077 #define FUNC_NAME s_scm_make_weak_value_hash_table
1078 {
1079   return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
1080                                 SCM_WEAK_TABLE_KIND_VALUE);
1081 }
1082 #undef FUNC_NAME
1083
1084
1085 SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
1086             (SCM n),
1087             "Return a hash table with weak keys and values with @var{size}\n"
1088             "buckets.  (@pxref{Hash Tables})")
1089 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
1090 {
1091   return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
1092                                 SCM_WEAK_TABLE_KIND_BOTH);
1093 }
1094 #undef FUNC_NAME
1095
1096
1097 SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
1098            (SCM obj),
1099             "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
1100             "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
1101             "Return @code{#t} if @var{obj} is the specified weak hash\n"
1102             "table. Note that a doubly weak hash table is neither a weak key\n"
1103             "nor a weak value hash table.")
1104 #define FUNC_NAME s_scm_weak_key_hash_table_p
1105 {
1106   return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
1107                         SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY);
1108 }
1109 #undef FUNC_NAME
1110
1111
1112 SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
1113             (SCM obj),
1114             "Return @code{#t} if @var{obj} is a weak value hash table.")
1115 #define FUNC_NAME s_scm_weak_value_hash_table_p
1116 {
1117   return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
1118                         SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE);
1119 }
1120 #undef FUNC_NAME
1121
1122
1123 SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
1124             (SCM obj),
1125             "Return @code{#t} if @var{obj} is a doubly weak hash table.")
1126 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
1127 {
1128   return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
1129                         SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH);
1130 }
1131 #undef FUNC_NAME
1132
1133
1134
1135 \f
1136
1137 void
1138 scm_weak_table_prehistory (void)
1139 {
1140   weak_key_gc_kind =
1141     GC_new_kind (GC_new_free_list (),
1142                  GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0),
1143                  0, 0);
1144   weak_value_gc_kind =
1145     GC_new_kind (GC_new_free_list (),
1146                  GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0),
1147                  0, 0);
1148 }
1149
1150 void
1151 scm_init_weak_table ()
1152 {
1153 #include "libguile/weak-table.x"
1154 }
1155
1156 /*
1157   Local Variables:
1158   c-file-style: "gnu"
1159   End:
1160 */