1 /* Copyright (C) 2011 Free Software Foundation, Inc.
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.
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.
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
27 #include "libguile/bdw-gc.h"
28 #include <gc/gc_mark.h>
30 #include "libguile/_scm.h"
31 #include "libguile/hash.h"
32 #include "libguile/eval.h"
33 #include "libguile/ports.h"
35 #include "libguile/validate.h"
36 #include "libguile/weak-table.h"
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.
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.
51 Collisions are handled using linear probing with the Robin Hood
52 technique. See Pedro Celis' paper, "Robin Hood Hashing":
54 http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
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.
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.
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.
73 Implementation-wise, there are two things to note.
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
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.
97 struct weak_entry_data
{
99 scm_t_weak_entry
*out
;
103 do_copy_weak_entry (void *data
)
105 struct weak_entry_data
*e
= data
;
107 e
->out
->hash
= e
->in
->hash
;
108 e
->out
->key
= e
->in
->key
;
109 e
->out
->value
= e
->in
->value
;
115 copy_weak_entry (scm_t_weak_entry
*src
, scm_t_weak_entry
*dst
)
117 struct weak_entry_data data
;
122 GC_call_with_alloc_lock (do_copy_weak_entry
, &data
);
126 register_disappearing_links (scm_t_weak_entry
*entry
,
128 scm_t_weak_table_kind kind
)
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
));
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
));
144 unregister_disappearing_links (scm_t_weak_entry
*entry
,
145 scm_t_weak_table_kind kind
)
147 if (kind
== SCM_WEAK_TABLE_KIND_KEY
|| kind
== SCM_WEAK_TABLE_KIND_BOTH
)
148 GC_unregister_disappearing_link ((GC_PTR
) &entry
->key
);
150 if (kind
== SCM_WEAK_TABLE_KIND_VALUE
|| kind
== SCM_WEAK_TABLE_KIND_BOTH
)
151 GC_unregister_disappearing_link ((GC_PTR
) &entry
->value
);
155 move_weak_entry (scm_t_weak_entry
*from
, scm_t_weak_entry
*to
,
156 scm_t_weak_table_kind kind
)
160 scm_t_weak_entry copy
;
162 copy_weak_entry (from
, ©
);
163 to
->hash
= copy
.hash
;
165 to
->value
= copy
.value
;
167 unregister_disappearing_links (from
, kind
);
168 register_disappearing_links (to
,
169 SCM_PACK (copy
.key
), SCM_PACK (copy
.value
),
182 scm_t_weak_entry
*entries
; /* the data */
183 scm_i_pthread_mutex_t lock
; /* the lock */
184 scm_t_weak_table_kind kind
; /* what kind of table it is */
185 unsigned long size
; /* total number of slots. */
186 unsigned long n_items
; /* number of items in table */
187 unsigned long lower
; /* when to shrink */
188 unsigned long upper
; /* when to grow */
189 int size_index
; /* index into hashtable_size */
190 int min_size_index
; /* minimum size_index */
194 #define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table))
195 #define SCM_VALIDATE_WEAK_TABLE(pos, arg) \
196 SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table")
197 #define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x))
201 hash_to_index (unsigned long hash
, unsigned long size
)
203 return (hash
>> 1) % size
;
207 entry_distance (unsigned long hash
, unsigned long k
, unsigned long size
)
209 unsigned long origin
= hash_to_index (hash
, size
);
214 /* The other key was displaced and wrapped around. */
215 return size
- origin
+ k
;
219 rob_from_rich (scm_t_weak_table
*table
, unsigned long k
)
221 unsigned long empty
, size
;
225 /* If we are to free up slot K in the table, we need room to do so. */
226 assert (table
->n_items
< size
);
230 empty
= (empty
+ 1) % size
;
231 while (table
->entries
[empty
].hash
);
235 unsigned long last
= empty
? (empty
- 1) : (size
- 1);
236 move_weak_entry (&table
->entries
[last
], &table
->entries
[empty
],
242 table
->entries
[empty
].hash
= 0;
243 table
->entries
[empty
].key
= 0;
244 table
->entries
[empty
].value
= 0;
248 give_to_poor (scm_t_weak_table
*table
, unsigned long k
)
250 /* Slot K was just freed up; possibly shuffle others down. */
251 unsigned long size
= table
->size
;
255 unsigned long next
= (k
+ 1) % size
;
257 scm_t_weak_entry copy
;
259 hash
= table
->entries
[next
].hash
;
261 if (!hash
|| hash_to_index (hash
, size
) == next
)
264 copy_weak_entry (&table
->entries
[next
], ©
);
266 if (!copy
.key
|| !copy
.value
)
267 /* Lost weak reference. */
269 give_to_poor (table
, next
);
274 move_weak_entry (&table
->entries
[next
], &table
->entries
[k
],
280 /* We have shuffled down any entries that should be shuffled down; now
282 table
->entries
[k
].hash
= 0;
283 table
->entries
[k
].key
= 0;
284 table
->entries
[k
].value
= 0;
290 /* The GC "kinds" for singly-weak tables. */
291 static int weak_key_gc_kind
;
292 static int weak_value_gc_kind
;
294 static struct GC_ms_entry
*
295 mark_weak_key_table (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
296 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
298 scm_t_weak_entry
*entries
= (scm_t_weak_entry
*) addr
;
299 unsigned long k
, size
= GC_size (addr
) / sizeof (scm_t_weak_entry
);
301 for (k
= 0; k
< size
; k
++)
302 if (entries
[k
].hash
&& entries
[k
].key
)
304 SCM value
= SCM_PACK (entries
[k
].value
);
305 mark_stack_ptr
= GC_MARK_AND_PUSH ((GC_word
*) SCM_HEAP_OBJECT_BASE (value
),
306 mark_stack_ptr
, mark_stack_limit
,
310 return mark_stack_ptr
;
313 static struct GC_ms_entry
*
314 mark_weak_value_table (GC_word
*addr
, struct GC_ms_entry
*mark_stack_ptr
,
315 struct GC_ms_entry
*mark_stack_limit
, GC_word env
)
317 scm_t_weak_entry
*entries
= (scm_t_weak_entry
*) addr
;
318 unsigned long k
, size
= GC_size (addr
) / sizeof (scm_t_weak_entry
);
320 for (k
= 0; k
< size
; k
++)
321 if (entries
[k
].hash
&& entries
[k
].value
)
323 SCM key
= SCM_PACK (entries
[k
].key
);
324 mark_stack_ptr
= GC_MARK_AND_PUSH ((GC_word
*) SCM_HEAP_OBJECT_BASE (key
),
325 mark_stack_ptr
, mark_stack_limit
,
329 return mark_stack_ptr
;
332 static scm_t_weak_entry
*
333 allocate_entries (unsigned long size
, scm_t_weak_table_kind kind
)
335 scm_t_weak_entry
*ret
;
336 size_t bytes
= size
* sizeof (*ret
);
340 case SCM_WEAK_TABLE_KIND_KEY
:
341 ret
= GC_generic_malloc (bytes
, weak_key_gc_kind
);
343 case SCM_WEAK_TABLE_KIND_VALUE
:
344 ret
= GC_generic_malloc (bytes
, weak_value_gc_kind
);
346 case SCM_WEAK_TABLE_KIND_BOTH
:
347 ret
= scm_gc_malloc_pointerless (bytes
, "weak-table");
353 memset (ret
, 0, bytes
);
360 /* Growing or shrinking is triggered when the load factor
362 * L = N / S (N: number of items in table, S: bucket vector length)
364 * passes an upper limit of 0.9 or a lower limit of 0.2.
366 * The implementation stores the upper and lower number of items which
367 * trigger a resize in the hashtable object.
369 * Possible hash table sizes (primes) are stored in the array
373 static unsigned long hashtable_size
[] = {
374 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
375 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081,
376 57524111, 115048217, 230096423
379 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
382 resize_table (scm_t_weak_table
*table
)
384 scm_t_weak_entry
*old_entries
, *new_entries
;
386 unsigned long old_size
, new_size
, old_k
;
388 old_entries
= table
->entries
;
389 old_size
= table
->size
;
391 if (table
->n_items
< table
->lower
)
393 /* rehashing is not triggered when i <= min_size */
394 i
= table
->size_index
;
397 while (i
> table
->min_size_index
398 && table
->n_items
< hashtable_size
[i
] / 4);
402 i
= table
->size_index
+ 1;
403 if (i
>= HASHTABLE_SIZE_N
)
404 /* The biggest size currently is 230096423, which for a 32-bit
405 machine will occupy 2.3GB of memory at a load of 80%. There
406 is probably something better to do here, but if you have a
407 weak map of that size, you are hosed in any case. */
411 new_size
= hashtable_size
[i
];
412 new_entries
= allocate_entries (new_size
, table
->kind
);
414 table
->size_index
= i
;
415 table
->size
= new_size
;
416 if (i
<= table
->min_size_index
)
419 table
->lower
= new_size
/ 5;
420 table
->upper
= 9 * new_size
/ 10;
422 table
->entries
= new_entries
;
424 for (old_k
= 0; old_k
< old_size
; old_k
++)
426 scm_t_weak_entry copy
;
427 unsigned long new_k
, distance
;
429 if (!old_entries
[old_k
].hash
)
432 copy_weak_entry (&old_entries
[old_k
], ©
);
434 if (!copy
.key
|| !copy
.value
)
437 new_k
= hash_to_index (copy
.hash
, new_size
);
439 for (distance
= 0; ; distance
++, new_k
= (new_k
+ 1) % new_size
)
441 unsigned long other_hash
= new_entries
[new_k
].hash
;
444 /* Found an empty entry. */
447 /* Displace the entry if our distance is less, otherwise keep
449 if (entry_distance (other_hash
, new_k
, new_size
) < distance
)
451 rob_from_rich (table
, new_k
);
457 new_entries
[new_k
].hash
= copy
.hash
;
458 new_entries
[new_k
].key
= copy
.key
;
459 new_entries
[new_k
].value
= copy
.value
;
461 register_disappearing_links (&new_entries
[new_k
],
462 SCM_PACK (copy
.key
), SCM_PACK (copy
.value
),
467 /* Run after GC via do_vacuum_weak_table, this function runs over the
468 whole table, removing lost weak references, reshuffling the table as it
469 goes. It might resize the table if it reaps enough entries. */
471 vacuum_weak_table (scm_t_weak_table
*table
)
473 scm_t_weak_entry
*entries
= table
->entries
;
474 unsigned long size
= table
->size
;
477 for (k
= 0; k
< size
; k
++)
479 unsigned long hash
= entries
[k
].hash
;
483 scm_t_weak_entry copy
;
485 copy_weak_entry (&entries
[k
], ©
);
487 if (!copy
.key
|| !copy
.value
)
488 /* Lost weak reference; reshuffle. */
490 give_to_poor (table
, k
);
496 if (table
->n_items
< table
->lower
)
497 resize_table (table
);
504 weak_table_ref (scm_t_weak_table
*table
, unsigned long hash
,
505 scm_t_table_predicate_fn pred
, void *closure
,
508 unsigned long k
, distance
, size
;
509 scm_t_weak_entry
*entries
;
512 entries
= table
->entries
;
514 hash
= (hash
<< 1) | 0x1;
515 k
= hash_to_index (hash
, size
);
517 for (distance
= 0; distance
< size
; distance
++, k
= (k
+ 1) % size
)
519 unsigned long other_hash
;
522 other_hash
= entries
[k
].hash
;
528 if (hash
== other_hash
)
530 scm_t_weak_entry copy
;
532 copy_weak_entry (&entries
[k
], ©
);
534 if (!copy
.key
|| !copy
.value
)
535 /* Lost weak reference; reshuffle. */
537 give_to_poor (table
, k
);
542 if (pred (SCM_PACK (copy
.key
), SCM_PACK (copy
.value
), closure
))
544 return SCM_PACK (copy
.value
);
547 /* If the entry's distance is less, our key is not in the table. */
548 if (entry_distance (other_hash
, k
, size
) < distance
)
552 /* If we got here, then we were unfortunate enough to loop through the
553 whole table. Shouldn't happen, but hey. */
559 weak_table_put_x (scm_t_weak_table
*table
, unsigned long hash
,
560 scm_t_table_predicate_fn pred
, void *closure
,
563 unsigned long k
, distance
, size
;
564 scm_t_weak_entry
*entries
;
567 entries
= table
->entries
;
569 hash
= (hash
<< 1) | 0x1;
570 k
= hash_to_index (hash
, size
);
572 for (distance
= 0; ; distance
++, k
= (k
+ 1) % size
)
574 unsigned long other_hash
;
577 other_hash
= entries
[k
].hash
;
580 /* Found an empty entry. */
583 if (other_hash
== hash
)
585 scm_t_weak_entry copy
;
587 copy_weak_entry (&entries
[k
], ©
);
589 if (!copy
.key
|| !copy
.value
)
590 /* Lost weak reference; reshuffle. */
592 give_to_poor (table
, k
);
597 if (pred (SCM_PACK (copy
.key
), SCM_PACK (copy
.value
), closure
))
598 /* Found an entry with this key. */
602 if (table
->n_items
> table
->upper
)
603 /* Full table, time to resize. */
605 resize_table (table
);
606 return weak_table_put_x (table
, hash
>> 1, pred
, closure
, key
, value
);
609 /* Displace the entry if our distance is less, otherwise keep
611 if (entry_distance (other_hash
, k
, size
) < distance
)
613 rob_from_rich (table
, k
);
619 unregister_disappearing_links (&entries
[k
], table
->kind
);
623 entries
[k
].hash
= hash
;
624 entries
[k
].key
= SCM_UNPACK (key
);
625 entries
[k
].value
= SCM_UNPACK (value
);
627 register_disappearing_links (&entries
[k
], key
, value
, table
->kind
);
632 weak_table_remove_x (scm_t_weak_table
*table
, unsigned long hash
,
633 scm_t_table_predicate_fn pred
, void *closure
)
635 unsigned long k
, distance
, size
;
636 scm_t_weak_entry
*entries
;
639 entries
= table
->entries
;
641 hash
= (hash
<< 1) | 0x1;
642 k
= hash_to_index (hash
, size
);
644 for (distance
= 0; distance
< size
; distance
++, k
= (k
+ 1) % size
)
646 unsigned long other_hash
;
649 other_hash
= entries
[k
].hash
;
655 if (other_hash
== hash
)
657 scm_t_weak_entry copy
;
659 copy_weak_entry (&entries
[k
], ©
);
661 if (!copy
.key
|| !copy
.value
)
662 /* Lost weak reference; reshuffle. */
664 give_to_poor (table
, k
);
669 if (pred (SCM_PACK (copy
.key
), SCM_PACK (copy
.value
), closure
))
670 /* Found an entry with this key. */
674 entries
[k
].value
= 0;
676 unregister_disappearing_links (&entries
[k
], table
->kind
);
678 if (--table
->n_items
< table
->lower
)
679 resize_table (table
);
681 give_to_poor (table
, k
);
687 /* If the entry's distance is less, our key is not in the table. */
688 if (entry_distance (other_hash
, k
, size
) < distance
)
696 make_weak_table (unsigned long k
, scm_t_weak_table_kind kind
)
698 scm_t_weak_table
*table
;
700 int i
= 0, n
= k
? k
: 31;
701 while (i
+ 1 < HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
703 n
= hashtable_size
[i
];
705 table
= scm_gc_malloc (sizeof (*table
), "weak-table");
706 table
->entries
= allocate_entries (n
, kind
);
711 table
->upper
= 9 * n
/ 10;
712 table
->size_index
= i
;
713 table
->min_size_index
= i
;
714 scm_i_pthread_mutex_init (&table
->lock
, NULL
);
716 return scm_cell (scm_tc7_weak_table
, (scm_t_bits
)table
);
720 scm_i_weak_table_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
722 scm_puts_unlocked ("#<", port
);
723 scm_puts_unlocked ("weak-table ", port
);
724 scm_uintprint (SCM_WEAK_TABLE (exp
)->n_items
, 10, port
);
725 scm_putc_unlocked ('/', port
);
726 scm_uintprint (SCM_WEAK_TABLE (exp
)->size
, 10, port
);
727 scm_puts_unlocked (">", port
);
731 do_vacuum_weak_table (SCM table
)
735 t
= SCM_WEAK_TABLE (table
);
737 if (scm_i_pthread_mutex_trylock (&t
->lock
) == 0)
739 vacuum_weak_table (t
);
740 scm_i_pthread_mutex_unlock (&t
->lock
);
746 /* The before-gc C hook only runs if GC_table_start_callback is available,
747 so if not, fall back on a finalizer-based implementation. */
749 weak_gc_callback (void **weak
)
752 void (*callback
) (SCM
) = weak
[1];
757 callback (SCM_PACK_POINTER (val
));
762 #ifdef HAVE_GC_TABLE_START_CALLBACK
764 weak_gc_hook (void *hook_data
, void *fn_data
, void *data
)
766 if (!weak_gc_callback (fn_data
))
767 scm_c_hook_remove (&scm_before_gc_c_hook
, weak_gc_hook
, fn_data
);
773 weak_gc_finalizer (void *ptr
, void *data
)
775 if (weak_gc_callback (ptr
))
776 GC_REGISTER_FINALIZER_NO_ORDER (ptr
, weak_gc_finalizer
, data
, NULL
, NULL
);
781 scm_c_register_weak_gc_callback (SCM obj
, void (*callback
) (SCM
))
783 void **weak
= GC_MALLOC_ATOMIC (sizeof (void*) * 2);
785 weak
[0] = SCM_UNPACK_POINTER (obj
);
786 weak
[1] = (void*)callback
;
787 GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak
, SCM_HEAP_OBJECT_BASE (obj
));
789 #ifdef HAVE_GC_TABLE_START_CALLBACK
790 scm_c_hook_add (&scm_after_gc_c_hook
, weak_gc_hook
, weak
, 0);
792 GC_REGISTER_FINALIZER_NO_ORDER (weak
, weak_gc_finalizer
, NULL
, NULL
, NULL
);
797 scm_c_make_weak_table (unsigned long k
, scm_t_weak_table_kind kind
)
801 ret
= make_weak_table (k
, kind
);
803 scm_c_register_weak_gc_callback (ret
, do_vacuum_weak_table
);
809 scm_weak_table_p (SCM obj
)
811 return scm_from_bool (SCM_WEAK_TABLE_P (obj
));
815 scm_c_weak_table_ref (SCM table
, unsigned long raw_hash
,
816 scm_t_table_predicate_fn pred
,
817 void *closure
, SCM dflt
)
818 #define FUNC_NAME "weak-table-ref"
823 SCM_VALIDATE_WEAK_TABLE (1, table
);
825 t
= SCM_WEAK_TABLE (table
);
827 scm_i_pthread_mutex_lock (&t
->lock
);
829 ret
= weak_table_ref (t
, raw_hash
, pred
, closure
, dflt
);
831 scm_i_pthread_mutex_unlock (&t
->lock
);
838 scm_c_weak_table_put_x (SCM table
, unsigned long raw_hash
,
839 scm_t_table_predicate_fn pred
,
840 void *closure
, SCM key
, SCM value
)
841 #define FUNC_NAME "weak-table-put!"
845 SCM_VALIDATE_WEAK_TABLE (1, table
);
847 t
= SCM_WEAK_TABLE (table
);
849 scm_i_pthread_mutex_lock (&t
->lock
);
851 weak_table_put_x (t
, raw_hash
, pred
, closure
, key
, value
);
853 scm_i_pthread_mutex_unlock (&t
->lock
);
858 scm_c_weak_table_remove_x (SCM table
, unsigned long raw_hash
,
859 scm_t_table_predicate_fn pred
,
861 #define FUNC_NAME "weak-table-remove!"
865 SCM_VALIDATE_WEAK_TABLE (1, table
);
867 t
= SCM_WEAK_TABLE (table
);
869 scm_i_pthread_mutex_lock (&t
->lock
);
871 weak_table_remove_x (t
, raw_hash
, pred
, closure
);
873 scm_i_pthread_mutex_unlock (&t
->lock
);
878 assq_predicate (SCM x
, SCM y
, void *closure
)
880 return scm_is_eq (x
, SCM_PACK_POINTER (closure
));
884 scm_weak_table_refq (SCM table
, SCM key
, SCM dflt
)
886 if (SCM_UNBNDP (dflt
))
889 return scm_c_weak_table_ref (table
, scm_ihashq (key
, -1),
890 assq_predicate
, SCM_UNPACK_POINTER (key
),
895 scm_weak_table_putq_x (SCM table
, SCM key
, SCM value
)
897 scm_c_weak_table_put_x (table
, scm_ihashq (key
, -1),
898 assq_predicate
, SCM_UNPACK_POINTER (key
),
900 return SCM_UNSPECIFIED
;
904 scm_weak_table_remq_x (SCM table
, SCM key
)
906 scm_c_weak_table_remove_x (table
, scm_ihashq (key
, -1),
907 assq_predicate
, SCM_UNPACK_POINTER (key
));
908 return SCM_UNSPECIFIED
;
912 scm_weak_table_clear_x (SCM table
)
913 #define FUNC_NAME "weak-table-clear!"
917 SCM_VALIDATE_WEAK_TABLE (1, table
);
919 t
= SCM_WEAK_TABLE (table
);
921 scm_i_pthread_mutex_lock (&t
->lock
);
923 memset (t
->entries
, 0, sizeof (scm_t_weak_entry
) * t
->size
);
926 scm_i_pthread_mutex_unlock (&t
->lock
);
928 return SCM_UNSPECIFIED
;
933 scm_c_weak_table_fold (scm_t_table_fold_fn proc
, void *closure
,
937 scm_t_weak_entry
*entries
;
938 unsigned long k
, size
;
940 t
= SCM_WEAK_TABLE (table
);
942 scm_i_pthread_mutex_lock (&t
->lock
);
945 entries
= t
->entries
;
947 for (k
= 0; k
< size
; k
++)
951 scm_t_weak_entry copy
;
953 copy_weak_entry (&entries
[k
], ©
);
955 if (copy
.key
&& copy
.value
)
957 /* Release table lock while we call the function. */
958 scm_i_pthread_mutex_unlock (&t
->lock
);
959 init
= proc (closure
,
960 SCM_PACK (copy
.key
), SCM_PACK (copy
.value
),
962 scm_i_pthread_mutex_lock (&t
->lock
);
967 scm_i_pthread_mutex_unlock (&t
->lock
);
973 fold_trampoline (void *closure
, SCM k
, SCM v
, SCM init
)
975 return scm_call_3 (SCM_PACK_POINTER (closure
), k
, v
, init
);
979 scm_weak_table_fold (SCM proc
, SCM init
, SCM table
)
980 #define FUNC_NAME "weak-table-fold"
982 SCM_VALIDATE_WEAK_TABLE (3, table
);
983 SCM_VALIDATE_PROC (1, proc
);
985 return scm_c_weak_table_fold (fold_trampoline
, SCM_UNPACK_POINTER (proc
), init
, table
);
990 for_each_trampoline (void *closure
, SCM k
, SCM v
, SCM seed
)
992 scm_call_2 (SCM_PACK_POINTER (closure
), k
, v
);
997 scm_weak_table_for_each (SCM proc
, SCM table
)
998 #define FUNC_NAME "weak-table-for-each"
1000 SCM_VALIDATE_WEAK_TABLE (2, table
);
1001 SCM_VALIDATE_PROC (1, proc
);
1003 scm_c_weak_table_fold (for_each_trampoline
, SCM_UNPACK_POINTER (proc
), SCM_BOOL_F
, table
);
1005 return SCM_UNSPECIFIED
;
1010 map_trampoline (void *closure
, SCM k
, SCM v
, SCM seed
)
1012 return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure
), k
, v
), seed
);
1016 scm_weak_table_map_to_list (SCM proc
, SCM table
)
1017 #define FUNC_NAME "weak-table-map->list"
1019 SCM_VALIDATE_WEAK_TABLE (2, table
);
1020 SCM_VALIDATE_PROC (1, proc
);
1022 return scm_c_weak_table_fold (map_trampoline
, SCM_UNPACK_POINTER (proc
), SCM_EOL
, table
);
1029 /* Legacy interface. */
1031 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
1033 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
1034 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
1035 "Return a weak hash table with @var{size} buckets.\n"
1037 "You can modify weak hash tables in exactly the same way you\n"
1038 "would modify regular hash tables. (@pxref{Hash Tables})")
1039 #define FUNC_NAME s_scm_make_weak_key_hash_table
1041 return scm_c_make_weak_table (SCM_UNBNDP (n
) ? 0 : scm_to_ulong (n
),
1042 SCM_WEAK_TABLE_KIND_KEY
);
1047 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
1049 "Return a hash table with weak values with @var{size} buckets.\n"
1050 "(@pxref{Hash Tables})")
1051 #define FUNC_NAME s_scm_make_weak_value_hash_table
1053 return scm_c_make_weak_table (SCM_UNBNDP (n
) ? 0 : scm_to_ulong (n
),
1054 SCM_WEAK_TABLE_KIND_VALUE
);
1059 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
1061 "Return a hash table with weak keys and values with @var{size}\n"
1062 "buckets. (@pxref{Hash Tables})")
1063 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
1065 return scm_c_make_weak_table (SCM_UNBNDP (n
) ? 0 : scm_to_ulong (n
),
1066 SCM_WEAK_TABLE_KIND_BOTH
);
1071 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
1073 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
1074 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
1075 "Return @code{#t} if @var{obj} is the specified weak hash\n"
1076 "table. Note that a doubly weak hash table is neither a weak key\n"
1077 "nor a weak value hash table.")
1078 #define FUNC_NAME s_scm_weak_key_hash_table_p
1080 return scm_from_bool (SCM_WEAK_TABLE_P (obj
) &&
1081 SCM_WEAK_TABLE (obj
)->kind
== SCM_WEAK_TABLE_KIND_KEY
);
1086 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
1088 "Return @code{#t} if @var{obj} is a weak value hash table.")
1089 #define FUNC_NAME s_scm_weak_value_hash_table_p
1091 return scm_from_bool (SCM_WEAK_TABLE_P (obj
) &&
1092 SCM_WEAK_TABLE (obj
)->kind
== SCM_WEAK_TABLE_KIND_VALUE
);
1097 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
1099 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
1100 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
1102 return scm_from_bool (SCM_WEAK_TABLE_P (obj
) &&
1103 SCM_WEAK_TABLE (obj
)->kind
== SCM_WEAK_TABLE_KIND_BOTH
);
1112 scm_weak_table_prehistory (void)
1115 GC_new_kind (GC_new_free_list (),
1116 GC_MAKE_PROC (GC_new_proc (mark_weak_key_table
), 0),
1118 weak_value_gc_kind
=
1119 GC_new_kind (GC_new_free_list (),
1120 GC_MAKE_PROC (GC_new_proc (mark_weak_value_table
), 0),
1125 scm_init_weak_table ()
1127 #include "libguile/weak-table.x"