[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Weak tables harmful to GC?
|
From: |
Ludovic Courtès |
|
Subject: |
Re: Weak tables harmful to GC? |
|
Date: |
Sun, 22 Oct 2017 17:16:56 -0700 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/25.3 (gnu/linux) |
Hi Chris,
Thanks for your support. :-)
Christopher Allan Webber <address@hidden> skribis:
> + else
> + {
> + /* The move to BDW-GC with Guile 2.0 introduced some bugs
> + related to weak hash tables, threads, memory usage, and the
> + alloc lock. We were unable to fix these issues
> + satisfactorily in 2.0 but have addressed them via a rewrite
> + in 2.2. If you see this message often, you probably want
> + to upgrade to 2.2. */
> + fprintf (stderr, "guile: warning: weak hash table corruption "
> + "(https://bugs.gnu.org/19180)");
> + len = 0;
> + }
>
> Guess reverting this patch means this comment also should be amended!
Indeed. :-)
The attached patch fixes the bug for me. Having spend days on
weak-table stuff, the bug looked (described in the commit log below)
almost obvious to me.
This tight loop used to trigger the bug after a few seconds; it no
longer does after several minutes:
(define table
(make-weak-key-hash-table))
(let loop ((i 0))
(unless #f
(hashq-set! table (make-list 1000) i)
(loop (1+ i))))
Also, it no longer displays the pathological behavior shown in
<https://bugs.gnu.org/28590>.
Of course, even better if people could test the two patches and confirm
that it works for them.
Then if there are no objections I’d like to merge them in ‘stable-2.2’.
Ludo’.
>From d61b9c0768ef28965be61e6c160f56bd17ef8715 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Sun, 22 Oct 2017 16:56:51 -0700
Subject: [PATCH 2/2] Keep weak hash table item count consistent.
Fixes a TOCTTOU kind of bug whereby we'd first count the number of items
deleted from the table, and later, *without* having the alloc lock, we'd
update the table's item count. The problem is that the item count could
have been updated in the meantime, hence the bug.
Fixes <https://bugs.gnu.org/19180>.
* libguile/hashtab.c (vacuum_weak_hash_table): Rename to...
(do_vacuum_weak_hash_table): ... this. Unmarshall the void* argument.
Replace 'fprintf' warning with an assertion.
(vacuum_weak_hash_table): New function. Call the above with
'GC_call_with_alloc_lock'.
(t_fixup_args): Add 'table' field; remove 'removed_items'.
(do_weak_bucket_fixup): Update TABLE's 'n_items' field.
(weak_bucket_assoc): Check 'SCM_HASHTABLE_N_ITEMS' instead of
'args.removed_items'.
---
libguile/hashtab.c | 68 +++++++++++++++++++++++++++---------------------------
1 file changed, 34 insertions(+), 34 deletions(-)
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index bd308c5e9..7a6585740 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -96,7 +96,7 @@ static char *s_hashtable = "hashtable";
/* Remove nullified weak pairs from ALIST such that the result contains only
valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
- deleted. */
+ deleted. Assumes the allocation lock is already taken. */
static SCM
scm_fixup_weak_alist (SCM alist, size_t *removed_items)
{
@@ -130,9 +130,10 @@ scm_fixup_weak_alist (SCM alist, size_t *removed_items)
return result;
}
-static void
-vacuum_weak_hash_table (SCM table)
+static void *
+do_vacuum_weak_hash_table (void *arg)
{
+ SCM table = SCM_PACK_POINTER (arg);
SCM buckets = SCM_HASHTABLE_VECTOR (table);
unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets);
size_t len = SCM_HASHTABLE_N_ITEMS (table);
@@ -142,44 +143,52 @@ vacuum_weak_hash_table (SCM table)
size_t removed;
SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
alist = scm_fixup_weak_alist (alist, &removed);
- if (removed <= len)
- len -= removed;
- else
- {
- /* The move to BDW-GC with Guile 2.0 introduced some bugs
- related to weak hash tables, threads, memory usage, and the
- alloc lock. We were unable to fix these issues
- satisfactorily in 2.0 but have addressed them via a rewrite
- in 2.2. If you see this message often, you probably want
- to upgrade to 2.2. */
- fprintf (stderr, "guile: warning: weak hash table corruption "
- "(https://bugs.gnu.org/19180)\n");
- len = 0;
- }
+
+ /* The alloc lock is taken, so we cannot get REMOVED > LEN. If we
+ do, that means we messed up while counting items. */
+ assert (removed <= len);
+
SCM_SIMPLE_VECTOR_SET (buckets, k, alist);
}
SCM_SET_HASHTABLE_N_ITEMS (table, len);
+
+ return table;
+}
+
+/* Remove deleted weak pairs from the buckets of TABLE, and update
+ TABLE's item count accordingly. */
+static void
+vacuum_weak_hash_table (SCM table)
+{
+ /* Take the alloc lock so we have a consistent view of the live
+ elements in TABLE. Failing to do that, we could be miscounting the
+ number of elements. */
+ GC_call_with_alloc_lock (do_vacuum_weak_hash_table,
+ SCM_PACK (table));
}
+
/* Packed arguments for `do_weak_bucket_fixup'. */
struct t_fixup_args
{
+ SCM table;
SCM bucket;
SCM *bucket_copy;
- size_t removed_items;
};
static void *
do_weak_bucket_fixup (void *data)
{
- struct t_fixup_args *args;
SCM pair, *copy;
+ size_t len, removed_items;
+ struct t_fixup_args *args = (struct t_fixup_args *) data;
- args = (struct t_fixup_args *) data;
+ args->bucket = scm_fixup_weak_alist (args->bucket, &removed_items);
- args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items);
+ len = SCM_HASHTABLE_N_ITEMS (args->table);
+ SCM_SET_HASHTABLE_N_ITEMS (args->table, len - removed_items);
for (pair = args->bucket, copy = args->bucket_copy;
scm_is_pair (pair);
@@ -214,6 +223,7 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t
bucket_index,
and values in BUCKET. */
strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM));
+ args.table = table;
args.bucket = bucket;
args.bucket_copy = strong_refs;
@@ -239,19 +249,9 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t
bucket_index,
scm_remember_upto_here_1 (strong_refs);
- if (args.removed_items > 0)
- {
- /* Update TABLE's item count and optionally trigger a rehash. */
- size_t remaining;
-
- assert (SCM_HASHTABLE_N_ITEMS (table) >= args.removed_items);
-
- remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items;
- SCM_SET_HASHTABLE_N_ITEMS (table, remaining);
-
- if (remaining < SCM_HASHTABLE_LOWER (table))
- scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
- }
+ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
+ /* Trigger a rehash. */
+ scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
return result;
}
--
2.14.2
>From 380d0ed6925245b2ace154f07743dd230f7018a2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Sat, 21 Oct 2017 16:18:39 -0600
Subject: [PATCH 1/2] Remove weak tables and revert to weak hash tables.
This removes weak-tables.[ch] and reintroduces weak hash tables as
implemented in Guile 2.0 into hashtab.[ch]. This reduces wall-clock
time by more than 15% on some GC-intensive benchmarks (compiling code)
where big weak hash tables are in use, such as source properties.
For more details on the rationale, see
<https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>.
* libguile.h: Don't include "weak-table.h".
* libguile/Makefile.am (address@hidden@_la_SOURCES)
(DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Remove weak-table.*
files.
* libguile/evalext.c (scm_self_evaluating_p): Remove reference to
scm_tc7_weak_table.
* libguile/hashtab.c (SCM_HASHTABLEF_WEAK_CAR)
(SCM_HASHTABLEF_WEAK_CDR): New macros.
* libguile/hashtab.c (scm_fixup_weak_alist, vacuum_weak_hash_table)
(do_weak_bucket_fixup, weak_bucket_assoc)
(weak_bucket_assoc_by_hash): New function.
(make_hash_table, scm_make_hash_table): Add support for weak hash
tables.
(weak_gc_callback, weak_gc_hook, weak_gc_finalizer)
(scm_c_register_weak_gc_callback, scm_make_weak_key_hash_table)
(scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table): New
functions.
(SCM_WEAK_TABLE_P): Remove.
(scm_weak_key_hash_table_p, scm_weak_value_hash_table_p)
(scm_doubly_weak_hash_table_p, scm_hash_fn_get_handle_by_hash): New
functions.
(scm_hash_fn_create_handle_x): Add support for weak hash tables.
(get_weak_cdr, weak_pair_cdr): New functions.
(scm_hash_fn_set_x): Add support for weak hash tables.
(scm_hash_fn_remove_x): Likewise.
(scm_hashq_get_handle, scm_hashq_create_handle_x): Likewise.
(scm_hashv_get_handle, scm_hashv_create_handle_x): Likewise.
(scm_hashq_ref, scm_hashq_set_x, scm_hashq_remove_x): Remove special
cases for 'SCM_WEAK_TABLE_P'.
(scm_hashv_ref, scm_hashv_set_x, scm_hashv_remove_x): Likewise.
(scm_hash_ref, scm_hash_set_x, scm_hash_remove_x): Likewise.
(scm_hashx_ref, scm_hashx_set_x, scm_hashx_remove_x): Likewise.
(assv_predicate, assoc_predicate, assx_predicate): Remove.
(scm_hash_map_to_list, scm_internal_hash_fold): Likewise, and check for
deleted entries.
(scm_internal_hash_for_each_handle): Likewise.
(scm_t_ihashx_closure): Remove 'key' field.
(wcar_pair_descr, wcdr_pair_descr): New variables.
(scm_weak_car_pair, scm_weak_cdr_pair, scm_doubly_weak_pair): New
functions.
(scm_weak_table_refq, scm_weak_table_putq_x, scm_c_make_weak_table)
(scm_c_weak_table_fold): Rewrite in terms of the hash-table API.
(scm_init_hashtab): Initialize 'wcar_pair_descr' and 'wcdr_pair_descr'.
* libguile/hashtab.h (scm_t_weak_table_kind): New type.
(SCM_HASHTABLE, SCM_HASHTABLE_FLAGS, SCM_HASHTABLE_WEAK_KEY_P)
(SCM_HASHTABLE_WEAK_VALUE_P, SCM_HASHTABLE_DOUBLY_WEAK_P): New macros.
(scm_t_hash_predicate_fn): New type.
(scm_t_hashtable)[flags]: New field.
(scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table)
(scm_make_weak_key_hash_table, scm_c_make_weak_table)
(scm_c_weak_table_fold, scm_weak_table_refq)
(scm_weak_table_putq_x): New declarations.
* libguile/init.c (scm_i_init_guile): Remove calls to
'scm_weak_table_prehistory' and 'scm_init_weak_table'.
(iprin1): Remove reference to scm_tc7_weak_table.
* libguile/procprop.c: Include "hashtab.h".
* libguile/tags.h (scm_tc7_weak_table): Remove.
* libguile/weak-list.h (scm_weak_car_pair, scm_weak_cdr_pair)
(scm_doubly_weak_pair): New declarations.
(SCM_WEAK_PAIR_DELETED_P, SCM_WEAK_PAIR_WORD_DELETED_P)
(SCM_WEAK_PAIR_CAR_DELETED_P, SCM_WEAK_PAIR_CDR_DELETED_P)
(SCM_WEAK_PAIR_WORD, SCM_WEAK_PAIR_CAR, SCM_WEAK_PAIR_CDR): New macros.
* module/system/base/types.scm (%tc7-weak-table): Mark as obsolete.
* test-suite/tests/types.test ("opaque objects"): Replace references to
'weak-table' with 'hash-table'. Add 'make-hash-table' test.
---
libguile.h | 3 +-
libguile/Makefile.am | 6 +-
libguile/evalext.c | 3 +-
libguile/hashtab.c | 878 +++++++++++++++++++++++++++++++++++--------
libguile/hashtab.h | 48 ++-
libguile/init.c | 4 +-
libguile/print.c | 5 +-
libguile/procprop.c | 4 +-
libguile/tags.h | 3 +-
libguile/weak-list.h | 32 +-
module/system/base/types.scm | 2 +-
test-suite/tests/types.test | 9 +-
12 files changed, 809 insertions(+), 188 deletions(-)
diff --git a/libguile.h b/libguile.h
index 3f7f0b791..90326844b 100644
--- a/libguile.h
+++ b/libguile.h
@@ -1,7 +1,7 @@
#ifndef SCM_LIBGUILE_H
#define SCM_LIBGUILE_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008,
2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008,
2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -117,7 +117,6 @@ extern "C" {
#include "libguile/version.h"
#include "libguile/vports.h"
#include "libguile/weak-set.h"
-#include "libguile/weak-table.h"
#include "libguile/weak-vector.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 2214a4aa3..6420d0f48 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with Automake to create Makefile.in
##
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
-## 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016 Free Software
Foundation, Inc.
+## 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016, 2017 Free Software
Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -225,7 +225,6 @@ address@hidden@_la_SOURCES =
\
vm.c \
vports.c \
weak-set.c \
- weak-table.c \
weak-vector.c
DOT_X_FILES = \
@@ -330,7 +329,6 @@ DOT_X_FILES = \
vm.x \
vports.x \
weak-set.x \
- weak-table.x \
weak-vector.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
@@ -432,7 +430,6 @@ DOT_DOC_FILES = \
version.doc \
vports.doc \
weak-set.doc \
- weak-table.doc \
weak-vector.doc
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
@@ -685,7 +682,6 @@ modinclude_HEADERS = \
vm.h \
vports.h \
weak-set.h \
- weak-table.h \
weak-vector.h
nodist_modinclude_HEADERS = version.h scmconfig.h
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 33205a2ca..e381daa65 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011,
2012, 2013, 2015 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011,
2012, 2013, 2015, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -77,7 +77,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0,
0,
case scm_tc7_pointer:
case scm_tc7_hashtable:
case scm_tc7_weak_set:
- case scm_tc7_weak_table:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
case scm_tc7_frame:
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 8920e08a6..bd308c5e9 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
- * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ * 2008, 2009, 2010, 2011, 2012, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -38,9 +38,18 @@
#include "libguile/validate.h"
#include "libguile/hashtab.h"
+#include <gc/gc_mark.h>
+#include <gc/gc_typed.h>
+
+/* Map the 2.0 names (on the left) to the new enum values. */
+#define SCM_HASHTABLEF_WEAK_CAR SCM_WEAK_TABLE_KIND_KEY
+#define SCM_HASHTABLEF_WEAK_CDR SCM_WEAK_TABLE_KIND_VALUE
+
+
+
/* A hash table is a cell containing a vector of association lists.
*
* Growing or shrinking, with following rehashing, is triggered when
@@ -53,6 +62,9 @@
* The implementation stores the upper and lower number of items which
* trigger a resize in the hashtable object.
*
+ * Weak hash tables use weak pairs in the bucket lists rather than
+ * normal pairs.
+ *
* Possible hash table sizes (primes) are stored in the array
* hashtable_size.
*/
@@ -72,8 +84,213 @@ static unsigned long hashtable_size[] = {
static char *s_hashtable = "hashtable";
+
+
+/* Helper functions and macros to deal with weak pairs.
+
+ Weak pairs need to be accessed very carefully since their components can
+ be nullified by the GC when the object they refer to becomes unreachable.
+ Hence the macros and functions below that detect such weak pairs within
+ buckets and remove them. */
+
+
+/* Remove nullified weak pairs from ALIST such that the result contains only
+ valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
+ deleted. */
static SCM
-make_hash_table (unsigned long k, const char *func_name)
+scm_fixup_weak_alist (SCM alist, size_t *removed_items)
+{
+ SCM result;
+ SCM prev = SCM_EOL;
+
+ *removed_items = 0;
+ for (result = alist;
+ scm_is_pair (alist);
+ alist = SCM_CDR (alist))
+ {
+ SCM pair = SCM_CAR (alist);
+
+ if (SCM_WEAK_PAIR_DELETED_P (pair))
+ {
+ /* Remove from ALIST weak pair PAIR whose car/cdr has been
+ nullified by the GC. */
+ if (scm_is_null (prev))
+ result = SCM_CDR (alist);
+ else
+ SCM_SETCDR (prev, SCM_CDR (alist));
+
+ (*removed_items)++;
+
+ /* Leave PREV unchanged. */
+ }
+ else
+ prev = alist;
+ }
+
+ return result;
+}
+
+static void
+vacuum_weak_hash_table (SCM table)
+{
+ SCM buckets = SCM_HASHTABLE_VECTOR (table);
+ unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ size_t len = SCM_HASHTABLE_N_ITEMS (table);
+
+ while (k--)
+ {
+ size_t removed;
+ SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
+ alist = scm_fixup_weak_alist (alist, &removed);
+ if (removed <= len)
+ len -= removed;
+ else
+ {
+ /* The move to BDW-GC with Guile 2.0 introduced some bugs
+ related to weak hash tables, threads, memory usage, and the
+ alloc lock. We were unable to fix these issues
+ satisfactorily in 2.0 but have addressed them via a rewrite
+ in 2.2. If you see this message often, you probably want
+ to upgrade to 2.2. */
+ fprintf (stderr, "guile: warning: weak hash table corruption "
+ "(https://bugs.gnu.org/19180)\n");
+ len = 0;
+ }
+ SCM_SIMPLE_VECTOR_SET (buckets, k, alist);
+ }
+
+ SCM_SET_HASHTABLE_N_ITEMS (table, len);
+}
+
+
+/* Packed arguments for `do_weak_bucket_fixup'. */
+struct t_fixup_args
+{
+ SCM bucket;
+ SCM *bucket_copy;
+ size_t removed_items;
+};
+
+static void *
+do_weak_bucket_fixup (void *data)
+{
+ struct t_fixup_args *args;
+ SCM pair, *copy;
+
+ args = (struct t_fixup_args *) data;
+
+ args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items);
+
+ for (pair = args->bucket, copy = args->bucket_copy;
+ scm_is_pair (pair);
+ pair = SCM_CDR (pair), copy += 2)
+ {
+ /* At this point, all weak pairs have been removed. */
+ assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair)));
+
+ /* Copy the key and value. */
+ copy[0] = SCM_CAAR (pair);
+ copy[1] = SCM_CDAR (pair);
+ }
+
+ return args;
+}
+
+/* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
+ for in the alist that is the BUCKET_INDEXth element of BUCKETS.
+ Optionally update TABLE and rehash it. */
+static SCM
+weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc, SCM object, void *closure)
+{
+ SCM result;
+ SCM bucket, *strong_refs;
+ struct t_fixup_args args;
+
+ bucket = SCM_SIMPLE_VECTOR_REF (buckets, bucket_index);
+
+ /* Prepare STRONG_REFS as an array large enough to hold all the keys
+ and values in BUCKET. */
+ strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM));
+
+ args.bucket = bucket;
+ args.bucket_copy = strong_refs;
+
+ /* Fixup BUCKET. Do that with the allocation lock held to avoid
+ seeing disappearing links pointing to objects that have already
+ been reclaimed (this happens when the disappearing links that point
+ to it haven't yet been cleared.)
+
+ The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
+ of BUCKET's entries after it's been fixed up. Thus, all the
+ entries kept in BUCKET are still reachable when ASSOC sees
+ them. */
+ GC_call_with_alloc_lock (do_weak_bucket_fixup, &args);
+
+ bucket = args.bucket;
+ SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket);
+
+ result = assoc (object, bucket, closure);
+
+ /* If we got a result, it should not have NULL fields. */
+ if (scm_is_pair (result) && SCM_WEAK_PAIR_DELETED_P (result))
+ abort ();
+
+ scm_remember_upto_here_1 (strong_refs);
+
+ if (args.removed_items > 0)
+ {
+ /* Update TABLE's item count and optionally trigger a rehash. */
+ size_t remaining;
+
+ assert (SCM_HASHTABLE_N_ITEMS (table) >= args.removed_items);
+
+ remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items;
+ SCM_SET_HASHTABLE_N_ITEMS (table, remaining);
+
+ if (remaining < SCM_HASHTABLE_LOWER (table))
+ scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
+ }
+
+ return result;
+}
+
+
+/* Packed arguments for `weak_bucket_assoc_by_hash'. */
+struct assoc_by_hash_data
+{
+ SCM alist;
+ SCM ret;
+ scm_t_hash_predicate_fn predicate;
+ void *closure;
+};
+
+/* See scm_hash_fn_get_handle_by_hash below. */
+static void*
+weak_bucket_assoc_by_hash (void *args)
+{
+ struct assoc_by_hash_data *data = args;
+ SCM alist = data->alist;
+
+ for (; scm_is_pair (alist); alist = SCM_CDR (alist))
+ {
+ SCM pair = SCM_CAR (alist);
+
+ if (!SCM_WEAK_PAIR_DELETED_P (pair)
+ && data->predicate (SCM_CAR (pair), data->closure))
+ {
+ data->ret = pair;
+ break;
+ }
+ }
+ return args;
+}
+
+
+
+static SCM
+make_hash_table (int flags, unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
@@ -82,6 +299,9 @@ make_hash_table (unsigned long k, const char *func_name)
++i;
n = hashtable_size[i];
+ /* In both cases, i.e., regardless of whether we are creating a weak hash
+ table, we return a non-weak vector. This is because the vector itself
+ is not weak in the case of a weak hash table: the alist pairs are. */
vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
@@ -89,6 +309,8 @@ make_hash_table (unsigned long k, const char *func_name)
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
+ t->flags = flags;
+ t->hash_fn = NULL;
/* FIXME: we just need two words of storage, not three */
return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
@@ -121,6 +343,13 @@ scm_i_rehash (SCM table,
if (i >= HASHTABLE_SIZE_N)
/* don't rehash */
return;
+
+ /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
+ is not needed since CLOSURE can not be guaranteed to be valid
+ after this function returns.
+ */
+ if (closure == NULL)
+ SCM_HASHTABLE (table)->hash_fn = hash_fn;
}
SCM_HASHTABLE (table)->size_index = i;
@@ -134,6 +363,13 @@ scm_i_rehash (SCM table,
new_buckets = scm_c_make_vector (new_size, SCM_EOL);
+ /* When this is a weak hashtable, running the GC might change it.
+ We need to cope with this while rehashing its elements. We do
+ this by first installing the new, empty bucket vector. Then we
+ remove the elements from the old bucket vector and insert them
+ into the new one.
+ */
+
SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
SCM_SET_HASHTABLE_N_ITEMS (table, 0);
@@ -153,6 +389,10 @@ scm_i_rehash (SCM table,
handle = SCM_CAR (cell);
ls = SCM_CDR (ls);
+ if (SCM_WEAK_PAIR_DELETED_P (handle))
+ /* HANDLE is a nullified weak pair: skip it. */
+ continue;
+
h = hash_fn (SCM_CAR (handle), new_size, closure);
if (h >= new_size)
scm_out_of_range (func_name, scm_from_ulong (h));
@@ -167,7 +407,14 @@ scm_i_rehash (SCM table,
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<hash-table ", port);
+ scm_puts ("#<", port);
+ if (SCM_HASHTABLE_WEAK_KEY_P (exp))
+ scm_puts ("weak-key-", port);
+ else if (SCM_HASHTABLE_WEAK_VALUE_P (exp))
+ scm_puts ("weak-value-", port);
+ else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
+ scm_puts ("doubly-weak-", port);
+ scm_puts ("hash-table ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
@@ -181,7 +428,7 @@ scm_i_hashtable_print (SCM exp, SCM port, scm_print_state
*pstate)
SCM
scm_c_make_hash_table (unsigned long k)
{
- return make_hash_table (k, "scm_c_make_hash_table");
+ return make_hash_table (0, k, "scm_c_make_hash_table");
}
SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
@@ -189,18 +436,171 @@ SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0,
1, 0,
"Make a new abstract hash table object with minimum number of
buckets @var{n}\n")
#define FUNC_NAME s_scm_make_hash_table
{
- return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
+ if (SCM_UNBNDP (n))
+ return make_hash_table (0, 0, FUNC_NAME);
+ else
+ return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
+}
+#undef FUNC_NAME
+
+/* The before-gc C hook only runs if GC_set_start_callback is available,
+ so if not, fall back on a finalizer-based implementation. */
+static int
+weak_gc_callback (void **weak)
+{
+ void *val = weak[0];
+ void (*callback) (SCM) = weak[1];
+
+ if (!val)
+ return 0;
+
+ callback (PTR2SCM (val));
+
+ return 1;
+}
+
+#ifdef HAVE_GC_SET_START_CALLBACK
+static void*
+weak_gc_hook (void *hook_data, void *fn_data, void *data)
+{
+ if (!weak_gc_callback (fn_data))
+ scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
+
+ return NULL;
+}
+#else
+static void
+weak_gc_finalizer (void *ptr, void *data)
+{
+ if (weak_gc_callback (ptr))
+ GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL);
+}
+#endif
+
+static void
+scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
+{
+ void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
+
+ weak[0] = SCM2PTR (obj);
+ weak[1] = (void*)callback;
+ GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
+
+#ifdef HAVE_GC_SET_START_CALLBACK
+ scm_c_hook_add (&scm_before_gc_c_hook, weak_gc_hook, weak, 0);
+#else
+ GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
+#endif
+}
+
+SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
+ (SCM n),
+ "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
+ "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
+ "Return a weak hash table with @var{size} buckets.\n"
+ "\n"
+ "You can modify weak hash tables in exactly the same way you\n"
+ "would modify regular hash tables. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_key_hash_table
+{
+ SCM ret;
+
+ if (SCM_UNBNDP (n))
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
+ else
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
+ scm_to_ulong (n), FUNC_NAME);
+
+ scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0,
1, 0,
+ (SCM n),
+ "Return a hash table with weak values with @var{size} buckets.\n"
+ "(@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_value_hash_table
+{
+ SCM ret;
+
+ if (SCM_UNBNDP (n))
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
+ else
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
+ scm_to_ulong (n), FUNC_NAME);
+
+ scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 0,
1, 0,
+ (SCM n),
+ "Return a hash table with weak keys and values with @var{size}\n"
+ "buckets. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_doubly_weak_hash_table
+{
+ SCM ret;
+
+ if (SCM_UNBNDP (n))
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+ 0, FUNC_NAME);
+ else
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+ scm_to_ulong (n), FUNC_NAME);
+
+ scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
+
+ return ret;
}
#undef FUNC_NAME
-#define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an abstract hash table object.")
#define FUNC_NAME s_scm_hash_table_p
{
- return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj));
+ return scm_from_bool (SCM_HASHTABLE_P (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
+ "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
+ "Return @code{#t} if @var{obj} is the specified weak hash\n"
+ "table. Note that a doubly weak hash table is neither a weak key\n"
+ "nor a weak value hash table.")
+#define FUNC_NAME s_scm_weak_key_hash_table_p
+{
+ return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P
(obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak value hash table.")
+#define FUNC_NAME s_scm_weak_value_hash_table_p
+{
+ return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P
(obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a doubly weak hash table.")
+#define FUNC_NAME s_scm_doubly_weak_hash_table_p
+{
+ return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P
(obj));
}
#undef FUNC_NAME
@@ -226,7 +626,69 @@ scm_hash_fn_get_handle (SCM table, SCM obj,
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ if (SCM_HASHTABLE_WEAK_P (table))
+ h = weak_bucket_assoc (table, buckets, k, hash_fn,
+ assoc_fn, obj, closure);
+ else
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+
+ return h;
+}
+#undef FUNC_NAME
+
+
+/* This procedure implements three optimizations, with respect to the
+ raw get_handle():
+
+ 1. For weak tables, it's assumed that calling the predicate in the
+ allocation lock is safe. In practice this means that the predicate
+ cannot call arbitrary scheme functions.
+
+ 2. We don't check for overflow / underflow and rehash.
+
+ 3. We don't actually have to allocate a key -- instead we get the
+ hash value directly. This is useful for, for example, looking up
+ strings in the symbol table.
+ */
+SCM
+scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash,
+ scm_t_hash_predicate_fn predicate_fn,
+ void *closure)
+#define FUNC_NAME "scm_hash_fn_ref_by_hash"
+{
+ unsigned long k;
+ SCM buckets, alist, h = SCM_BOOL_F;
+
+ SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
+ buckets = SCM_HASHTABLE_VECTOR (table);
+
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
+ return SCM_BOOL_F;
+
+ k = raw_hash % SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
+
+ if (SCM_HASHTABLE_WEAK_P (table))
+ {
+ struct assoc_by_hash_data args;
+
+ args.alist = alist;
+ args.ret = SCM_BOOL_F;
+ args.predicate = predicate_fn;
+ args.closure = closure;
+ GC_call_with_alloc_lock (weak_bucket_assoc_by_hash, &args);
+ h = args.ret;
+ }
+ else
+ for (; scm_is_pair (alist); alist = SCM_CDR (alist))
+ {
+ SCM pair = SCM_CAR (alist);
+ if (predicate_fn (SCM_CAR (pair), closure))
+ {
+ h = pair;
+ break;
+ }
+ }
return h;
}
@@ -252,7 +714,11 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ if (SCM_HASHTABLE_WEAK_P (table))
+ it = weak_bucket_assoc (table, buckets, k, hash_fn,
+ assoc_fn, obj, closure);
+ else
+ it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_pair (it))
return it;
@@ -260,9 +726,29 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
else
{
+ /* When this is a weak hashtable, running the GC can change it.
+ Thus, we must allocate the new cells first and can only then
+ access BUCKETS. Also, we need to fetch the bucket vector
+ again since the hashtable might have been rehashed. This
+ necessitates a new hash value as well.
+ */
SCM handle, new_bucket;
- handle = scm_cons (obj, init);
+ if (SCM_HASHTABLE_WEAK_P (table))
+ {
+ /* FIXME: We don't support weak alist vectors. */
+ /* Use a weak cell. */
+ if (SCM_HASHTABLE_DOUBLY_WEAK_P (table))
+ handle = scm_doubly_weak_pair (obj, init);
+ else if (SCM_HASHTABLE_WEAK_KEY_P (table))
+ handle = scm_weak_car_pair (obj, init);
+ else
+ handle = scm_weak_cdr_pair (obj, init);
+ }
+ else
+ /* Use a regular, non-weak cell. */
+ handle = scm_cons (obj, init);
+
new_bucket = scm_cons (handle, SCM_EOL);
if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
@@ -298,6 +784,36 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
return dflt;
}
+struct weak_cdr_data
+{
+ SCM pair;
+ SCM cdr;
+};
+
+static void*
+get_weak_cdr (void *data)
+{
+ struct weak_cdr_data *d = data;
+
+ if (SCM_WEAK_PAIR_CDR_DELETED_P (d->pair))
+ d->cdr = SCM_BOOL_F;
+ else
+ d->cdr = SCM_CDR (d->pair);
+
+ return NULL;
+}
+
+static SCM
+weak_pair_cdr (SCM x)
+{
+ struct weak_cdr_data data;
+
+ data.pair = x;
+ GC_call_with_alloc_lock (get_weak_cdr, &data);
+
+ return data.cdr;
+}
+
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
@@ -309,7 +825,24 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
hash_fn, assoc_fn, closure);
if (!scm_is_eq (SCM_CDR (pair), val))
- SCM_SETCDR (pair, val);
+ {
+ if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table)))
+ {
+ /* If the former value was on the heap, we need to unregister
+ the weak link. */
+ SCM prev = weak_pair_cdr (pair);
+
+ SCM_SETCDR (pair, val);
+
+ if (SCM_NIMP (prev) && !SCM_NIMP (val))
+ GC_unregister_disappearing_link ((void **) SCM_CDRLOC (pair));
+ else
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) SCM_CDRLOC (pair),
+ SCM2PTR (val));
+ }
+ else
+ SCM_SETCDR (pair, val);
+ }
return val;
}
@@ -336,7 +869,11 @@ scm_hash_fn_remove_x (SCM table, SCM obj,
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ if (SCM_HASHTABLE_WEAK_P (table))
+ h = weak_bucket_assoc (table, buckets, k, hash_fn,
+ assoc_fn, obj, closure);
+ else
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_true (h))
{
@@ -355,12 +892,6 @@ SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
"Remove all items from @var{table} (without triggering a resize).")
#define FUNC_NAME s_scm_hash_clear_x
{
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_clear_x (table);
- return SCM_UNSPECIFIED;
- }
-
SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
@@ -380,6 +911,9 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0,
0,
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -395,6 +929,9 @@ SCM_DEFINE (scm_hashq_create_handle_x,
"hashq-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -413,10 +950,6 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
-
- if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_refq (table, key, dflt);
-
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -432,12 +965,6 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
"store @var{val} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_putq_x (table, key, val);
- return val;
- }
-
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -453,16 +980,6 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_remq_x (table, key);
- /* This return value is for historical compatibility with
- hash-remove!, which returns either the "handle" corresponding
- to the entry, or #f. Since weak tables don't have handles, we
- have to return #f. */
- return SCM_BOOL_F;
- }
-
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -481,6 +998,9 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0,
0,
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -496,6 +1016,9 @@ SCM_DEFINE (scm_hashv_create_handle_x,
"hashv-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -504,12 +1027,6 @@ SCM_DEFINE (scm_hashv_create_handle_x,
"hashv-create-handle!", 3, 0, 0,
#undef FUNC_NAME
-static int
-assv_predicate (SCM k, SCM v, void *closure)
-{
- return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
-}
-
SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
@@ -520,12 +1037,6 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
-
- if (SCM_WEAK_TABLE_P (table))
- return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
- assv_predicate,
- (void *) SCM_UNPACK (key), dflt);
-
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -541,14 +1052,6 @@ SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
- assv_predicate, (void *) SCM_UNPACK (key),
- key, val);
- return val;
- }
-
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -563,14 +1066,6 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
- assv_predicate, (void *) SCM_UNPACK (key));
- /* See note in hashq-remove!. */
- return SCM_BOOL_F;
- }
-
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -588,6 +1083,9 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0,
0,
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -603,6 +1101,9 @@ SCM_DEFINE (scm_hash_create_handle_x,
"hash-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -611,12 +1112,6 @@ SCM_DEFINE (scm_hash_create_handle_x,
"hash-create-handle!", 3, 0, 0,
#undef FUNC_NAME
-static int
-assoc_predicate (SCM k, SCM v, void *closure)
-{
- return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
-}
-
SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
@@ -627,12 +1122,6 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
-
- if (SCM_WEAK_TABLE_P (table))
- return scm_c_weak_table_ref (table, scm_ihash (key, -1),
- assoc_predicate,
- (void *) SCM_UNPACK (key), dflt);
-
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -649,14 +1138,6 @@ SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_put_x (table, scm_ihash (key, -1),
- assoc_predicate, (void *) SCM_UNPACK (key),
- key, val);
- return val;
- }
-
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -672,14 +1153,6 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
- assoc_predicate, (void *) SCM_UNPACK (key));
- /* See note in hashq-remove!. */
- return SCM_BOOL_F;
- }
-
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -694,9 +1167,10 @@ typedef struct scm_t_ihashx_closure
{
SCM hash;
SCM assoc;
- SCM key;
} scm_t_ihashx_closure;
+
+
static unsigned long
scm_ihashx (SCM obj, unsigned long n, void *arg)
{
@@ -706,6 +1180,8 @@ scm_ihashx (SCM obj, unsigned long n, void *arg)
return scm_to_ulong (answer);
}
+
+
static SCM
scm_sloppy_assx (SCM obj, SCM alist, void *arg)
{
@@ -713,20 +1189,6 @@ scm_sloppy_assx (SCM obj, SCM alist, void *arg)
return scm_call_2 (closure->assoc, obj, alist);
}
-static int
-assx_predicate (SCM k, SCM v, void *closure)
-{
- scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
-
- /* FIXME: The hashx interface is crazy. Hash tables have nothing to
- do with alists in principle. Instead of getting an assoc proc,
- hashx functions should use an equality predicate. Perhaps we can
- change this before 2.2, but until then, add a terrible, terrible
- hack. */
-
- return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v,
SCM_EOL)));
-}
-
SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key),
@@ -741,7 +1203,9 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4,
0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
- closure.key = key;
+
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
@@ -762,7 +1226,9 @@ SCM_DEFINE (scm_hashx_create_handle_x,
"hashx-create-handle!", 5, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
- closure.key = key;
+
+ if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
@@ -789,15 +1255,6 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
dflt = SCM_BOOL_F;
closure.hash = hash;
closure.assoc = assoc;
- closure.key = key;
-
- if (SCM_WEAK_TABLE_P (table))
- {
- unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
- scm_from_ulong (-1)));
- return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
- }
-
return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
@@ -822,16 +1279,6 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
- closure.key = key;
-
- if (SCM_WEAK_TABLE_P (table))
- {
- unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
- scm_from_ulong (-1)));
- scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
- return val;
- }
-
return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
@@ -853,17 +1300,6 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
- closure.key = obj;
-
- if (SCM_WEAK_TABLE_P (table))
- {
- unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
- scm_from_ulong (-1)));
- scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
- /* See note in hashq-remove!. */
- return SCM_BOOL_F;
- }
-
return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
@@ -884,10 +1320,6 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
#define FUNC_NAME s_scm_hash_fold
{
SCM_VALIDATE_PROC (1, proc);
-
- if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_fold (proc, init, table);
-
SCM_VALIDATE_HASHTABLE (3, table);
return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
(void *) SCM_UNPACK (proc), init, table);
@@ -909,13 +1341,6 @@ SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
#define FUNC_NAME s_scm_hash_for_each
{
SCM_VALIDATE_PROC (1, proc);
-
- if (SCM_WEAK_TABLE_P (table))
- {
- scm_weak_table_for_each (proc, table);
- return SCM_UNSPECIFIED;
- }
-
SCM_VALIDATE_HASHTABLE (2, table);
scm_internal_hash_for_each_handle (for_each_proc,
@@ -934,6 +1359,9 @@ SCM_DEFINE (scm_hash_for_each_handle,
"hash-for-each-handle", 2, 0, 0,
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_VALIDATE_HASHTABLE (2, table);
+ if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table)))
+ SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc),
table);
@@ -956,10 +1384,6 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0,
0,
#define FUNC_NAME s_scm_hash_map_to_list
{
SCM_VALIDATE_PROC (1, proc);
-
- if (SCM_WEAK_TABLE_P (table))
- return scm_weak_table_map_to_list (proc, table);
-
SCM_VALIDATE_HASHTABLE (2, table);
return scm_internal_hash_fold (map_proc,
(void *) SCM_UNPACK (proc),
@@ -1005,9 +1429,6 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void
*closure,
long i, n;
SCM buckets, result = init;
- if (SCM_WEAK_TABLE_P (table))
- return scm_c_weak_table_fold (fn, closure, init, table);
-
SCM_VALIDATE_HASHTABLE (0, table);
buckets = SCM_HASHTABLE_VECTOR (table);
@@ -1020,7 +1441,14 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void
*closure,
ls = SCM_CDR (ls))
{
handle = SCM_CAR (ls);
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
+
+ if (SCM_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle))
+ /* Don't try to unlink this weak pair, as we're not within
+ the allocation lock. Instead rely on
+ vacuum_weak_hash_table to do its job. */
+ continue;
+ else
+ result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
}
}
@@ -1056,7 +1484,9 @@ scm_internal_hash_for_each_handle (scm_t_hash_handle_fn
fn, void *closure,
handle = SCM_CAR (ls);
if (!scm_is_pair (handle))
SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
- fn (closure, handle);
+ if (!SCM_HASHTABLE_WEAK_P (table)
+ || !SCM_WEAK_PAIR_DELETED_P (handle))
+ fn (closure, handle);
ls = SCM_CDR (ls);
}
}
@@ -1064,11 +1494,137 @@ scm_internal_hash_for_each_handle
(scm_t_hash_handle_fn fn, void *closure,
#undef FUNC_NAME
+/* Weak pairs for use in weak alist vectors and weak hash tables.
+
+ We have weal-car pairs, weak-cdr pairs, and doubly weak pairs. In weak
+ pairs, the weak component(s) are not scanned for pointers and are
+ registered as disapperaring links; therefore, the weak component may be
+ set to NULL by the garbage collector when no other reference to that word
+ exist. Thus, users should only access weak pairs via the
+ `SCM_WEAK_PAIR_C[AD]R ()' macros. See also `scm_fixup_weak_alist ()' in
+ `hashtab.c'. */
+
+/* Type descriptors for weak-c[ad]r pairs. */
+static GC_descr wcar_pair_descr, wcdr_pair_descr;
+
+
+SCM
+scm_weak_car_pair (SCM car, SCM cdr)
+{
+ scm_t_cell *cell;
+
+ cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
+ wcar_pair_descr);
+
+ cell->word_0 = car;
+ cell->word_1 = cdr;
+
+ if (SCM_NIMP (car))
+ /* Weak car cells make sense iff the car is non-immediate. */
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car));
+
+ return (SCM_PACK (cell));
+}
+
+SCM
+scm_weak_cdr_pair (SCM car, SCM cdr)
+{
+ scm_t_cell *cell;
+
+ cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
+ wcdr_pair_descr);
+
+ cell->word_0 = car;
+ cell->word_1 = cdr;
+
+ if (SCM_NIMP (cdr))
+ /* Weak cdr cells make sense iff the cdr is non-immediate. */
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr));
+
+ return (SCM_PACK (cell));
+}
+
+SCM
+scm_doubly_weak_pair (SCM car, SCM cdr)
+{
+ /* Doubly weak cells shall not be scanned at all for pointers. */
+ scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell),
+ "weak cell");
+
+ cell->word_0 = car;
+ cell->word_1 = cdr;
+
+ if (SCM_NIMP (car))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car));
+ if (SCM_NIMP (cdr))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr));
+
+ return (SCM_PACK (cell));
+}
+
+
+/* Backward-compatibility with the former internal weak-table API. */
+
+SCM
+scm_weak_table_refq (SCM table, SCM key, SCM dflt)
+{
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
+}
+
+void
+scm_weak_table_putq_x (SCM table, SCM key, SCM value)
+{
+ (void) scm_hashq_set_x (table, key, value);
+}
+
+SCM
+scm_c_make_weak_table (unsigned long size, scm_t_weak_table_kind kind)
+{
+ switch (kind)
+ {
+ case SCM_WEAK_TABLE_KIND_KEY:
+ return scm_make_weak_key_hash_table (scm_from_ulong (size));
+ case SCM_WEAK_TABLE_KIND_VALUE:
+ return scm_make_weak_value_hash_table (scm_from_ulong (size));
+ case SCM_WEAK_TABLE_KIND_BOTH:
+ return scm_make_doubly_weak_hash_table (scm_from_ulong (size));
+ default:
+ abort ();
+ }
+}
+
+SCM
+scm_c_weak_table_fold (scm_t_hash_fold_fn fn, void *closure,
+ SCM init, SCM table)
+{
+ return scm_internal_hash_fold (fn, closure, init, table);
+}
+
+
void
scm_init_hashtab ()
{
+ /* Initialize weak pairs. */
+ GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
+ GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
+
+ /* In a weak-car pair, only the second word must be scanned for
+ pointers. */
+ GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1));
+ wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap,
+ GC_WORD_LEN (scm_t_cell));
+
+ /* Conversely, in a weak-cdr pair, only the first word must be scanned for
+ pointers. */
+ GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0));
+ wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap,
+ GC_WORD_LEN (scm_t_cell));
+
#include "libguile/hashtab.x"
}
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 82ed22e66..19caea5dc 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -3,7 +3,7 @@
#ifndef SCM_HASHTAB_H
#define SCM_HASHTAB_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2011
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2017
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -25,14 +25,34 @@
#include "libguile/__scm.h"
+#include "libguile/weak-list.h"
+
#define SCM_HASHTABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_hashtable))
+
+/* Types of weak hash tables. */
+typedef enum {
+ SCM_WEAK_TABLE_KIND_KEY = 1,
+ SCM_WEAK_TABLE_KIND_VALUE = 2,
+ SCM_WEAK_TABLE_KIND_BOTH = 1 | 2
+} scm_t_weak_table_kind;
+
#define SCM_VALIDATE_HASHTABLE(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table")
#define SCM_HASHTABLE_VECTOR(h) SCM_CELL_OBJECT_1 (h)
#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_CELL_OBJECT_1 ((x), (v))
#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_CELL_WORD_2 (x))
+#define SCM_HASHTABLE_FLAGS(x) (SCM_HASHTABLE (x)->flags)
+#define SCM_HASHTABLE_WEAK_KEY_P(x) \
+ (SCM_HASHTABLE_FLAGS (x) & SCM_WEAK_TABLE_KIND_KEY)
+#define SCM_HASHTABLE_WEAK_VALUE_P(x) \
+ (SCM_HASHTABLE_FLAGS (x) & SCM_WEAK_TABLE_KIND_VALUE)
+#define SCM_HASHTABLE_DOUBLY_WEAK_P(x) \
+ ((SCM_HASHTABLE_FLAGS (x) \
+ & (SCM_WEAK_TABLE_KIND_KEY | SCM_WEAK_TABLE_KIND_VALUE)) \
+ == (SCM_WEAK_TABLE_KIND_KEY | SCM_WEAK_TABLE_KIND_VALUE))
+#define SCM_HASHTABLE_WEAK_P(x) SCM_HASHTABLE_FLAGS (x)
#define SCM_HASHTABLE_N_ITEMS(x) (SCM_HASHTABLE (x)->n_items)
#define SCM_SET_HASHTABLE_N_ITEMS(x, n) (SCM_HASHTABLE (x)->n_items = n)
#define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++)
@@ -55,6 +75,10 @@ typedef unsigned long (*scm_t_hash_fn) (SCM obj, unsigned
long max,
some equality predicate. */
typedef SCM (*scm_t_assoc_fn) (SCM obj, SCM alist, void *closure);
+/* Function that returns true if the given object is the one we are
+ looking for, for scm_hash_fn_ref_by_hash. */
+typedef int (*scm_t_hash_predicate_fn) (SCM obj, void *closure);
+
/* Function to fold over the entries of a hash table. */
typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key, SCM value,
SCM result);
@@ -64,6 +88,7 @@ typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key,
SCM value,
typedef SCM (*scm_t_hash_handle_fn) (void *closure, SCM handle);
typedef struct scm_t_hashtable {
+ int flags; /* properties of table */
unsigned long n_items; /* number of items in table */
unsigned long lower; /* when to shrink */
unsigned long upper; /* when to grow */
@@ -77,8 +102,14 @@ typedef struct scm_t_hashtable {
SCM_API SCM scm_vector_to_hash_table (SCM vector);
SCM_API SCM scm_c_make_hash_table (unsigned long k);
SCM_API SCM scm_make_hash_table (SCM n);
+SCM_API SCM scm_make_weak_key_hash_table (SCM k);
+SCM_API SCM scm_make_weak_value_hash_table (SCM k);
+SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);
SCM_API SCM scm_hash_table_p (SCM h);
+SCM_API SCM scm_weak_key_hash_table_p (SCM h);
+SCM_API SCM scm_weak_value_hash_table_p (SCM h);
+SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
SCM_INTERNAL void scm_i_rehash (SCM table, scm_t_hash_fn hash_fn,
void *closure, const char *func_name);
@@ -88,6 +119,10 @@ SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj,
scm_t_hash_fn hash_fn,
scm_t_assoc_fn assoc_fn,
void *closure);
+SCM_INTERNAL
+SCM scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash,
+ scm_t_hash_predicate_fn predicate_fn,
+ void *closure);
SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
scm_t_hash_fn hash_fn,
scm_t_assoc_fn assoc_fn,
@@ -138,6 +173,17 @@ SCM_API SCM scm_hash_count (SCM hash, SCM pred);
SCM_INTERNAL void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state
*pstate);
SCM_INTERNAL void scm_init_hashtab (void);
+
+/* Guile 2.2.x (x <= 2) weak-table API. */
+
+SCM_INTERNAL SCM scm_c_make_weak_table (unsigned long k,
+ scm_t_weak_table_kind kind);
+SCM_INTERNAL SCM scm_c_weak_table_fold (scm_t_hash_fold_fn proc, void *closure,
+ SCM init, SCM table);
+SCM_INTERNAL SCM scm_weak_table_refq (SCM table, SCM key, SCM dflt);
+SCM_INTERNAL void scm_weak_table_putq_x (SCM table, SCM key, SCM value);
+
+
#endif /* SCM_HASHTAB_H */
/*
diff --git a/libguile/init.c b/libguile/init.c
index b046685d4..64d3f8d63 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995-2004, 2006, 2009-2014 Free Software Foundation, Inc.
+/* Copyright (C) 1995-2004, 2006, 2009-2014, 2017 Free Software Foundation,
Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -387,7 +387,6 @@ scm_i_init_guile (void *base)
scm_storage_prehistory ();
scm_threads_prehistory (base); /* requires storage_prehistory */
- scm_weak_table_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
#endif
@@ -495,7 +494,6 @@ scm_i_init_guile (void *base)
scm_init_trees ();
scm_init_version ();
scm_init_weak_set ();
- scm_init_weak_table ();
scm_init_weak_vectors ();
scm_init_guardians (); /* requires smob_prehistory */
scm_init_vports ();
diff --git a/libguile/print.c b/libguile/print.c
index 7667d24bb..2ed721919 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
- * 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2017 Free Software Foundation,
Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -701,9 +701,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_weak_set:
scm_i_weak_set_print (exp, port, pstate);
break;
- case scm_tc7_weak_table:
- scm_i_weak_table_print (exp, port, pstate);
- break;
case scm_tc7_fluid:
scm_i_fluid_print (exp, port, pstate);
break;
diff --git a/libguile/procprop.c b/libguile/procprop.c
index ad56bd5ba..c906c93f8 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010,
2011, 2012, 2013, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -30,7 +30,7 @@
#include "libguile/gsubr.h"
#include "libguile/smob.h"
#include "libguile/vectors.h"
-#include "libguile/weak-table.h"
+#include "libguile/hashtab.h"
#include "libguile/programs.h"
#include "libguile/vm-builtins.h"
diff --git a/libguile/tags.h b/libguile/tags.h
index 3a01a1587..9aa4d00d0 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015,2017
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -423,7 +423,6 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#define scm_tc7_bytevector 0x4d
#define scm_tc7_unused_4f 0x4f
#define scm_tc7_weak_set 0x55
-#define scm_tc7_weak_table 0x57
#define scm_tc7_array 0x5d
#define scm_tc7_bitvector 0x5f
#define scm_tc7_unused_65 0x65
diff --git a/libguile/weak-list.h b/libguile/weak-list.h
index 989cb7f0a..e8e5a3555 100644
--- a/libguile/weak-list.h
+++ b/libguile/weak-list.h
@@ -3,7 +3,7 @@
#ifndef SCM_WEAK_LIST_H
#define SCM_WEAK_LIST_H
-/* Copyright (C) 2016 Free Software Foundation, Inc.
+/* Copyright (C) 2016, 2017 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -24,6 +24,7 @@
#include "libguile/__scm.h"
+#include "libguile/pairs.h"
#include "libguile/weak-vector.h"
@@ -64,6 +65,35 @@ scm_i_visit_weak_list (SCM *list_loc, void (*visit) (SCM))
}
+
+/* Weak pairs. */
+
+SCM_INTERNAL SCM scm_weak_car_pair (SCM car, SCM cdr);
+SCM_INTERNAL SCM scm_weak_cdr_pair (SCM car, SCM cdr);
+SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr);
+
+/* Testing the weak component(s) of a cell for reachability. */
+#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \
+ (SCM_UNPACK (SCM_CELL_OBJECT ((_cell), (_word))) == 0)
+#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \
+ (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0))
+#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \
+ (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 1))
+
+#define SCM_WEAK_PAIR_DELETED_P(_cell) \
+ ((SCM_WEAK_PAIR_CAR_DELETED_P (_cell)) \
+ || (SCM_WEAK_PAIR_CDR_DELETED_P (_cell)))
+
+/* Accessing the components of a weak cell. These return `SCM_UNDEFINED' if
+ the car/cdr has been collected. */
+#define SCM_WEAK_PAIR_WORD(_cell, _word) \
+ (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word)) \
+ ? SCM_UNDEFINED \
+ : SCM_CELL_OBJECT ((_cell), (_word)))
+#define SCM_WEAK_PAIR_CAR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 0))
+#define SCM_WEAK_PAIR_CDR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 1))
+
+
#endif /* SCM_WEAK_LIST_H */
/*
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 49aea27ba..14bf5a9b2 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -260,7 +260,7 @@ the matching bits, possibly with bitwise operations to
extract it from BITS."
(define %tc7-vm-continuation #x47)
(define %tc7-bytevector #x4d)
(define %tc7-weak-set #x55)
-(define %tc7-weak-table #x57)
+(define %tc7-weak-table #x57) ;no longer used
(define %tc7-array #x5d)
(define %tc7-bitvector #x5f)
(define %tc7-port #x7d)
diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test
index 446aff541..336350f9a 100644
--- a/test-suite/tests/types.test
+++ b/test-suite/tests/types.test
@@ -1,6 +1,6 @@
;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8;
-*-
;;;;
-;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
;;;;
;;;; This file is part of GNU Guile.
;;;;
@@ -103,9 +103,10 @@
((lambda () #t) program _)
((make-variable 'foo) variable _)
((make-weak-vector 3 #t) weak-vector _)
- ((make-weak-key-hash-table) weak-table _)
- ((make-weak-value-hash-table) weak-table _)
- ((make-doubly-weak-hash-table) weak-table _)
+ ((make-hash-table) hash-table _)
+ ((make-weak-key-hash-table) hash-table _)
+ ((make-weak-value-hash-table) hash-table _)
+ ((make-doubly-weak-hash-table) hash-table _)
(#2((1 2 3) (4 5 6)) array _)
(#*00000110 bitvector _)
((expt 2 70) bignum _)
--
2.14.2
- Re: Weak tables harmful to GC?, Christopher Allan Webber, 2017/10/09
- Re: Weak tables harmful to GC?, Ricardo Wurmus, 2017/10/25
- Re: Weak tables harmful to GC?, Ricardo Wurmus, 2017/10/25
- Re: Weak tables harmful to GC?, Ludovic Courtès, 2017/10/26
- Re: Weak tables harmful to GC?, Ricardo Wurmus, 2017/10/26
- Re: Weak tables harmful to GC?, Ricardo Wurmus, 2017/10/26
- Re: Weak tables harmful to GC?, Ludovic Courtès, 2017/10/27