Commit | Line | Data |
---|---|---|
7005c60f AW |
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_NIMP (k) | |
131 | && (kind == SCM_WEAK_TABLE_KIND_KEY | |
132 | || kind == SCM_WEAK_TABLE_KIND_BOTH)) | |
133 | SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key, | |
134 | (GC_PTR) SCM2PTR (k)); | |
135 | ||
136 | if (SCM_UNPACK (v) && SCM_NIMP (v) | |
137 | && (kind == SCM_WEAK_TABLE_KIND_VALUE | |
138 | || kind == SCM_WEAK_TABLE_KIND_BOTH)) | |
139 | SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value, | |
140 | (GC_PTR) SCM2PTR (v)); | |
141 | } | |
142 | ||
143 | static void | |
144 | unregister_disappearing_links (scm_t_weak_entry *entry, | |
145 | scm_t_weak_table_kind kind) | |
146 | { | |
147 | if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH) | |
148 | GC_unregister_disappearing_link ((GC_PTR) &entry->key); | |
149 | ||
150 | if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH) | |
151 | GC_unregister_disappearing_link ((GC_PTR) &entry->value); | |
152 | } | |
153 | ||
154 | static void | |
155 | move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to, | |
156 | scm_t_weak_table_kind kind) | |
157 | { | |
158 | if (from->hash) | |
159 | { | |
160 | scm_t_weak_entry copy; | |
161 | ||
162 | copy_weak_entry (from, ©); | |
163 | to->hash = copy.hash; | |
164 | to->key = copy.key; | |
165 | to->value = copy.value; | |
166 | ||
167 | unregister_disappearing_links (from, kind); | |
168 | register_disappearing_links (to, | |
169 | SCM_PACK (copy.key), SCM_PACK (copy.value), | |
170 | kind); | |
171 | } | |
172 | else | |
173 | { | |
174 | to->hash = 0; | |
175 | to->key = 0; | |
176 | to->value = 0; | |
177 | } | |
178 | } | |
179 | ||
180 | ||
181 | typedef struct { | |
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 */ | |
191 | } scm_t_weak_table; | |
192 | ||
193 | ||
dc7da0be | 194 | #define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table)) |
7005c60f AW |
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)) | |
198 | ||
199 | ||
200 | static unsigned long | |
201 | hash_to_index (unsigned long hash, unsigned long size) | |
202 | { | |
203 | return (hash >> 1) % size; | |
204 | } | |
205 | ||
206 | static unsigned long | |
207 | entry_distance (unsigned long hash, unsigned long k, unsigned long size) | |
208 | { | |
209 | unsigned long origin = hash_to_index (hash, size); | |
210 | ||
211 | if (k >= origin) | |
212 | return k - origin; | |
213 | else | |
214 | /* The other key was displaced and wrapped around. */ | |
215 | return size - origin + k; | |
216 | } | |
217 | ||
218 | static void | |
219 | rob_from_rich (scm_t_weak_table *table, unsigned long k) | |
220 | { | |
221 | unsigned long empty, size; | |
222 | ||
223 | size = table->size; | |
224 | ||
225 | /* If we are to free up slot K in the table, we need room to do so. */ | |
226 | assert (table->n_items < size); | |
227 | ||
228 | empty = k; | |
229 | do | |
230 | empty = (empty + 1) % size; | |
231 | while (table->entries[empty].hash); | |
232 | ||
233 | do | |
234 | { | |
235 | unsigned long last = empty ? (empty - 1) : (size - 1); | |
236 | move_weak_entry (&table->entries[last], &table->entries[empty], | |
237 | table->kind); | |
238 | empty = last; | |
239 | } | |
240 | while (empty != k); | |
241 | ||
242 | table->entries[empty].hash = 0; | |
243 | table->entries[empty].key = 0; | |
244 | table->entries[empty].value = 0; | |
245 | } | |
246 | ||
247 | static void | |
248 | give_to_poor (scm_t_weak_table *table, unsigned long k) | |
249 | { | |
250 | /* Slot K was just freed up; possibly shuffle others down. */ | |
251 | unsigned long size = table->size; | |
252 | ||
253 | while (1) | |
254 | { | |
255 | unsigned long next = (k + 1) % size; | |
256 | unsigned long hash; | |
257 | scm_t_weak_entry copy; | |
258 | ||
259 | hash = table->entries[next].hash; | |
260 | ||
261 | if (!hash || hash_to_index (hash, size) == next) | |
262 | break; | |
263 | ||
264 | copy_weak_entry (&table->entries[next], ©); | |
265 | ||
266 | if (!copy.key || !copy.value) | |
267 | /* Lost weak reference. */ | |
268 | { | |
269 | give_to_poor (table, next); | |
270 | table->n_items--; | |
271 | continue; | |
272 | } | |
273 | ||
274 | move_weak_entry (&table->entries[next], &table->entries[k], | |
275 | table->kind); | |
276 | ||
277 | k = next; | |
278 | } | |
279 | ||
280 | /* We have shuffled down any entries that should be shuffled down; now | |
281 | free the end. */ | |
282 | table->entries[k].hash = 0; | |
283 | table->entries[k].key = 0; | |
284 | table->entries[k].value = 0; | |
285 | } | |
286 | ||
287 | ||
288 | \f | |
289 | ||
290 | /* The GC "kinds" for singly-weak tables. */ | |
291 | static int weak_key_gc_kind; | |
292 | static int weak_value_gc_kind; | |
293 | ||
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) | |
297 | { | |
298 | scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; | |
299 | unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); | |
300 | ||
301 | for (k = 0; k < size; k++) | |
302 | if (entries[k].hash && entries[k].key) | |
303 | { | |
304 | SCM value = SCM_PACK (entries[k].value); | |
305 | mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (value), | |
306 | mark_stack_ptr, mark_stack_limit, | |
307 | NULL); | |
308 | } | |
309 | ||
310 | return mark_stack_ptr; | |
311 | } | |
312 | ||
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) | |
316 | { | |
317 | scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; | |
318 | unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); | |
319 | ||
320 | for (k = 0; k < size; k++) | |
321 | if (entries[k].hash && entries[k].value) | |
322 | { | |
323 | SCM key = SCM_PACK (entries[k].key); | |
324 | mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key), | |
325 | mark_stack_ptr, mark_stack_limit, | |
326 | NULL); | |
327 | } | |
328 | ||
329 | return mark_stack_ptr; | |
330 | } | |
331 | ||
332 | static scm_t_weak_entry * | |
333 | allocate_entries (unsigned long size, scm_t_weak_table_kind kind) | |
334 | { | |
335 | scm_t_weak_entry *ret; | |
336 | size_t bytes = size * sizeof (*ret); | |
337 | ||
338 | switch (kind) | |
339 | { | |
340 | case SCM_WEAK_TABLE_KIND_KEY: | |
341 | ret = GC_generic_malloc (bytes, weak_key_gc_kind); | |
342 | break; | |
343 | case SCM_WEAK_TABLE_KIND_VALUE: | |
344 | ret = GC_generic_malloc (bytes, weak_value_gc_kind); | |
345 | break; | |
346 | case SCM_WEAK_TABLE_KIND_BOTH: | |
347 | ret = scm_gc_malloc_pointerless (bytes, "weak-table"); | |
348 | break; | |
349 | default: | |
350 | abort (); | |
351 | } | |
352 | ||
353 | memset (ret, 0, bytes); | |
354 | ||
355 | return ret; | |
356 | } | |
357 | ||
358 | \f | |
359 | ||
360 | /* Growing or shrinking is triggered when the load factor | |
361 | * | |
362 | * L = N / S (N: number of items in table, S: bucket vector length) | |
363 | * | |
364 | * passes an upper limit of 0.9 or a lower limit of 0.2. | |
365 | * | |
366 | * The implementation stores the upper and lower number of items which | |
367 | * trigger a resize in the hashtable object. | |
368 | * | |
369 | * Possible hash table sizes (primes) are stored in the array | |
370 | * hashtable_size. | |
371 | */ | |
372 | ||
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 | |
377 | }; | |
378 | ||
379 | #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long)) | |
380 | ||
381 | static void | |
382 | resize_table (scm_t_weak_table *table) | |
383 | { | |
384 | scm_t_weak_entry *old_entries, *new_entries; | |
385 | int i; | |
386 | unsigned long old_size, new_size, old_k; | |
387 | ||
388 | old_entries = table->entries; | |
389 | old_size = table->size; | |
390 | ||
391 | if (table->n_items < table->lower) | |
392 | { | |
393 | /* rehashing is not triggered when i <= min_size */ | |
394 | i = table->size_index; | |
395 | do | |
396 | --i; | |
397 | while (i > table->min_size_index | |
398 | && table->n_items < hashtable_size[i] / 4); | |
399 | } | |
400 | else | |
401 | { | |
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. */ | |
408 | abort (); | |
409 | } | |
410 | ||
411 | new_size = hashtable_size[i]; | |
412 | new_entries = allocate_entries (new_size, table->kind); | |
413 | ||
414 | table->size_index = i; | |
415 | table->size = new_size; | |
416 | if (i <= table->min_size_index) | |
417 | table->lower = 0; | |
418 | else | |
419 | table->lower = new_size / 5; | |
420 | table->upper = 9 * new_size / 10; | |
421 | table->n_items = 0; | |
422 | table->entries = new_entries; | |
423 | ||
424 | for (old_k = 0; old_k < old_size; old_k++) | |
425 | { | |
426 | scm_t_weak_entry copy; | |
427 | unsigned long new_k, distance; | |
428 | ||
429 | if (!old_entries[old_k].hash) | |
430 | continue; | |
431 | ||
432 | copy_weak_entry (&old_entries[old_k], ©); | |
433 | ||
434 | if (!copy.key || !copy.value) | |
435 | continue; | |
436 | ||
437 | new_k = hash_to_index (copy.hash, new_size); | |
438 | ||
439 | for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size) | |
440 | { | |
441 | unsigned long other_hash = new_entries[new_k].hash; | |
442 | ||
443 | if (!other_hash) | |
444 | /* Found an empty entry. */ | |
445 | break; | |
446 | ||
447 | /* Displace the entry if our distance is less, otherwise keep | |
448 | looking. */ | |
449 | if (entry_distance (other_hash, new_k, new_size) < distance) | |
450 | { | |
451 | rob_from_rich (table, new_k); | |
452 | break; | |
453 | } | |
454 | } | |
455 | ||
456 | table->n_items++; | |
457 | new_entries[new_k].hash = copy.hash; | |
458 | new_entries[new_k].key = copy.key; | |
459 | new_entries[new_k].value = copy.value; | |
460 | ||
461 | register_disappearing_links (&new_entries[new_k], | |
462 | SCM_PACK (copy.key), SCM_PACK (copy.value), | |
463 | table->kind); | |
464 | } | |
465 | } | |
466 | ||
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. */ | |
470 | static void | |
471 | vacuum_weak_table (scm_t_weak_table *table) | |
472 | { | |
473 | scm_t_weak_entry *entries = table->entries; | |
474 | unsigned long size = table->size; | |
475 | unsigned long k; | |
476 | ||
477 | for (k = 0; k < size; k++) | |
478 | { | |
479 | unsigned long hash = entries[k].hash; | |
480 | ||
481 | if (hash) | |
482 | { | |
483 | scm_t_weak_entry copy; | |
484 | ||
485 | copy_weak_entry (&entries[k], ©); | |
486 | ||
487 | if (!copy.key || !copy.value) | |
488 | /* Lost weak reference; reshuffle. */ | |
489 | { | |
490 | give_to_poor (table, k); | |
491 | table->n_items--; | |
492 | } | |
493 | } | |
494 | } | |
495 | ||
496 | if (table->n_items < table->lower) | |
497 | resize_table (table); | |
498 | } | |
499 | ||
500 | ||
501 | \f | |
502 | ||
503 | static SCM | |
504 | weak_table_ref (scm_t_weak_table *table, unsigned long hash, | |
505 | scm_t_table_predicate_fn pred, void *closure, | |
506 | SCM dflt) | |
507 | { | |
508 | unsigned long k, distance, size; | |
509 | scm_t_weak_entry *entries; | |
510 | ||
511 | size = table->size; | |
512 | entries = table->entries; | |
513 | ||
514 | hash = (hash << 1) | 0x1; | |
515 | k = hash_to_index (hash, size); | |
516 | ||
517 | for (distance = 0; distance < size; distance++, k = (k + 1) % size) | |
518 | { | |
519 | unsigned long other_hash; | |
520 | ||
521 | retry: | |
522 | other_hash = entries[k].hash; | |
523 | ||
524 | if (!other_hash) | |
525 | /* Not found. */ | |
526 | return dflt; | |
527 | ||
528 | if (hash == other_hash) | |
529 | { | |
530 | scm_t_weak_entry copy; | |
531 | ||
532 | copy_weak_entry (&entries[k], ©); | |
533 | ||
534 | if (!copy.key || !copy.value) | |
535 | /* Lost weak reference; reshuffle. */ | |
536 | { | |
537 | give_to_poor (table, k); | |
538 | table->n_items--; | |
539 | goto retry; | |
540 | } | |
541 | ||
542 | if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) | |
543 | /* Found. */ | |
544 | return SCM_PACK (copy.value); | |
545 | } | |
546 | ||
547 | /* If the entry's distance is less, our key is not in the table. */ | |
548 | if (entry_distance (other_hash, k, size) < distance) | |
549 | return dflt; | |
550 | } | |
551 | ||
552 | /* If we got here, then we were unfortunate enough to loop through the | |
553 | whole table. Shouldn't happen, but hey. */ | |
554 | return dflt; | |
555 | } | |
556 | ||
557 | ||
558 | static void | |
559 | weak_table_put_x (scm_t_weak_table *table, unsigned long hash, | |
560 | scm_t_table_predicate_fn pred, void *closure, | |
561 | SCM key, SCM value) | |
562 | { | |
563 | unsigned long k, distance, size; | |
564 | scm_t_weak_entry *entries; | |
565 | ||
566 | size = table->size; | |
567 | entries = table->entries; | |
568 | ||
569 | hash = (hash << 1) | 0x1; | |
570 | k = hash_to_index (hash, size); | |
571 | ||
572 | for (distance = 0; ; distance++, k = (k + 1) % size) | |
573 | { | |
574 | unsigned long other_hash; | |
575 | ||
576 | retry: | |
577 | other_hash = entries[k].hash; | |
578 | ||
579 | if (!other_hash) | |
580 | /* Found an empty entry. */ | |
581 | break; | |
582 | ||
583 | if (other_hash == hash) | |
584 | { | |
585 | scm_t_weak_entry copy; | |
586 | ||
587 | copy_weak_entry (&entries[k], ©); | |
588 | ||
589 | if (!copy.key || !copy.value) | |
590 | /* Lost weak reference; reshuffle. */ | |
591 | { | |
592 | give_to_poor (table, k); | |
593 | table->n_items--; | |
594 | goto retry; | |
595 | } | |
596 | ||
597 | if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) | |
598 | /* Found an entry with this key. */ | |
599 | break; | |
600 | } | |
601 | ||
602 | if (table->n_items > table->upper) | |
603 | /* Full table, time to resize. */ | |
604 | { | |
605 | resize_table (table); | |
606 | return weak_table_put_x (table, hash >> 1, pred, closure, key, value); | |
607 | } | |
608 | ||
609 | /* Displace the entry if our distance is less, otherwise keep | |
610 | looking. */ | |
611 | if (entry_distance (other_hash, k, size) < distance) | |
612 | { | |
613 | rob_from_rich (table, k); | |
614 | break; | |
615 | } | |
616 | } | |
617 | ||
618 | if (entries[k].hash) | |
619 | unregister_disappearing_links (&entries[k], table->kind); | |
620 | else | |
621 | table->n_items++; | |
622 | ||
623 | entries[k].hash = hash; | |
624 | entries[k].key = SCM_UNPACK (key); | |
625 | entries[k].value = SCM_UNPACK (value); | |
626 | ||
627 | register_disappearing_links (&entries[k], key, value, table->kind); | |
628 | } | |
629 | ||
630 | ||
631 | static void | |
632 | weak_table_remove_x (scm_t_weak_table *table, unsigned long hash, | |
633 | scm_t_table_predicate_fn pred, void *closure) | |
634 | { | |
635 | unsigned long k, distance, size; | |
636 | scm_t_weak_entry *entries; | |
637 | ||
638 | size = table->size; | |
639 | entries = table->entries; | |
640 | ||
641 | hash = (hash << 1) | 0x1; | |
642 | k = hash_to_index (hash, size); | |
643 | ||
644 | for (distance = 0; distance < size; distance++, k = (k + 1) % size) | |
645 | { | |
646 | unsigned long other_hash; | |
647 | ||
648 | retry: | |
649 | other_hash = entries[k].hash; | |
650 | ||
651 | if (!other_hash) | |
652 | /* Not found. */ | |
653 | return; | |
654 | ||
655 | if (other_hash == hash) | |
656 | { | |
657 | scm_t_weak_entry copy; | |
658 | ||
659 | copy_weak_entry (&entries[k], ©); | |
660 | ||
661 | if (!copy.key || !copy.value) | |
662 | /* Lost weak reference; reshuffle. */ | |
663 | { | |
664 | give_to_poor (table, k); | |
665 | table->n_items--; | |
666 | goto retry; | |
667 | } | |
668 | ||
669 | if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) | |
670 | /* Found an entry with this key. */ | |
671 | { | |
672 | entries[k].hash = 0; | |
673 | entries[k].key = 0; | |
674 | entries[k].value = 0; | |
675 | ||
676 | unregister_disappearing_links (&entries[k], table->kind); | |
677 | ||
678 | if (--table->n_items < table->lower) | |
679 | resize_table (table); | |
680 | else | |
681 | give_to_poor (table, k); | |
682 | ||
683 | return; | |
684 | } | |
685 | } | |
686 | ||
687 | /* If the entry's distance is less, our key is not in the table. */ | |
688 | if (entry_distance (other_hash, k, size) < distance) | |
689 | return; | |
690 | } | |
691 | } | |
692 | ||
693 | ||
694 | \f | |
695 | static SCM | |
696 | make_weak_table (unsigned long k, scm_t_weak_table_kind kind) | |
697 | { | |
698 | scm_t_weak_table *table; | |
699 | ||
700 | int i = 0, n = k ? k : 31; | |
701 | while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i]) | |
702 | ++i; | |
703 | n = hashtable_size[i]; | |
704 | ||
705 | table = scm_gc_malloc (sizeof (*table), "weak-table"); | |
706 | table->entries = allocate_entries (n, kind); | |
707 | table->kind = kind; | |
708 | table->n_items = 0; | |
709 | table->size = n; | |
710 | table->lower = 0; | |
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); | |
715 | ||
716 | return scm_cell (scm_tc7_weak_table, (scm_t_bits)table); | |
717 | } | |
718 | ||
719 | void | |
720 | scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate) | |
721 | { | |
722 | scm_puts ("#<", port); | |
723 | scm_puts ("weak-table ", port); | |
724 | scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port); | |
725 | scm_putc ('/', port); | |
726 | scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); | |
727 | scm_puts (">", port); | |
728 | } | |
729 | ||
730 | static void | |
731 | do_vacuum_weak_table (SCM table) | |
732 | { | |
733 | scm_t_weak_table *t; | |
734 | ||
735 | t = SCM_WEAK_TABLE (table); | |
736 | ||
737 | if (scm_i_pthread_mutex_trylock (&t->lock) == 0) | |
738 | { | |
739 | vacuum_weak_table (t); | |
740 | scm_i_pthread_mutex_unlock (&t->lock); | |
741 | } | |
742 | ||
743 | return; | |
744 | } | |
745 | ||
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. */ | |
748 | static int | |
749 | weak_gc_callback (void **weak) | |
750 | { | |
751 | void *val = weak[0]; | |
752 | void (*callback) (SCM) = weak[1]; | |
753 | ||
754 | if (!val) | |
755 | return 0; | |
756 | ||
21041372 | 757 | callback (SCM_PACK_POINTER (val)); |
7005c60f AW |
758 | |
759 | return 1; | |
760 | } | |
761 | ||
762 | #ifdef HAVE_GC_TABLE_START_CALLBACK | |
763 | static void* | |
764 | weak_gc_hook (void *hook_data, void *fn_data, void *data) | |
765 | { | |
766 | if (!weak_gc_callback (fn_data)) | |
767 | scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data); | |
768 | ||
769 | return NULL; | |
770 | } | |
771 | #else | |
772 | static void | |
773 | weak_gc_finalizer (void *ptr, void *data) | |
774 | { | |
775 | if (weak_gc_callback (ptr)) | |
776 | GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL); | |
777 | } | |
778 | #endif | |
779 | ||
780 | static void | |
781 | scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM)) | |
782 | { | |
783 | void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2); | |
784 | ||
21041372 | 785 | weak[0] = SCM_UNPACK_POINTER (obj); |
7005c60f AW |
786 | weak[1] = (void*)callback; |
787 | GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj)); | |
788 | ||
789 | #ifdef HAVE_GC_TABLE_START_CALLBACK | |
790 | scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0); | |
791 | #else | |
792 | GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL); | |
793 | #endif | |
794 | } | |
795 | ||
796 | SCM | |
797 | scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind) | |
798 | { | |
799 | SCM ret; | |
800 | ||
801 | ret = make_weak_table (k, kind); | |
802 | ||
803 | scm_c_register_weak_gc_callback (ret, do_vacuum_weak_table); | |
804 | ||
805 | return ret; | |
806 | } | |
807 | ||
808 | SCM | |
809 | scm_weak_table_p (SCM obj) | |
810 | { | |
811 | return scm_from_bool (SCM_WEAK_TABLE_P (obj)); | |
812 | } | |
813 | ||
814 | SCM | |
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" | |
819 | { | |
820 | SCM ret; | |
821 | scm_t_weak_table *t; | |
822 | ||
823 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
824 | ||
825 | t = SCM_WEAK_TABLE (table); | |
826 | ||
827 | scm_i_pthread_mutex_lock (&t->lock); | |
828 | ||
829 | ret = weak_table_ref (t, raw_hash, pred, closure, dflt); | |
830 | ||
831 | scm_i_pthread_mutex_unlock (&t->lock); | |
832 | ||
833 | return ret; | |
834 | } | |
835 | #undef FUNC_NAME | |
836 | ||
837 | void | |
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!" | |
842 | { | |
843 | scm_t_weak_table *t; | |
844 | ||
845 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
846 | ||
847 | t = SCM_WEAK_TABLE (table); | |
848 | ||
849 | scm_i_pthread_mutex_lock (&t->lock); | |
850 | ||
851 | weak_table_put_x (t, raw_hash, pred, closure, key, value); | |
852 | ||
853 | scm_i_pthread_mutex_unlock (&t->lock); | |
854 | } | |
855 | #undef FUNC_NAME | |
856 | ||
857 | void | |
858 | scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash, | |
859 | scm_t_table_predicate_fn pred, | |
860 | void *closure) | |
861 | #define FUNC_NAME "weak-table-remove!" | |
862 | { | |
863 | scm_t_weak_table *t; | |
864 | ||
865 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
866 | ||
867 | t = SCM_WEAK_TABLE (table); | |
868 | ||
869 | scm_i_pthread_mutex_lock (&t->lock); | |
870 | ||
871 | weak_table_remove_x (t, raw_hash, pred, closure); | |
872 | ||
873 | scm_i_pthread_mutex_unlock (&t->lock); | |
874 | } | |
875 | #undef FUNC_NAME | |
876 | ||
877 | static int | |
878 | assq_predicate (SCM x, SCM y, void *closure) | |
879 | { | |
21041372 | 880 | return scm_is_eq (x, SCM_PACK_POINTER (closure)); |
7005c60f AW |
881 | } |
882 | ||
883 | SCM | |
884 | scm_weak_table_refq (SCM table, SCM key, SCM dflt) | |
885 | { | |
886 | if (SCM_UNBNDP (dflt)) | |
887 | dflt = SCM_BOOL_F; | |
888 | ||
889 | return scm_c_weak_table_ref (table, scm_ihashq (key, -1), | |
21041372 | 890 | assq_predicate, SCM_UNPACK_POINTER (key), |
7005c60f AW |
891 | dflt); |
892 | } | |
893 | ||
894 | SCM | |
895 | scm_weak_table_putq_x (SCM table, SCM key, SCM value) | |
896 | { | |
897 | scm_c_weak_table_put_x (table, scm_ihashq (key, -1), | |
21041372 | 898 | assq_predicate, SCM_UNPACK_POINTER (key), |
7005c60f AW |
899 | key, value); |
900 | return SCM_UNSPECIFIED; | |
901 | } | |
902 | ||
903 | SCM | |
904 | scm_weak_table_remq_x (SCM table, SCM key) | |
905 | { | |
906 | scm_c_weak_table_remove_x (table, scm_ihashq (key, -1), | |
21041372 | 907 | assq_predicate, SCM_UNPACK_POINTER (key)); |
7005c60f AW |
908 | return SCM_UNSPECIFIED; |
909 | } | |
910 | ||
911 | SCM | |
912 | scm_weak_table_clear_x (SCM table) | |
913 | #define FUNC_NAME "weak-table-clear!" | |
914 | { | |
915 | scm_t_weak_table *t; | |
916 | ||
917 | SCM_VALIDATE_WEAK_TABLE (1, table); | |
918 | ||
919 | t = SCM_WEAK_TABLE (table); | |
920 | ||
921 | scm_i_pthread_mutex_lock (&t->lock); | |
922 | ||
923 | memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size); | |
924 | t->n_items = 0; | |
925 | ||
926 | scm_i_pthread_mutex_unlock (&t->lock); | |
927 | ||
928 | return SCM_UNSPECIFIED; | |
929 | } | |
930 | #undef FUNC_NAME | |
931 | ||
932 | SCM | |
933 | scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure, | |
934 | SCM init, SCM table) | |
935 | { | |
936 | scm_t_weak_table *t; | |
937 | scm_t_weak_entry *entries; | |
938 | unsigned long k, size; | |
939 | ||
940 | t = SCM_WEAK_TABLE (table); | |
941 | ||
942 | scm_i_pthread_mutex_lock (&t->lock); | |
943 | ||
944 | size = t->size; | |
945 | entries = t->entries; | |
946 | ||
947 | for (k = 0; k < size; k++) | |
948 | { | |
949 | if (entries[k].hash) | |
950 | { | |
951 | scm_t_weak_entry copy; | |
952 | ||
953 | copy_weak_entry (&entries[k], ©); | |
954 | ||
955 | if (copy.key && copy.value) | |
956 | { | |
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), | |
961 | init); | |
962 | scm_i_pthread_mutex_lock (&t->lock); | |
963 | } | |
964 | } | |
965 | } | |
966 | ||
967 | scm_i_pthread_mutex_unlock (&t->lock); | |
968 | ||
969 | return init; | |
970 | } | |
971 | ||
972 | static SCM | |
973 | fold_trampoline (void *closure, SCM k, SCM v, SCM init) | |
974 | { | |
21041372 | 975 | return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init); |
7005c60f AW |
976 | } |
977 | ||
978 | SCM | |
979 | scm_weak_table_fold (SCM proc, SCM init, SCM table) | |
980 | #define FUNC_NAME "weak-table-fold" | |
981 | { | |
982 | SCM_VALIDATE_WEAK_TABLE (3, table); | |
983 | SCM_VALIDATE_PROC (1, proc); | |
984 | ||
21041372 | 985 | return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table); |
7005c60f AW |
986 | } |
987 | #undef FUNC_NAME | |
988 | ||
989 | static SCM | |
990 | for_each_trampoline (void *closure, SCM k, SCM v, SCM seed) | |
991 | { | |
21041372 | 992 | scm_call_2 (SCM_PACK_POINTER (closure), k, v); |
7005c60f AW |
993 | return seed; |
994 | } | |
995 | ||
996 | SCM | |
997 | scm_weak_table_for_each (SCM proc, SCM table) | |
998 | #define FUNC_NAME "weak-table-for-each" | |
999 | { | |
1000 | SCM_VALIDATE_WEAK_TABLE (2, table); | |
1001 | SCM_VALIDATE_PROC (1, proc); | |
1002 | ||
21041372 | 1003 | scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table); |
7005c60f AW |
1004 | |
1005 | return SCM_UNSPECIFIED; | |
1006 | } | |
1007 | #undef FUNC_NAME | |
1008 | ||
1009 | static SCM | |
1010 | map_trampoline (void *closure, SCM k, SCM v, SCM seed) | |
1011 | { | |
21041372 | 1012 | return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed); |
7005c60f AW |
1013 | } |
1014 | ||
1015 | SCM | |
1016 | scm_weak_table_map_to_list (SCM proc, SCM table) | |
1017 | #define FUNC_NAME "weak-table-map->list" | |
1018 | { | |
1019 | SCM_VALIDATE_WEAK_TABLE (2, table); | |
1020 | SCM_VALIDATE_PROC (1, proc); | |
1021 | ||
21041372 | 1022 | return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table); |
7005c60f AW |
1023 | } |
1024 | #undef FUNC_NAME | |
1025 | ||
1026 | ||
54a9b981 AW |
1027 | \f |
1028 | ||
1029 | /* Legacy interface. */ | |
1030 | ||
1031 | SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, | |
1032 | (SCM n), | |
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" | |
1036 | "\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 | |
1040 | { | |
1041 | return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), | |
1042 | SCM_WEAK_TABLE_KIND_KEY); | |
1043 | } | |
1044 | #undef FUNC_NAME | |
1045 | ||
1046 | ||
1047 | SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0, | |
1048 | (SCM n), | |
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 | |
1052 | { | |
1053 | return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), | |
1054 | SCM_WEAK_TABLE_KIND_VALUE); | |
1055 | } | |
1056 | #undef FUNC_NAME | |
1057 | ||
1058 | ||
1059 | SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, | |
1060 | (SCM n), | |
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 | |
1064 | { | |
1065 | return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), | |
1066 | SCM_WEAK_TABLE_KIND_BOTH); | |
1067 | } | |
1068 | #undef FUNC_NAME | |
1069 | ||
1070 | ||
1071 | SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, | |
1072 | (SCM obj), | |
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 | |
1079 | { | |
1080 | return scm_from_bool (SCM_WEAK_TABLE_P (obj) && | |
1081 | SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY); | |
1082 | } | |
1083 | #undef FUNC_NAME | |
1084 | ||
1085 | ||
1086 | SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, | |
1087 | (SCM obj), | |
1088 | "Return @code{#t} if @var{obj} is a weak value hash table.") | |
1089 | #define FUNC_NAME s_scm_weak_value_hash_table_p | |
1090 | { | |
1091 | return scm_from_bool (SCM_WEAK_TABLE_P (obj) && | |
1092 | SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE); | |
1093 | } | |
1094 | #undef FUNC_NAME | |
1095 | ||
1096 | ||
1097 | SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, | |
1098 | (SCM obj), | |
1099 | "Return @code{#t} if @var{obj} is a doubly weak hash table.") | |
1100 | #define FUNC_NAME s_scm_doubly_weak_hash_table_p | |
1101 | { | |
1102 | return scm_from_bool (SCM_WEAK_TABLE_P (obj) && | |
1103 | SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH); | |
1104 | } | |
1105 | #undef FUNC_NAME | |
1106 | ||
1107 | ||
1108 | ||
1109 | \f | |
1110 | ||
7005c60f AW |
1111 | void |
1112 | scm_weak_table_prehistory (void) | |
1113 | { | |
1114 | weak_key_gc_kind = | |
1115 | GC_new_kind (GC_new_free_list (), | |
1116 | GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0), | |
1117 | 0, 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), | |
1121 | 0, 0); | |
1122 | } | |
1123 | ||
1124 | void | |
1125 | scm_init_weak_table () | |
1126 | { | |
1127 | #include "libguile/weak-table.x" | |
1128 | } | |
1129 | ||
1130 | /* | |
1131 | Local Variables: | |
1132 | c-file-style: "gnu" | |
1133 | End: | |
1134 | */ |