Commit | Line | Data |
---|---|---|
04023cce | 1 | /* Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
7005c60f AW |
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 | { | |
8c5bb729 | 130 | if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k) |
7005c60f AW |
131 | && (kind == SCM_WEAK_TABLE_KIND_KEY |
132 | || kind == SCM_WEAK_TABLE_KIND_BOTH)) | |
2aed2667 AW |
133 | SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key, |
134 | SCM2PTR (k)); | |
7005c60f | 135 | |
8c5bb729 | 136 | if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v) |
7005c60f AW |
137 | && (kind == SCM_WEAK_TABLE_KIND_VALUE |
138 | || kind == SCM_WEAK_TABLE_KIND_BOTH)) | |
2aed2667 AW |
139 | SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value, |
140 | SCM2PTR (v)); | |
7005c60f AW |
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) | |
2aed2667 | 148 | GC_unregister_disappearing_link ((void **) &entry->key); |
7005c60f AW |
149 | |
150 | if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH) | |
2aed2667 | 151 | GC_unregister_disappearing_link ((void **) &entry->value); |
7005c60f AW |
152 | } |
153 | ||
d7cb7f79 AW |
154 | #ifndef HAVE_GC_MOVE_DISAPPEARING_LINK |
155 | static void | |
156 | GC_move_disappearing_link (void **from, void **to) | |
157 | { | |
158 | GC_unregister_disappearing_link (from); | |
159 | SCM_I_REGISTER_DISAPPEARING_LINK (to, *to); | |
160 | } | |
161 | #endif | |
162 | ||
3dc9f419 AW |
163 | static void |
164 | move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to, | |
165 | SCM key, SCM value, scm_t_weak_table_kind kind) | |
166 | { | |
167 | if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH) | |
168 | && SCM_HEAP_OBJECT_P (key)) | |
d7cb7f79 | 169 | GC_move_disappearing_link ((void **) &from->key, (void **) &to->key); |
3dc9f419 AW |
170 | |
171 | if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH) | |
172 | && SCM_HEAP_OBJECT_P (value)) | |
d7cb7f79 | 173 | GC_move_disappearing_link ((void **) &from->value, (void **) &to->value); |
3dc9f419 AW |
174 | } |
175 | ||
7005c60f AW |
176 | static void |
177 | move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to, | |
178 | scm_t_weak_table_kind kind) | |
179 | { | |
180 | if (from->hash) | |
181 | { | |
182 | scm_t_weak_entry copy; | |
183 | ||
184 | copy_weak_entry (from, ©); | |
185 | to->hash = copy.hash; | |
186 | to->key = copy.key; | |
187 | to->value = copy.value; | |
188 | ||
3dc9f419 AW |
189 | move_disappearing_links (from, to, |
190 | SCM_PACK (copy.key), SCM_PACK (copy.value), | |
191 | kind); | |
7005c60f AW |
192 | } |
193 | else | |
194 | { | |
195 | to->hash = 0; | |
196 | to->key = 0; | |
197 | to->value = 0; | |
198 | } | |
199 | } | |
200 | ||
201 | ||
202 | typedef struct { | |
203 | scm_t_weak_entry *entries; /* the data */ | |
204 | scm_i_pthread_mutex_t lock; /* the lock */ | |
205 | scm_t_weak_table_kind kind; /* what kind of table it is */ | |
206 | unsigned long size; /* total number of slots. */ | |
207 | unsigned long n_items; /* number of items in table */ | |
208 | unsigned long lower; /* when to shrink */ | |
209 | unsigned long upper; /* when to grow */ | |
210 | int size_index; /* index into hashtable_size */ | |
211 | int min_size_index; /* minimum size_index */ | |
212 | } scm_t_weak_table; | |
213 | ||
214 | ||
dc7da0be | 215 | #define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table)) |
7005c60f AW |
216 | #define SCM_VALIDATE_WEAK_TABLE(pos, arg) \ |
217 | SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table") | |
218 | #define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x)) | |
219 | ||
220 | ||
221 | static unsigned long | |
222 | hash_to_index (unsigned long hash, unsigned long size) | |
223 | { | |
224 | return (hash >> 1) % size; | |
225 | } | |
226 | ||
227 | static unsigned long | |
228 | entry_distance (unsigned long hash, unsigned long k, unsigned long size) | |
229 | { | |
230 | unsigned long origin = hash_to_index (hash, size); | |
231 | ||
232 | if (k >= origin) | |
233 | return k - origin; | |
234 | else | |
235 | /* The other key was displaced and wrapped around. */ | |
236 | return size - origin + k; | |
237 | } | |
238 | ||
239 | static void | |
240 | rob_from_rich (scm_t_weak_table *table, unsigned long k) | |
241 | { | |
242 | unsigned long empty, size; | |
243 | ||
244 | size = table->size; | |
245 | ||
246 | /* If we are to free up slot K in the table, we need room to do so. */ | |
247 | assert (table->n_items < size); | |
248 | ||
249 | empty = k; | |
250 | do | |
251 | empty = (empty + 1) % size; | |
252 | while (table->entries[empty].hash); | |
253 | ||
254 | do | |
255 | { | |
256 | unsigned long last = empty ? (empty - 1) : (size - 1); | |
257 | move_weak_entry (&table->entries[last], &table->entries[empty], | |
258 | table->kind); | |
259 | empty = last; | |
260 | } | |
261 | while (empty != k); | |
262 | ||
263 | table->entries[empty].hash = 0; | |
264 | table->entries[empty].key = 0; | |
265 | table->entries[empty].value = 0; | |
266 | } | |
267 | ||
268 | static void | |
269 | give_to_poor (scm_t_weak_table *table, unsigned long k) | |
270 | { | |
271 | /* Slot K was just freed up; possibly shuffle others down. */ | |
272 | unsigned long size = table->size; | |
273 | ||
274 | while (1) | |
275 | { | |
276 | unsigned long next = (k + 1) % size; | |
277 | unsigned long hash; | |
278 | scm_t_weak_entry copy; | |
279 | ||
280 | hash = table->entries[next].hash; | |
281 | ||
282 | if (!hash || hash_to_index (hash, size) == next) | |
283 | break; | |
284 | ||
285 | copy_weak_entry (&table->entries[next], ©); | |
286 | ||
287 | if (!copy.key || !copy.value) | |
288 | /* Lost weak reference. */ | |
289 | { | |
290 | give_to_poor (table, next); | |
291 | table->n_items--; | |
292 | continue; | |
293 | } | |
294 | ||
295 | move_weak_entry (&table->entries[next], &table->entries[k], | |
296 | table->kind); | |
297 | ||
298 | k = next; | |
299 | } | |
300 | ||
301 | /* We have shuffled down any entries that should be shuffled down; now | |
302 | free the end. */ | |
303 | table->entries[k].hash = 0; | |
304 | table->entries[k].key = 0; | |
305 | table->entries[k].value = 0; | |
306 | } | |
307 | ||
308 | ||
309 | \f | |
310 | ||
311 | /* The GC "kinds" for singly-weak tables. */ | |
312 | static int weak_key_gc_kind; | |
313 | static int weak_value_gc_kind; | |
314 | ||
315 | static struct GC_ms_entry * | |
316 | mark_weak_key_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, | |
317 | struct GC_ms_entry *mark_stack_limit, GC_word env) | |
318 | { | |
319 | scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; | |
320 | unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); | |
321 | ||
322 | for (k = 0; k < size; k++) | |
323 | if (entries[k].hash && entries[k].key) | |
324 | { | |
325 | SCM value = SCM_PACK (entries[k].value); | |
0aed71aa | 326 | mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (value), |
7005c60f AW |
327 | mark_stack_ptr, mark_stack_limit, |
328 | NULL); | |
329 | } | |
330 | ||
331 | return mark_stack_ptr; | |
332 | } | |
333 | ||
334 | static struct GC_ms_entry * | |
335 | mark_weak_value_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, | |
336 | struct GC_ms_entry *mark_stack_limit, GC_word env) | |
337 | { | |
338 | scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; | |
339 | unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); | |
340 | ||
341 | for (k = 0; k < size; k++) | |
342 | if (entries[k].hash && entries[k].value) | |
343 | { | |
344 | SCM key = SCM_PACK (entries[k].key); | |
0aed71aa | 345 | mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key), |
7005c60f AW |
346 | mark_stack_ptr, mark_stack_limit, |
347 | NULL); | |
348 | } | |
349 | ||
350 | return mark_stack_ptr; | |
351 | } | |
352 | ||
353 | static scm_t_weak_entry * | |
354 | allocate_entries (unsigned long size, scm_t_weak_table_kind kind) | |
355 | { | |
356 | scm_t_weak_entry *ret; | |
357 | size_t bytes = size * sizeof (*ret); | |
358 | ||
359 | switch (kind) | |
360 | { | |
361 | case SCM_WEAK_TABLE_KIND_KEY: | |
362 | ret = GC_generic_malloc (bytes, weak_key_gc_kind); | |
363 | break; | |
364 | case SCM_WEAK_TABLE_KIND_VALUE: | |
365 | ret = GC_generic_malloc (bytes, weak_value_gc_kind); | |
366 | break; | |
367 | case SCM_WEAK_TABLE_KIND_BOTH: | |
368 | ret = scm_gc_malloc_pointerless (bytes, "weak-table"); | |
369 | break; | |
370 | default: | |
371 | abort (); | |
372 | } | |
373 | ||
374 | memset (ret, 0, bytes); | |
375 | ||
376 | return ret; | |
377 | } | |
378 | ||
379 | \f | |
380 | ||
381 | /* Growing or shrinking is triggered when the load factor | |
382 | * | |
383 | * L = N / S (N: number of items in table, S: bucket vector length) | |
384 | * | |
385 | * passes an upper limit of 0.9 or a lower limit of 0.2. | |
386 | * | |
387 | * The implementation stores the upper and lower number of items which | |
388 | * trigger a resize in the hashtable object. | |
389 | * | |
390 | * Possible hash table sizes (primes) are stored in the array | |
391 | * hashtable_size. | |
392 | */ | |
393 | ||
394 | static unsigned long hashtable_size[] = { | |
395 | 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363, | |
396 | 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081, | |
397 | 57524111, 115048217, 230096423 | |
398 | }; | |
399 | ||
400 | #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long)) | |
401 | ||
aac980de AW |
402 | static int |
403 | compute_size_index (scm_t_weak_table *table) | |
7005c60f | 404 | { |
aac980de | 405 | int i = table->size_index; |
7005c60f | 406 | |
7005c60f AW |
407 | if (table->n_items < table->lower) |
408 | { | |
409 | /* rehashing is not triggered when i <= min_size */ | |
7005c60f AW |
410 | do |
411 | --i; | |
412 | while (i > table->min_size_index | |
aac980de | 413 | && table->n_items < hashtable_size[i] / 5); |
7005c60f | 414 | } |
aac980de | 415 | else if (table->n_items > table->upper) |
7005c60f | 416 | { |
aac980de | 417 | ++i; |
7005c60f AW |
418 | if (i >= HASHTABLE_SIZE_N) |
419 | /* The biggest size currently is 230096423, which for a 32-bit | |
420 | machine will occupy 2.3GB of memory at a load of 80%. There | |
421 | is probably something better to do here, but if you have a | |
422 | weak map of that size, you are hosed in any case. */ | |
423 | abort (); | |
424 | } | |
425 | ||
aac980de AW |
426 | return i; |
427 | } | |
428 | ||
7932759f AW |
429 | static int |
430 | is_acceptable_size_index (scm_t_weak_table *table, int size_index) | |
431 | { | |
432 | int computed = compute_size_index (table); | |
433 | ||
434 | if (size_index == computed) | |
435 | /* We were going to grow or shrink, and allocating the new vector | |
436 | didn't change the target size. */ | |
437 | return 1; | |
438 | ||
439 | if (size_index == computed + 1) | |
440 | { | |
441 | /* We were going to enlarge the table, but allocating the new | |
442 | vector finalized some objects, making an enlargement | |
443 | unnecessary. It might still be a good idea to use the larger | |
444 | table, though. (This branch also gets hit if, while allocating | |
445 | the vector, some other thread was actively removing items from | |
446 | the table. That is less likely, though.) */ | |
447 | unsigned long new_lower = hashtable_size[size_index] / 5; | |
448 | ||
449 | return table->size > new_lower; | |
450 | } | |
451 | ||
452 | if (size_index == computed - 1) | |
453 | { | |
454 | /* We were going to shrink the table, but when we dropped the lock | |
455 | to allocate the new vector, some other thread added elements to | |
456 | the table. */ | |
457 | return 0; | |
458 | } | |
459 | ||
460 | /* The computed size differs from our newly allocated size by more | |
461 | than one size index -- recalculate. */ | |
462 | return 0; | |
463 | } | |
464 | ||
aac980de AW |
465 | static void |
466 | resize_table (scm_t_weak_table *table) | |
467 | { | |
468 | scm_t_weak_entry *old_entries, *new_entries; | |
469 | int new_size_index; | |
470 | unsigned long old_size, new_size, old_k; | |
471 | ||
472 | do | |
473 | { | |
474 | new_size_index = compute_size_index (table); | |
475 | if (new_size_index == table->size_index) | |
476 | return; | |
477 | new_size = hashtable_size[new_size_index]; | |
aac980de | 478 | new_entries = allocate_entries (new_size, table->kind); |
aac980de | 479 | } |
7932759f | 480 | while (!is_acceptable_size_index (table, new_size_index)); |
7005c60f | 481 | |
aac980de AW |
482 | old_entries = table->entries; |
483 | old_size = table->size; | |
484 | ||
485 | table->size_index = new_size_index; | |
7005c60f | 486 | table->size = new_size; |
aac980de | 487 | if (new_size_index <= table->min_size_index) |
7005c60f AW |
488 | table->lower = 0; |
489 | else | |
490 | table->lower = new_size / 5; | |
491 | table->upper = 9 * new_size / 10; | |
492 | table->n_items = 0; | |
493 | table->entries = new_entries; | |
494 | ||
495 | for (old_k = 0; old_k < old_size; old_k++) | |
496 | { | |
497 | scm_t_weak_entry copy; | |
498 | unsigned long new_k, distance; | |
499 | ||
500 | if (!old_entries[old_k].hash) | |
501 | continue; | |
502 | ||
503 | copy_weak_entry (&old_entries[old_k], ©); | |
504 | ||
505 | if (!copy.key || !copy.value) | |
506 | continue; | |
507 | ||
508 | new_k = hash_to_index (copy.hash, new_size); | |
509 | ||
510 | for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size) | |
511 | { | |
512 | unsigned long other_hash = new_entries[new_k].hash; | |
513 | ||
514 | if (!other_hash) | |
515 | /* Found an empty entry. */ | |
516 | break; | |
517 | ||
518 | /* Displace the entry if our distance is less, otherwise keep | |
519 | looking. */ | |
520 | if (entry_distance (other_hash, new_k, new_size) < distance) | |
521 | { | |
522 | rob_from_rich (table, new_k); | |
523 | break; | |
524 | } | |
525 | } | |
526 | ||
527 | table->n_items++; | |
528 | new_entries[new_k].hash = copy.hash; | |
529 | new_entries[new_k].key = copy.key; | |
530 | new_entries[new_k].value = copy.value; | |
531 | ||
532 | register_disappearing_links (&new_entries[new_k], | |
533 | SCM_PACK (copy.key), SCM_PACK (copy.value), | |
534 | table->kind); | |
535 | } | |
536 | } | |
537 | ||
538 | /* Run after GC via do_vacuum_weak_table, this function runs over the | |
539 | whole table, removing lost weak references, reshuffling the table as it | |
540 | goes. It might resize the table if it reaps enough entries. */ | |
541 | static void | |
542 | vacuum_weak_table (scm_t_weak_table *table) | |
543 | { | |
544 | scm_t_weak_entry *entries = table->entries; | |
545 | unsigned long size = table->size; | |
546 | unsigned long k; | |
547 | ||
548 | for (k = 0; k < size; k++) | |
549 | { | |
550 | unsigned long hash = entries[k].hash; | |
551 | ||
552 | if (hash) | |
553 | { | |
554 | scm_t_weak_entry copy; | |
555 | ||
556 | copy_weak_entry (&entries[k], ©); | |
557 | ||
558 | if (!copy.key || !copy.value) | |
559 | /* Lost weak reference; reshuffle. */ | |
560 | { | |
561 | give_to_poor (table, k); | |
562 | table->n_items--; | |
563 | } | |
564 | } | |
565 | } | |
566 | ||
567 | if (table->n_items < table->lower) | |
568 | resize_table (table); | |
569 | } | |
570 | ||
571 | ||
572 | \f | |
573 | ||
574 | static SCM | |
575 | weak_table_ref (scm_t_weak_table *table, unsigned long hash, | |
576 | scm_t_table_predicate_fn pred, void *closure, | |
577 | SCM dflt) | |
578 | { | |
579 | unsigned long k, distance, size; | |
580 | scm_t_weak_entry *entries; | |
581 | ||
582 | size = table->size; | |
583 | entries = table->entries; | |
584 | ||
585 | hash = (hash << 1) | 0x1; | |
586 | k = hash_to_index (hash, size); | |
587 | ||
588 | for (distance = 0; distance < size; distance++, k = (k + 1) % size) | |
589 | { | |
590 | unsigned long other_hash; | |
591 | ||
592 | retry: | |
593 | other_hash = entries[k].hash; | |
594 | ||
595 | if (!other_hash) | |
596 | /* Not found. */ | |
597 | return dflt; | |
598 | ||
599 | if (hash == other_hash) | |
600 | { | |
601 | scm_t_weak_entry copy; | |
602 | ||
603 | copy_weak_entry (&entries[k], ©); | |
604 | ||
605 | if (!copy.key || !copy.value) | |
606 | /* Lost weak reference; reshuffle. */ | |
607 | { | |
608 | give_to_poor (table, k); | |
609 | table->n_items--; | |
610 | goto retry; | |
611 | } | |
612 | ||
613 | if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) | |
614 | /* Found. */ | |
615 | return SCM_PACK (copy.value); | |
616 | } | |
617 | ||
618 | /* If the entry's distance is less, our key is not in the table. */ | |
619 | if (entry_distance (other_hash, k, size) < distance) | |
620 | return dflt; | |
621 | } | |
622 | ||
623 | /* If we got here, then we were unfortunate enough to loop through the | |
624 | whole table. Shouldn't happen, but hey. */ | |
625 | return dflt; | |
626 | } | |
627 | ||
628 | ||
629 | static void | |
630 | weak_table_put_x (scm_t_weak_table *table, unsigned long hash, | |
631 | scm_t_table_predicate_fn pred, void *closure, | |
632 | SCM key, SCM value) | |
633 | { | |
634 | unsigned long k, distance, size; | |
635 | scm_t_weak_entry *entries; | |
636 | ||
637 | size = table->size; | |
638 | entries = table->entries; | |
639 | ||
640 | hash = (hash << 1) | 0x1; | |
641 | k = hash_to_index (hash, size); | |
642 | ||
643 | for (distance = 0; ; distance++, k = (k + 1) % size) | |
644 | { | |
645 | unsigned long other_hash; | |
646 | ||
647 | retry: | |
648 | other_hash = entries[k].hash; | |
649 | ||
650 | if (!other_hash) | |
651 | /* Found an empty entry. */ | |
652 | break; | |
653 | ||
654 | if (other_hash == hash) | |
655 | { | |
656 | scm_t_weak_entry copy; | |
657 | ||
658 | copy_weak_entry (&entries[k], ©); | |
659 | ||
660 | if (!copy.key || !copy.value) | |
661 | /* Lost weak reference; reshuffle. */ | |
662 | { | |
663 | give_to_poor (table, k); | |
664 | table->n_items--; | |
665 | goto retry; | |
666 | } | |
667 | ||
668 | if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) | |
669 | /* Found an entry with this key. */ | |
670 | break; | |
671 | } | |
672 | ||
673 | if (table->n_items > table->upper) | |
674 | /* Full table, time to resize. */ | |
675 | { | |
676 | resize_table (table); | |
677 | return weak_table_put_x (table, hash >> 1, pred, closure, key, value); | |
678 | } | |
679 | ||
680 | /* Displace the entry if our distance is less, otherwise keep | |
681 | looking. */ | |
682 | if (entry_distance (other_hash, k, size) < distance) | |
683 | { | |
684 | rob_from_rich (table, k); | |
685 | break; | |
686 | } | |
687 | } | |
688 | ||
689 | if (entries[k].hash) | |
690 | unregister_disappearing_links (&entries[k], table->kind); | |
691 | else | |
692 | table->n_items++; | |
693 | ||
694 | entries[k].hash = hash; | |
695 | entries[k].key = SCM_UNPACK (key); | |
696 | entries[k].value = SCM_UNPACK (value); | |
697 | ||
698 | register_disappearing_links (&entries[k], key, value, table->kind); | |
699 | } | |
700 | ||
701 | ||
702 | static void | |
703 | weak_table_remove_x (scm_t_weak_table *table, unsigned long hash, | |
704 | scm_t_table_predicate_fn pred, void *closure) | |
705 | { | |
706 | unsigned long k, distance, size; | |
707 | scm_t_weak_entry *entries; | |
708 | ||
709 | size = table->size; | |
710 | entries = table->entries; | |
711 | ||
712 | hash = (hash << 1) | 0x1; | |
713 | k = hash_to_index (hash, size); | |
714 | ||
715 | for (distance = 0; distance < size; distance++, k = (k + 1) % size) | |
716 | { | |
717 | unsigned long other_hash; | |
718 | ||
719 | retry: | |
720 | other_hash = entries[k].hash; | |
721 | ||
722 | if (!other_hash) | |
723 | /* Not found. */ | |
724 | return; | |
725 | ||
726 | if (other_hash == hash) | |
727 | { | |
728 | scm_t_weak_entry copy; | |
729 | ||
730 | copy_weak_entry (&entries[k], ©); | |
731 | ||
732 | if (!copy.key || !copy.value) | |
733 | /* Lost weak reference; reshuffle. */ | |
734 | { | |
735 | give_to_poor (table, k); | |
736 | table->n_items--; | |
737 | goto retry; | |
738 | } | |
739 | ||
740 | if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) | |
741 | /* Found an entry with this key. */ | |
742 | { | |
743 | entries[k].hash = 0; | |
744 | entries[k].key = 0; | |
745 | entries[k].value = 0; | |
746 | ||
747 | unregister_disappearing_links (&entries[k], table->kind); | |
748 | ||
749 | if (--table->n_items < table->lower) | |
750 | resize_table (table); | |
751 | else | |
752 | give_to_poor (table, k); | |
753 | ||
754 | return; | |
755 | } | |
756 | } | |
757 | ||
758 | /* If the entry's distance is less, our key is not in the table. */ | |
759 | if (entry_distance (other_hash, k, size) < distance) | |
760 | return; | |
761 | } | |
762 | } | |
763 | ||
764 | ||
765 | \f | |
766 | static SCM | |
767 | make_weak_table (unsigned long k, scm_t_weak_table_kind kind) | |
768 | { | |
769 | scm_t_weak_table *table; | |
770 | ||
771 | int i = 0, n = k ? k : 31; | |
772 | while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i]) | |
773 | ++i; | |
774 | n = hashtable_size[i]; | |
775 | ||
776 | table = scm_gc_malloc (sizeof (*table), "weak-table"); | |
777 | table->entries = allocate_entries (n, kind); | |
778 | table->kind = kind; | |
779 | table->n_items = 0; | |
780 | table->size = n; | |
781 | table->lower = 0; | |
782 | table->upper = 9 * n / 10; | |
783 | table->size_index = i; | |
784 | table->min_size_index = i; | |
785 | scm_i_pthread_mutex_init (&table->lock, NULL); | |
786 | ||
81b80b96 | 787 | return scm_cell (scm_tc7_weak_table, (scm_t_bits)table); |
7005c60f AW |
788 | } |
789 | ||
790 | void | |
791 | scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate) | |
792 | { | |
0607ebbf AW |
793 | scm_puts_unlocked ("#<", port); |
794 | scm_puts_unlocked ("weak-table ", port); | |
7005c60f | 795 | scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port); |
0607ebbf | 796 | scm_putc_unlocked ('/', port); |
7005c60f | 797 | scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); |
0607ebbf | 798 | scm_puts_unlocked (">", port); |
7005c60f AW |
799 | } |
800 | ||
801 | static void | |
802 | do_vacuum_weak_table (SCM table) | |
803 | { | |
804 | scm_t_weak_table *t; | |
805 | ||
806 | t = SCM_WEAK_TABLE (table); | |
807 | ||
d7cb7f79 AW |
808 | /* Unlike weak sets, the weak table interface allows custom predicates |
809 | to call out to arbitrary Scheme. There are two ways that this code | |
810 | can be re-entrant, then: calling weak hash procedures while in a | |
811 | custom predicate, or via finalizers run explicitly by (gc) or in an | |
812 | async (for non-threaded Guile). We add a restriction that | |
813 | prohibits the first case, by convention. But since we can't | |
814 | prohibit the second case, here we trylock instead of lock. Not so | |
815 | nice. */ | |
7005c60f AW |
816 | if (scm_i_pthread_mutex_trylock (&t->lock) == 0) |
817 | { | |
818 | vacuum_weak_table (t); | |
81b80b96 | 819 | scm_i_pthread_mutex_unlock (&t->lock); |
7005c60f AW |
820 | } |
821 | ||
822 | return; | |
823 | } | |
824 | ||
7005c60f AW |
825 | SCM |
826 | scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind) | |
827 | { | |
828 | SCM ret; | |
829 | ||
830 | ret = make_weak_table (k, kind); | |
831 | ||
d7cb7f79 | 832 | scm_i_register_weak_gc_callback (ret, do_vacuum_weak_table); |
7005c60f AW |
833 | |
834 | return ret; | |
835 | } | |
836 | ||
837 | SCM | |
838 | scm_weak_table_p (SCM obj) | |
839 | { | |
840 | return scm_from_bool (SCM_WEAK_TABLE_P (obj)); | |
841 | } | |
842 | ||
843 | SCM | |
844 | scm_c_weak_table_ref (SCM table, unsigned long raw_hash, | |
845 | scm_t_table_predicate_fn pred, | |
846 | void *closure, SCM dflt) | |
847 | #define FUNC_NAME "weak-table-ref" | |
848 | { | |
849 | SCM ret; | |
850 | scm_t_weak_table *t; | |
851 | ||
852 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
853 | ||
854 | t = SCM_WEAK_TABLE (table); | |
855 | ||
81b80b96 | 856 | scm_i_pthread_mutex_lock (&t->lock); |
7005c60f AW |
857 | |
858 | ret = weak_table_ref (t, raw_hash, pred, closure, dflt); | |
859 | ||
81b80b96 | 860 | scm_i_pthread_mutex_unlock (&t->lock); |
7005c60f AW |
861 | |
862 | return ret; | |
863 | } | |
864 | #undef FUNC_NAME | |
865 | ||
866 | void | |
867 | scm_c_weak_table_put_x (SCM table, unsigned long raw_hash, | |
868 | scm_t_table_predicate_fn pred, | |
869 | void *closure, SCM key, SCM value) | |
870 | #define FUNC_NAME "weak-table-put!" | |
871 | { | |
872 | scm_t_weak_table *t; | |
873 | ||
874 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
875 | ||
876 | t = SCM_WEAK_TABLE (table); | |
877 | ||
81b80b96 | 878 | scm_i_pthread_mutex_lock (&t->lock); |
7005c60f AW |
879 | |
880 | weak_table_put_x (t, raw_hash, pred, closure, key, value); | |
881 | ||
81b80b96 | 882 | scm_i_pthread_mutex_unlock (&t->lock); |
7005c60f AW |
883 | } |
884 | #undef FUNC_NAME | |
885 | ||
886 | void | |
887 | scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash, | |
888 | scm_t_table_predicate_fn pred, | |
889 | void *closure) | |
890 | #define FUNC_NAME "weak-table-remove!" | |
891 | { | |
892 | scm_t_weak_table *t; | |
893 | ||
894 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
895 | ||
896 | t = SCM_WEAK_TABLE (table); | |
897 | ||
81b80b96 | 898 | scm_i_pthread_mutex_lock (&t->lock); |
7005c60f AW |
899 | |
900 | weak_table_remove_x (t, raw_hash, pred, closure); | |
901 | ||
81b80b96 | 902 | scm_i_pthread_mutex_unlock (&t->lock); |
7005c60f AW |
903 | } |
904 | #undef FUNC_NAME | |
905 | ||
906 | static int | |
907 | assq_predicate (SCM x, SCM y, void *closure) | |
908 | { | |
21041372 | 909 | return scm_is_eq (x, SCM_PACK_POINTER (closure)); |
7005c60f AW |
910 | } |
911 | ||
912 | SCM | |
913 | scm_weak_table_refq (SCM table, SCM key, SCM dflt) | |
914 | { | |
915 | if (SCM_UNBNDP (dflt)) | |
916 | dflt = SCM_BOOL_F; | |
917 | ||
918 | return scm_c_weak_table_ref (table, scm_ihashq (key, -1), | |
21041372 | 919 | assq_predicate, SCM_UNPACK_POINTER (key), |
7005c60f AW |
920 | dflt); |
921 | } | |
922 | ||
07e69928 | 923 | void |
7005c60f AW |
924 | scm_weak_table_putq_x (SCM table, SCM key, SCM value) |
925 | { | |
926 | scm_c_weak_table_put_x (table, scm_ihashq (key, -1), | |
21041372 | 927 | assq_predicate, SCM_UNPACK_POINTER (key), |
7005c60f | 928 | key, value); |
7005c60f AW |
929 | } |
930 | ||
07e69928 | 931 | void |
7005c60f AW |
932 | scm_weak_table_remq_x (SCM table, SCM key) |
933 | { | |
934 | scm_c_weak_table_remove_x (table, scm_ihashq (key, -1), | |
21041372 | 935 | assq_predicate, SCM_UNPACK_POINTER (key)); |
7005c60f AW |
936 | } |
937 | ||
07e69928 | 938 | void |
7005c60f AW |
939 | scm_weak_table_clear_x (SCM table) |
940 | #define FUNC_NAME "weak-table-clear!" | |
941 | { | |
942 | scm_t_weak_table *t; | |
943 | ||
944 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
945 | ||
946 | t = SCM_WEAK_TABLE (table); | |
947 | ||
81b80b96 | 948 | scm_i_pthread_mutex_lock (&t->lock); |
7005c60f AW |
949 | |
950 | memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size); | |
951 | t->n_items = 0; | |
952 | ||
81b80b96 | 953 | scm_i_pthread_mutex_unlock (&t->lock); |
7005c60f AW |
954 | } |
955 | #undef FUNC_NAME | |
956 | ||
957 | SCM | |
958 | scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure, | |
959 | SCM init, SCM table) | |
960 | { | |
961 | scm_t_weak_table *t; | |
962 | scm_t_weak_entry *entries; | |
963 | unsigned long k, size; | |
964 | ||
965 | t = SCM_WEAK_TABLE (table); | |
966 | ||
81b80b96 | 967 | scm_i_pthread_mutex_lock (&t->lock); |
7005c60f AW |
968 | |
969 | size = t->size; | |
970 | entries = t->entries; | |
971 | ||
972 | for (k = 0; k < size; k++) | |
973 | { | |
974 | if (entries[k].hash) | |
975 | { | |
976 | scm_t_weak_entry copy; | |
977 | ||
978 | copy_weak_entry (&entries[k], ©); | |
979 | ||
980 | if (copy.key && copy.value) | |
981 | { | |
982 | /* Release table lock while we call the function. */ | |
81b80b96 | 983 | scm_i_pthread_mutex_unlock (&t->lock); |
7005c60f AW |
984 | init = proc (closure, |
985 | SCM_PACK (copy.key), SCM_PACK (copy.value), | |
986 | init); | |
81b80b96 | 987 | scm_i_pthread_mutex_lock (&t->lock); |
7005c60f AW |
988 | } |
989 | } | |
990 | } | |
991 | ||
81b80b96 | 992 | scm_i_pthread_mutex_unlock (&t->lock); |
7005c60f AW |
993 | |
994 | return init; | |
995 | } | |
996 | ||
997 | static SCM | |
998 | fold_trampoline (void *closure, SCM k, SCM v, SCM init) | |
999 | { | |
21041372 | 1000 | return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init); |
7005c60f AW |
1001 | } |
1002 | ||
1003 | SCM | |
1004 | scm_weak_table_fold (SCM proc, SCM init, SCM table) | |
1005 | #define FUNC_NAME "weak-table-fold" | |
1006 | { | |
1007 | SCM_VALIDATE_WEAK_TABLE (3, table); | |
1008 | SCM_VALIDATE_PROC (1, proc); | |
1009 | ||
21041372 | 1010 | return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table); |
7005c60f AW |
1011 | } |
1012 | #undef FUNC_NAME | |
1013 | ||
1014 | static SCM | |
1015 | for_each_trampoline (void *closure, SCM k, SCM v, SCM seed) | |
1016 | { | |
21041372 | 1017 | scm_call_2 (SCM_PACK_POINTER (closure), k, v); |
7005c60f AW |
1018 | return seed; |
1019 | } | |
1020 | ||
07e69928 | 1021 | void |
7005c60f AW |
1022 | scm_weak_table_for_each (SCM proc, SCM table) |
1023 | #define FUNC_NAME "weak-table-for-each" | |
1024 | { | |
1025 | SCM_VALIDATE_WEAK_TABLE (2, table); | |
1026 | SCM_VALIDATE_PROC (1, proc); | |
1027 | ||
21041372 | 1028 | scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table); |
7005c60f AW |
1029 | } |
1030 | #undef FUNC_NAME | |
1031 | ||
1032 | static SCM | |
1033 | map_trampoline (void *closure, SCM k, SCM v, SCM seed) | |
1034 | { | |
21041372 | 1035 | return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed); |
7005c60f AW |
1036 | } |
1037 | ||
1038 | SCM | |
1039 | scm_weak_table_map_to_list (SCM proc, SCM table) | |
1040 | #define FUNC_NAME "weak-table-map->list" | |
1041 | { | |
1042 | SCM_VALIDATE_WEAK_TABLE (2, table); | |
1043 | SCM_VALIDATE_PROC (1, proc); | |
1044 | ||
21041372 | 1045 | return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table); |
7005c60f AW |
1046 | } |
1047 | #undef FUNC_NAME | |
1048 | ||
1049 | ||
54a9b981 AW |
1050 | \f |
1051 | ||
1052 | /* Legacy interface. */ | |
1053 | ||
1054 | SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, | |
1055 | (SCM n), | |
1056 | "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n" | |
1057 | "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n" | |
1058 | "Return a weak hash table with @var{size} buckets.\n" | |
1059 | "\n" | |
1060 | "You can modify weak hash tables in exactly the same way you\n" | |
1061 | "would modify regular hash tables. (@pxref{Hash Tables})") | |
1062 | #define FUNC_NAME s_scm_make_weak_key_hash_table | |
1063 | { | |
1064 | return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), | |
1065 | SCM_WEAK_TABLE_KIND_KEY); | |
1066 | } | |
1067 | #undef FUNC_NAME | |
1068 | ||
1069 | ||
1070 | SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0, | |
1071 | (SCM n), | |
1072 | "Return a hash table with weak values with @var{size} buckets.\n" | |
1073 | "(@pxref{Hash Tables})") | |
1074 | #define FUNC_NAME s_scm_make_weak_value_hash_table | |
1075 | { | |
1076 | return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), | |
1077 | SCM_WEAK_TABLE_KIND_VALUE); | |
1078 | } | |
1079 | #undef FUNC_NAME | |
1080 | ||
1081 | ||
04023cce | 1082 | SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 0, 1, 0, |
54a9b981 AW |
1083 | (SCM n), |
1084 | "Return a hash table with weak keys and values with @var{size}\n" | |
1085 | "buckets. (@pxref{Hash Tables})") | |
1086 | #define FUNC_NAME s_scm_make_doubly_weak_hash_table | |
1087 | { | |
1088 | return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), | |
1089 | SCM_WEAK_TABLE_KIND_BOTH); | |
1090 | } | |
1091 | #undef FUNC_NAME | |
1092 | ||
1093 | ||
1094 | SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, | |
1095 | (SCM obj), | |
1096 | "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n" | |
1097 | "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n" | |
1098 | "Return @code{#t} if @var{obj} is the specified weak hash\n" | |
1099 | "table. Note that a doubly weak hash table is neither a weak key\n" | |
1100 | "nor a weak value hash table.") | |
1101 | #define FUNC_NAME s_scm_weak_key_hash_table_p | |
1102 | { | |
1103 | return scm_from_bool (SCM_WEAK_TABLE_P (obj) && | |
1104 | SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY); | |
1105 | } | |
1106 | #undef FUNC_NAME | |
1107 | ||
1108 | ||
1109 | SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, | |
1110 | (SCM obj), | |
1111 | "Return @code{#t} if @var{obj} is a weak value hash table.") | |
1112 | #define FUNC_NAME s_scm_weak_value_hash_table_p | |
1113 | { | |
1114 | return scm_from_bool (SCM_WEAK_TABLE_P (obj) && | |
1115 | SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE); | |
1116 | } | |
1117 | #undef FUNC_NAME | |
1118 | ||
1119 | ||
1120 | SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, | |
1121 | (SCM obj), | |
1122 | "Return @code{#t} if @var{obj} is a doubly weak hash table.") | |
1123 | #define FUNC_NAME s_scm_doubly_weak_hash_table_p | |
1124 | { | |
1125 | return scm_from_bool (SCM_WEAK_TABLE_P (obj) && | |
1126 | SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH); | |
1127 | } | |
1128 | #undef FUNC_NAME | |
1129 | ||
1130 | ||
1131 | ||
1132 | \f | |
1133 | ||
7005c60f AW |
1134 | void |
1135 | scm_weak_table_prehistory (void) | |
1136 | { | |
1137 | weak_key_gc_kind = | |
1138 | GC_new_kind (GC_new_free_list (), | |
1139 | GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0), | |
1140 | 0, 0); | |
1141 | weak_value_gc_kind = | |
1142 | GC_new_kind (GC_new_free_list (), | |
1143 | GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0), | |
1144 | 0, 0); | |
1145 | } | |
1146 | ||
1147 | void | |
1148 | scm_init_weak_table () | |
1149 | { | |
1150 | #include "libguile/weak-table.x" | |
1151 | } | |
1152 | ||
1153 | /* | |
1154 | Local Variables: | |
1155 | c-file-style: "gnu" | |
1156 | End: | |
1157 | */ |