Commit | Line | Data |
---|---|---|
a0551390 | 1 | /* Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. |
26b26354 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/_scm.h" | |
28 | #include "libguile/hash.h" | |
29 | #include "libguile/eval.h" | |
30 | #include "libguile/ports.h" | |
31 | #include "libguile/bdw-gc.h" | |
32 | ||
33 | #include "libguile/validate.h" | |
34 | #include "libguile/weak-set.h" | |
35 | ||
36 | ||
37 | /* Weak Sets | |
38 | ||
39 | This file implements weak sets. One example of a weak set is the | |
40 | symbol table, where you want all instances of the `foo' symbol to map | |
41 | to one object. So when you load a file and it wants a symbol with | |
42 | the characters "foo", you one up in the table, using custom hash and | |
43 | equality predicates. Only if one is not found will you bother to | |
44 | cons one up and intern it. | |
45 | ||
46 | Another use case for weak sets is the set of open ports. Guile needs | |
47 | to be able to flush them all when the process exits, but the set | |
48 | shouldn't prevent the GC from collecting the port (and thus closing | |
49 | it). | |
50 | ||
51 | Weak sets are implemented using an open-addressed hash table. | |
52 | Basically this means that there is an array of entries, and the item | |
53 | is expected to be found the slot corresponding to its hash code, | |
54 | modulo the length of the array. | |
55 | ||
56 | Collisions are handled using linear probing with the Robin Hood | |
57 | technique. See Pedro Celis' paper, "Robin Hood Hashing": | |
58 | ||
59 | http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf | |
60 | ||
61 | The vector of entries is allocated as an "atomic" piece of memory, so | |
62 | that the GC doesn't trace it. When an item is added to the set, a | |
63 | disappearing link is registered to its location. If the item is | |
64 | collected, then that link will be zeroed out. | |
65 | ||
66 | An entry is not just an item, though; the hash code is also stored in | |
67 | the entry. We munge hash codes so that they are never 0. In this | |
68 | way we can detect removed entries (key of zero but nonzero hash | |
69 | code), and can then reshuffle elements as needed to maintain the | |
70 | robin hood ordering. | |
71 | ||
72 | Compared to buckets-and-chains hash tables, open addressing has the | |
73 | advantage that it is very cache-friendly. It also uses less memory. | |
74 | ||
75 | Implementation-wise, there are two things to note. | |
76 | ||
77 | 1. We assume that hash codes are evenly distributed across the | |
78 | range of unsigned longs. The actual hash code stored in the | |
79 | entry is left-shifted by 1 bit (losing 1 bit of hash precision), | |
80 | and then or'd with 1. In this way we ensure that the hash field | |
81 | of an occupied entry is nonzero. To map to an index, we | |
82 | right-shift the hash by one, divide by the size, and take the | |
83 | remainder. | |
84 | ||
85 | 2. Since the "keys" (the objects in the set) are stored in an | |
86 | atomic region with disappearing links, they need to be accessed | |
87 | with the GC alloc lock. `copy_weak_entry' will do that for | |
88 | you. The hash code itself can be read outside the lock, | |
89 | though. | |
90 | */ | |
91 | ||
92 | ||
93 | typedef struct { | |
94 | unsigned long hash; | |
95 | scm_t_bits key; | |
96 | } scm_t_weak_entry; | |
97 | ||
98 | ||
99 | struct weak_entry_data { | |
100 | scm_t_weak_entry *in; | |
101 | scm_t_weak_entry *out; | |
102 | }; | |
103 | ||
104 | static void* | |
105 | do_copy_weak_entry (void *data) | |
106 | { | |
107 | struct weak_entry_data *e = data; | |
108 | ||
109 | e->out->hash = e->in->hash; | |
110 | e->out->key = e->in->key; | |
111 | ||
112 | return NULL; | |
113 | } | |
114 | ||
115 | static void | |
116 | copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst) | |
117 | { | |
118 | struct weak_entry_data data; | |
119 | ||
120 | data.in = src; | |
121 | data.out = dst; | |
122 | ||
123 | GC_call_with_alloc_lock (do_copy_weak_entry, &data); | |
124 | } | |
125 | ||
126 | ||
127 | typedef struct { | |
128 | scm_t_weak_entry *entries; /* the data */ | |
129 | scm_i_pthread_mutex_t lock; /* the lock */ | |
130 | unsigned long size; /* total number of slots. */ | |
131 | unsigned long n_items; /* number of items in set */ | |
132 | unsigned long lower; /* when to shrink */ | |
133 | unsigned long upper; /* when to grow */ | |
134 | int size_index; /* index into hashset_size */ | |
135 | int min_size_index; /* minimum size_index */ | |
136 | } scm_t_weak_set; | |
137 | ||
138 | ||
dc7da0be | 139 | #define SCM_WEAK_SET_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set)) |
26b26354 AW |
140 | #define SCM_VALIDATE_WEAK_SET(pos, arg) \ |
141 | SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_SET_P, "weak-set") | |
142 | #define SCM_WEAK_SET(x) ((scm_t_weak_set *) SCM_CELL_WORD_1 (x)) | |
143 | ||
144 | ||
145 | static unsigned long | |
146 | hash_to_index (unsigned long hash, unsigned long size) | |
147 | { | |
148 | return (hash >> 1) % size; | |
149 | } | |
150 | ||
151 | static unsigned long | |
152 | entry_distance (unsigned long hash, unsigned long k, unsigned long size) | |
153 | { | |
154 | unsigned long origin = hash_to_index (hash, size); | |
155 | ||
156 | if (k >= origin) | |
157 | return k - origin; | |
158 | else | |
159 | /* The other key was displaced and wrapped around. */ | |
160 | return size - origin + k; | |
161 | } | |
162 | ||
a0551390 AW |
163 | #ifndef HAVE_GC_MOVE_DISAPPEARING_LINK |
164 | static void | |
165 | GC_move_disappearing_link (void **from, void **to) | |
166 | { | |
167 | GC_unregister_disappearing_link (from); | |
168 | SCM_I_REGISTER_DISAPPEARING_LINK (to, *to); | |
169 | } | |
170 | #endif | |
171 | ||
26b26354 AW |
172 | static void |
173 | move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to) | |
174 | { | |
175 | if (from->hash) | |
176 | { | |
177 | scm_t_weak_entry copy; | |
178 | ||
179 | copy_weak_entry (from, ©); | |
180 | to->hash = copy.hash; | |
181 | to->key = copy.key; | |
182 | ||
8c5bb729 | 183 | if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key))) |
a0551390 | 184 | GC_move_disappearing_link ((void **) &from->key, (void **) &to->key); |
26b26354 AW |
185 | } |
186 | else | |
187 | { | |
188 | to->hash = 0; | |
189 | to->key = 0; | |
190 | } | |
191 | } | |
192 | ||
193 | static void | |
194 | rob_from_rich (scm_t_weak_set *set, unsigned long k) | |
195 | { | |
196 | unsigned long empty, size; | |
197 | ||
198 | size = set->size; | |
199 | ||
200 | /* If we are to free up slot K in the set, we need room to do so. */ | |
201 | assert (set->n_items < size); | |
202 | ||
203 | empty = k; | |
204 | do | |
205 | empty = (empty + 1) % size; | |
206 | /* Here we access key outside the lock. Is this a problem? At first | |
207 | glance, I wouldn't think so. */ | |
208 | while (set->entries[empty].key); | |
209 | ||
210 | do | |
211 | { | |
212 | unsigned long last = empty ? (empty - 1) : (size - 1); | |
213 | move_weak_entry (&set->entries[last], &set->entries[empty]); | |
214 | empty = last; | |
215 | } | |
216 | while (empty != k); | |
217 | ||
218 | /* Just for sanity. */ | |
219 | set->entries[empty].hash = 0; | |
220 | set->entries[empty].key = 0; | |
221 | } | |
222 | ||
223 | static void | |
224 | give_to_poor (scm_t_weak_set *set, unsigned long k) | |
225 | { | |
226 | /* Slot K was just freed up; possibly shuffle others down. */ | |
227 | unsigned long size = set->size; | |
228 | ||
229 | while (1) | |
230 | { | |
231 | unsigned long next = (k + 1) % size; | |
232 | unsigned long hash; | |
233 | scm_t_weak_entry copy; | |
234 | ||
235 | hash = set->entries[next].hash; | |
236 | ||
237 | if (!hash || hash_to_index (hash, size) == next) | |
238 | break; | |
239 | ||
240 | copy_weak_entry (&set->entries[next], ©); | |
241 | ||
242 | if (!copy.key) | |
243 | /* Lost weak reference. */ | |
244 | { | |
245 | give_to_poor (set, next); | |
246 | set->n_items--; | |
247 | continue; | |
248 | } | |
249 | ||
250 | move_weak_entry (&set->entries[next], &set->entries[k]); | |
251 | ||
252 | k = next; | |
253 | } | |
254 | ||
255 | /* We have shuffled down any entries that should be shuffled down; now | |
256 | free the end. */ | |
257 | set->entries[k].hash = 0; | |
258 | set->entries[k].key = 0; | |
259 | } | |
260 | ||
261 | ||
262 | \f | |
263 | ||
264 | /* Growing or shrinking is triggered when the load factor | |
265 | * | |
266 | * L = N / S (N: number of items in set, S: bucket vector length) | |
267 | * | |
268 | * passes an upper limit of 0.9 or a lower limit of 0.2. | |
269 | * | |
270 | * The implementation stores the upper and lower number of items which | |
271 | * trigger a resize in the hashset object. | |
272 | * | |
273 | * Possible hash set sizes (primes) are stored in the array | |
274 | * hashset_size. | |
275 | */ | |
276 | ||
277 | static unsigned long hashset_size[] = { | |
278 | 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363, | |
279 | 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081, | |
280 | 57524111, 115048217, 230096423 | |
281 | }; | |
282 | ||
283 | #define HASHSET_SIZE_N (sizeof(hashset_size)/sizeof(unsigned long)) | |
284 | ||
aac980de AW |
285 | static int |
286 | compute_size_index (scm_t_weak_set *set) | |
26b26354 | 287 | { |
aac980de | 288 | int i = set->size_index; |
26b26354 | 289 | |
26b26354 AW |
290 | if (set->n_items < set->lower) |
291 | { | |
292 | /* rehashing is not triggered when i <= min_size */ | |
26b26354 AW |
293 | do |
294 | --i; | |
295 | while (i > set->min_size_index | |
aac980de | 296 | && set->n_items < hashset_size[i] / 5); |
26b26354 | 297 | } |
aac980de | 298 | else if (set->n_items > set->upper) |
26b26354 | 299 | { |
aac980de | 300 | ++i; |
26b26354 AW |
301 | if (i >= HASHSET_SIZE_N) |
302 | /* The biggest size currently is 230096423, which for a 32-bit | |
303 | machine will occupy 1.5GB of memory at a load of 80%. There | |
304 | is probably something better to do here, but if you have a | |
305 | weak map of that size, you are hosed in any case. */ | |
306 | abort (); | |
307 | } | |
308 | ||
aac980de AW |
309 | return i; |
310 | } | |
311 | ||
7932759f AW |
312 | static int |
313 | is_acceptable_size_index (scm_t_weak_set *set, int size_index) | |
314 | { | |
315 | int computed = compute_size_index (set); | |
316 | ||
317 | if (size_index == computed) | |
318 | /* We were going to grow or shrink, and allocating the new vector | |
319 | didn't change the target size. */ | |
320 | return 1; | |
321 | ||
322 | if (size_index == computed + 1) | |
323 | { | |
324 | /* We were going to enlarge the set, but allocating the new | |
325 | vector finalized some objects, making an enlargement | |
326 | unnecessary. It might still be a good idea to use the larger | |
327 | set, though. (This branch also gets hit if, while allocating | |
328 | the vector, some other thread was actively removing items from | |
329 | the set. That is less likely, though.) */ | |
330 | unsigned long new_lower = hashset_size[size_index] / 5; | |
331 | ||
332 | return set->size > new_lower; | |
333 | } | |
334 | ||
335 | if (size_index == computed - 1) | |
336 | { | |
337 | /* We were going to shrink the set, but when we dropped the lock | |
338 | to allocate the new vector, some other thread added elements to | |
339 | the set. */ | |
340 | return 0; | |
341 | } | |
342 | ||
343 | /* The computed size differs from our newly allocated size by more | |
344 | than one size index -- recalculate. */ | |
345 | return 0; | |
346 | } | |
347 | ||
aac980de AW |
348 | static void |
349 | resize_set (scm_t_weak_set *set) | |
350 | { | |
351 | scm_t_weak_entry *old_entries, *new_entries; | |
352 | int new_size_index; | |
353 | unsigned long old_size, new_size, old_k; | |
354 | ||
355 | do | |
356 | { | |
357 | new_size_index = compute_size_index (set); | |
358 | if (new_size_index == set->size_index) | |
359 | return; | |
360 | new_size = hashset_size[new_size_index]; | |
aac980de AW |
361 | new_entries = scm_gc_malloc_pointerless (new_size * sizeof(scm_t_weak_entry), |
362 | "weak set"); | |
aac980de | 363 | } |
7932759f | 364 | while (!is_acceptable_size_index (set, new_size_index)); |
aac980de AW |
365 | |
366 | old_entries = set->entries; | |
367 | old_size = set->size; | |
368 | ||
26b26354 AW |
369 | memset (new_entries, 0, new_size * sizeof(scm_t_weak_entry)); |
370 | ||
aac980de | 371 | set->size_index = new_size_index; |
26b26354 | 372 | set->size = new_size; |
aac980de | 373 | if (new_size_index <= set->min_size_index) |
26b26354 AW |
374 | set->lower = 0; |
375 | else | |
376 | set->lower = new_size / 5; | |
377 | set->upper = 9 * new_size / 10; | |
378 | set->n_items = 0; | |
379 | set->entries = new_entries; | |
380 | ||
381 | for (old_k = 0; old_k < old_size; old_k++) | |
382 | { | |
383 | scm_t_weak_entry copy; | |
384 | unsigned long new_k, distance; | |
385 | ||
386 | if (!old_entries[old_k].hash) | |
387 | continue; | |
388 | ||
389 | copy_weak_entry (&old_entries[old_k], ©); | |
390 | ||
391 | if (!copy.key) | |
392 | continue; | |
393 | ||
394 | new_k = hash_to_index (copy.hash, new_size); | |
395 | ||
396 | for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size) | |
397 | { | |
398 | unsigned long other_hash = new_entries[new_k].hash; | |
399 | ||
400 | if (!other_hash) | |
401 | /* Found an empty entry. */ | |
402 | break; | |
403 | ||
404 | /* Displace the entry if our distance is less, otherwise keep | |
405 | looking. */ | |
406 | if (entry_distance (other_hash, new_k, new_size) < distance) | |
407 | { | |
408 | rob_from_rich (set, new_k); | |
409 | break; | |
410 | } | |
411 | } | |
412 | ||
413 | set->n_items++; | |
414 | new_entries[new_k].hash = copy.hash; | |
415 | new_entries[new_k].key = copy.key; | |
416 | ||
8c5bb729 | 417 | if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key))) |
2aed2667 AW |
418 | SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key, |
419 | (void *) new_entries[new_k].key); | |
26b26354 AW |
420 | } |
421 | } | |
422 | ||
a0551390 AW |
423 | /* Run from a finalizer via do_vacuum_weak_set, this function runs over |
424 | the whole table, removing lost weak references, reshuffling the set | |
425 | as it goes. It might resize the set if it reaps enough entries. */ | |
26b26354 AW |
426 | static void |
427 | vacuum_weak_set (scm_t_weak_set *set) | |
428 | { | |
429 | scm_t_weak_entry *entries = set->entries; | |
430 | unsigned long size = set->size; | |
431 | unsigned long k; | |
432 | ||
433 | for (k = 0; k < size; k++) | |
434 | { | |
435 | unsigned long hash = entries[k].hash; | |
436 | ||
437 | if (hash) | |
438 | { | |
439 | scm_t_weak_entry copy; | |
440 | ||
441 | copy_weak_entry (&entries[k], ©); | |
442 | ||
443 | if (!copy.key) | |
444 | /* Lost weak reference; reshuffle. */ | |
445 | { | |
446 | give_to_poor (set, k); | |
447 | set->n_items--; | |
448 | } | |
449 | } | |
450 | } | |
451 | ||
452 | if (set->n_items < set->lower) | |
453 | resize_set (set); | |
454 | } | |
455 | ||
456 | ||
457 | \f | |
458 | ||
459 | static SCM | |
460 | weak_set_lookup (scm_t_weak_set *set, unsigned long hash, | |
461 | scm_t_set_predicate_fn pred, void *closure, | |
462 | SCM dflt) | |
463 | { | |
464 | unsigned long k, distance, size; | |
465 | scm_t_weak_entry *entries; | |
466 | ||
467 | size = set->size; | |
468 | entries = set->entries; | |
469 | ||
470 | hash = (hash << 1) | 0x1; | |
471 | k = hash_to_index (hash, size); | |
472 | ||
473 | for (distance = 0; distance < size; distance++, k = (k + 1) % size) | |
474 | { | |
475 | unsigned long other_hash; | |
476 | ||
477 | retry: | |
478 | other_hash = entries[k].hash; | |
479 | ||
480 | if (!other_hash) | |
481 | /* Not found. */ | |
482 | return dflt; | |
483 | ||
484 | if (hash == other_hash) | |
485 | { | |
486 | scm_t_weak_entry copy; | |
487 | ||
488 | copy_weak_entry (&entries[k], ©); | |
489 | ||
490 | if (!copy.key) | |
491 | /* Lost weak reference; reshuffle. */ | |
492 | { | |
493 | give_to_poor (set, k); | |
494 | set->n_items--; | |
495 | goto retry; | |
496 | } | |
497 | ||
498 | if (pred (SCM_PACK (copy.key), closure)) | |
499 | /* Found. */ | |
500 | return SCM_PACK (copy.key); | |
501 | } | |
502 | ||
503 | /* If the entry's distance is less, our key is not in the set. */ | |
504 | if (entry_distance (other_hash, k, size) < distance) | |
505 | return dflt; | |
506 | } | |
507 | ||
508 | /* If we got here, then we were unfortunate enough to loop through the | |
509 | whole set. Shouldn't happen, but hey. */ | |
510 | return dflt; | |
511 | } | |
512 | ||
513 | ||
514 | static SCM | |
515 | weak_set_add_x (scm_t_weak_set *set, unsigned long hash, | |
516 | scm_t_set_predicate_fn pred, void *closure, | |
517 | SCM obj) | |
518 | { | |
519 | unsigned long k, distance, size; | |
520 | scm_t_weak_entry *entries; | |
521 | ||
522 | size = set->size; | |
523 | entries = set->entries; | |
524 | ||
525 | hash = (hash << 1) | 0x1; | |
526 | k = hash_to_index (hash, size); | |
527 | ||
528 | for (distance = 0; ; distance++, k = (k + 1) % size) | |
529 | { | |
530 | unsigned long other_hash; | |
531 | ||
532 | retry: | |
533 | other_hash = entries[k].hash; | |
534 | ||
535 | if (!other_hash) | |
536 | /* Found an empty entry. */ | |
537 | break; | |
538 | ||
539 | if (other_hash == hash) | |
540 | { | |
541 | scm_t_weak_entry copy; | |
542 | ||
543 | copy_weak_entry (&entries[k], ©); | |
544 | ||
545 | if (!copy.key) | |
546 | /* Lost weak reference; reshuffle. */ | |
547 | { | |
548 | give_to_poor (set, k); | |
549 | set->n_items--; | |
550 | goto retry; | |
551 | } | |
552 | ||
553 | if (pred (SCM_PACK (copy.key), closure)) | |
554 | /* Found an entry with this key. */ | |
555 | return SCM_PACK (copy.key); | |
556 | } | |
557 | ||
558 | if (set->n_items > set->upper) | |
559 | /* Full set, time to resize. */ | |
560 | { | |
561 | resize_set (set); | |
562 | return weak_set_add_x (set, hash >> 1, pred, closure, obj); | |
563 | } | |
564 | ||
565 | /* Displace the entry if our distance is less, otherwise keep | |
566 | looking. */ | |
567 | if (entry_distance (other_hash, k, size) < distance) | |
568 | { | |
569 | rob_from_rich (set, k); | |
570 | break; | |
571 | } | |
572 | } | |
573 | ||
574 | set->n_items++; | |
575 | entries[k].hash = hash; | |
576 | entries[k].key = SCM_UNPACK (obj); | |
577 | ||
8c5bb729 | 578 | if (SCM_HEAP_OBJECT_P (obj)) |
2aed2667 AW |
579 | SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key, |
580 | (void *) SCM2PTR (obj)); | |
26b26354 AW |
581 | |
582 | return obj; | |
583 | } | |
584 | ||
585 | ||
586 | static void | |
587 | weak_set_remove_x (scm_t_weak_set *set, unsigned long hash, | |
588 | scm_t_set_predicate_fn pred, void *closure) | |
589 | { | |
590 | unsigned long k, distance, size; | |
591 | scm_t_weak_entry *entries; | |
592 | ||
593 | size = set->size; | |
594 | entries = set->entries; | |
595 | ||
596 | hash = (hash << 1) | 0x1; | |
597 | k = hash_to_index (hash, size); | |
598 | ||
599 | for (distance = 0; distance < size; distance++, k = (k + 1) % size) | |
600 | { | |
601 | unsigned long other_hash; | |
602 | ||
603 | retry: | |
604 | other_hash = entries[k].hash; | |
605 | ||
606 | if (!other_hash) | |
607 | /* Not found. */ | |
608 | return; | |
609 | ||
610 | if (other_hash == hash) | |
611 | { | |
612 | scm_t_weak_entry copy; | |
613 | ||
614 | copy_weak_entry (&entries[k], ©); | |
615 | ||
616 | if (!copy.key) | |
617 | /* Lost weak reference; reshuffle. */ | |
618 | { | |
619 | give_to_poor (set, k); | |
620 | set->n_items--; | |
621 | goto retry; | |
622 | } | |
623 | ||
624 | if (pred (SCM_PACK (copy.key), closure)) | |
625 | /* Found an entry with this key. */ | |
626 | { | |
627 | entries[k].hash = 0; | |
628 | entries[k].key = 0; | |
629 | ||
8c5bb729 | 630 | if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key))) |
2aed2667 | 631 | GC_unregister_disappearing_link ((void **) &entries[k].key); |
26b26354 AW |
632 | |
633 | if (--set->n_items < set->lower) | |
634 | resize_set (set); | |
635 | else | |
636 | give_to_poor (set, k); | |
637 | ||
638 | return; | |
639 | } | |
640 | } | |
641 | ||
642 | /* If the entry's distance is less, our key is not in the set. */ | |
643 | if (entry_distance (other_hash, k, size) < distance) | |
644 | return; | |
645 | } | |
646 | } | |
647 | ||
648 | ||
649 | \f | |
650 | static SCM | |
651 | make_weak_set (unsigned long k) | |
652 | { | |
653 | scm_t_weak_set *set; | |
654 | ||
655 | int i = 0, n = k ? k : 31; | |
656 | while (i + 1 < HASHSET_SIZE_N && n > hashset_size[i]) | |
657 | ++i; | |
658 | n = hashset_size[i]; | |
659 | ||
660 | set = scm_gc_malloc (sizeof (*set), "weak-set"); | |
661 | set->entries = scm_gc_malloc_pointerless (n * sizeof(scm_t_weak_entry), | |
662 | "weak-set"); | |
663 | memset (set->entries, 0, n * sizeof(scm_t_weak_entry)); | |
664 | set->n_items = 0; | |
665 | set->size = n; | |
666 | set->lower = 0; | |
667 | set->upper = 9 * n / 10; | |
668 | set->size_index = i; | |
669 | set->min_size_index = i; | |
670 | scm_i_pthread_mutex_init (&set->lock, NULL); | |
671 | ||
672 | return scm_cell (scm_tc7_weak_set, (scm_t_bits)set); | |
673 | } | |
674 | ||
675 | void | |
676 | scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate) | |
677 | { | |
0607ebbf AW |
678 | scm_puts_unlocked ("#<", port); |
679 | scm_puts_unlocked ("weak-set ", port); | |
26b26354 | 680 | scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port); |
0607ebbf | 681 | scm_putc_unlocked ('/', port); |
26b26354 | 682 | scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port); |
0607ebbf | 683 | scm_puts_unlocked (">", port); |
26b26354 AW |
684 | } |
685 | ||
686 | static void | |
687 | do_vacuum_weak_set (SCM set) | |
688 | { | |
689 | scm_t_weak_set *s; | |
690 | ||
691 | s = SCM_WEAK_SET (set); | |
692 | ||
a0551390 AW |
693 | /* We should always be able to grab this lock, because we are run from |
694 | a finalizer, which runs in another thread (or an async, which is | |
695 | mostly equivalent). */ | |
696 | scm_i_pthread_mutex_lock (&s->lock); | |
697 | vacuum_weak_set (s); | |
698 | scm_i_pthread_mutex_unlock (&s->lock); | |
26b26354 AW |
699 | } |
700 | ||
701 | SCM | |
702 | scm_c_make_weak_set (unsigned long k) | |
703 | { | |
704 | SCM ret; | |
705 | ||
706 | ret = make_weak_set (k); | |
707 | ||
a0551390 | 708 | scm_i_register_weak_gc_callback (ret, do_vacuum_weak_set); |
26b26354 AW |
709 | |
710 | return ret; | |
711 | } | |
712 | ||
713 | SCM | |
714 | scm_weak_set_p (SCM obj) | |
715 | { | |
716 | return scm_from_bool (SCM_WEAK_SET_P (obj)); | |
717 | } | |
718 | ||
719 | SCM | |
720 | scm_weak_set_clear_x (SCM set) | |
721 | { | |
722 | scm_t_weak_set *s = SCM_WEAK_SET (set); | |
723 | ||
81b80b96 | 724 | scm_i_pthread_mutex_lock (&s->lock); |
26b26354 AW |
725 | |
726 | memset (s->entries, 0, sizeof (scm_t_weak_entry) * s->size); | |
727 | s->n_items = 0; | |
728 | ||
81b80b96 | 729 | scm_i_pthread_mutex_unlock (&s->lock); |
26b26354 AW |
730 | |
731 | return SCM_UNSPECIFIED; | |
732 | } | |
733 | ||
734 | SCM | |
735 | scm_c_weak_set_lookup (SCM set, unsigned long raw_hash, | |
736 | scm_t_set_predicate_fn pred, | |
737 | void *closure, SCM dflt) | |
738 | { | |
739 | SCM ret; | |
740 | scm_t_weak_set *s = SCM_WEAK_SET (set); | |
741 | ||
81b80b96 | 742 | scm_i_pthread_mutex_lock (&s->lock); |
26b26354 AW |
743 | |
744 | ret = weak_set_lookup (s, raw_hash, pred, closure, dflt); | |
745 | ||
81b80b96 | 746 | scm_i_pthread_mutex_unlock (&s->lock); |
26b26354 AW |
747 | |
748 | return ret; | |
749 | } | |
750 | ||
751 | SCM | |
752 | scm_c_weak_set_add_x (SCM set, unsigned long raw_hash, | |
753 | scm_t_set_predicate_fn pred, | |
754 | void *closure, SCM obj) | |
755 | { | |
756 | SCM ret; | |
757 | scm_t_weak_set *s = SCM_WEAK_SET (set); | |
758 | ||
81b80b96 | 759 | scm_i_pthread_mutex_lock (&s->lock); |
26b26354 AW |
760 | |
761 | ret = weak_set_add_x (s, raw_hash, pred, closure, obj); | |
762 | ||
81b80b96 | 763 | scm_i_pthread_mutex_unlock (&s->lock); |
26b26354 AW |
764 | |
765 | return ret; | |
766 | } | |
767 | ||
768 | void | |
769 | scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash, | |
770 | scm_t_set_predicate_fn pred, | |
771 | void *closure) | |
772 | { | |
773 | scm_t_weak_set *s = SCM_WEAK_SET (set); | |
774 | ||
81b80b96 | 775 | scm_i_pthread_mutex_lock (&s->lock); |
26b26354 AW |
776 | |
777 | weak_set_remove_x (s, raw_hash, pred, closure); | |
778 | ||
81b80b96 | 779 | scm_i_pthread_mutex_unlock (&s->lock); |
26b26354 AW |
780 | } |
781 | ||
782 | static int | |
783 | eq_predicate (SCM x, void *closure) | |
784 | { | |
21041372 | 785 | return scm_is_eq (x, SCM_PACK_POINTER (closure)); |
26b26354 AW |
786 | } |
787 | ||
788 | SCM | |
789 | scm_weak_set_add_x (SCM set, SCM obj) | |
790 | { | |
791 | return scm_c_weak_set_add_x (set, scm_ihashq (obj, -1), | |
21041372 | 792 | eq_predicate, SCM_UNPACK_POINTER (obj), obj); |
26b26354 AW |
793 | } |
794 | ||
795 | SCM | |
796 | scm_weak_set_remove_x (SCM set, SCM obj) | |
797 | { | |
798 | scm_c_weak_set_remove_x (set, scm_ihashq (obj, -1), | |
21041372 | 799 | eq_predicate, SCM_UNPACK_POINTER (obj)); |
26b26354 AW |
800 | |
801 | return SCM_UNSPECIFIED; | |
802 | } | |
803 | ||
804 | SCM | |
805 | scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure, | |
806 | SCM init, SCM set) | |
807 | { | |
808 | scm_t_weak_set *s; | |
809 | scm_t_weak_entry *entries; | |
810 | unsigned long k, size; | |
811 | ||
812 | s = SCM_WEAK_SET (set); | |
813 | ||
81b80b96 | 814 | scm_i_pthread_mutex_lock (&s->lock); |
26b26354 AW |
815 | |
816 | size = s->size; | |
817 | entries = s->entries; | |
818 | ||
819 | for (k = 0; k < size; k++) | |
820 | { | |
821 | if (entries[k].hash) | |
822 | { | |
823 | scm_t_weak_entry copy; | |
824 | ||
825 | copy_weak_entry (&entries[k], ©); | |
826 | ||
827 | if (copy.key) | |
828 | { | |
829 | /* Release set lock while we call the function. */ | |
81b80b96 | 830 | scm_i_pthread_mutex_unlock (&s->lock); |
26b26354 | 831 | init = proc (closure, SCM_PACK (copy.key), init); |
81b80b96 | 832 | scm_i_pthread_mutex_lock (&s->lock); |
26b26354 AW |
833 | } |
834 | } | |
835 | } | |
836 | ||
81b80b96 | 837 | scm_i_pthread_mutex_unlock (&s->lock); |
26b26354 AW |
838 | |
839 | return init; | |
840 | } | |
841 | ||
842 | static SCM | |
843 | fold_trampoline (void *closure, SCM item, SCM init) | |
844 | { | |
21041372 | 845 | return scm_call_2 (SCM_PACK_POINTER (closure), item, init); |
26b26354 AW |
846 | } |
847 | ||
848 | SCM | |
849 | scm_weak_set_fold (SCM proc, SCM init, SCM set) | |
850 | { | |
21041372 | 851 | return scm_c_weak_set_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, set); |
26b26354 AW |
852 | } |
853 | ||
854 | static SCM | |
855 | for_each_trampoline (void *closure, SCM item, SCM seed) | |
856 | { | |
21041372 | 857 | scm_call_1 (SCM_PACK_POINTER (closure), item); |
26b26354 AW |
858 | return seed; |
859 | } | |
860 | ||
861 | SCM | |
862 | scm_weak_set_for_each (SCM proc, SCM set) | |
863 | { | |
21041372 | 864 | scm_c_weak_set_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, set); |
26b26354 AW |
865 | |
866 | return SCM_UNSPECIFIED; | |
867 | } | |
868 | ||
869 | static SCM | |
870 | map_trampoline (void *closure, SCM item, SCM seed) | |
871 | { | |
21041372 | 872 | return scm_cons (scm_call_1 (SCM_PACK_POINTER (closure), item), seed); |
26b26354 AW |
873 | } |
874 | ||
875 | SCM | |
876 | scm_weak_set_map_to_list (SCM proc, SCM set) | |
877 | { | |
21041372 | 878 | return scm_c_weak_set_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, set); |
26b26354 AW |
879 | } |
880 | ||
881 | ||
882 | void | |
883 | scm_init_weak_set () | |
884 | { | |
885 | #include "libguile/weak-set.x" | |
886 | } | |
887 | ||
888 | /* | |
889 | Local Variables: | |
890 | c-file-style: "gnu" | |
891 | End: | |
892 | */ |