wingo pushed a commit to branch wip-whippet
in repository guile.
commit d457aaa57db79c299118e3b1094188b012d9f6f1
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue May 13 14:55:38 2025 +0200
Add ephemeron-table-clear!; ephemeron key can be immediate
* libguile/ephemerons.c (scm_make_ephemeron): Relax restriction that key
be a heap object. It's too annoying otherwise.
(scm_c_ephemeron_table_clear_x):
(scm_ephemeron_table_clear_x): New interface.
* module/ice-9/ephemerons.scm: Expose ephemeron-table-clear!.
* test-suite/tests/ephemerons.test ("ephemerons"): Update tests.
---
libguile/atomics-internal.h | 16 ++++++++++++++++
libguile/ephemerons.c | 28 +++++++++++++++++++++++++++-
module/ice-9/ephemerons.scm | 3 ++-
test-suite/tests/ephemerons.test | 12 ++++--------
4 files changed, 49 insertions(+), 10 deletions(-)
diff --git a/libguile/atomics-internal.h b/libguile/atomics-internal.h
index 048484576..dd1e71f10 100644
--- a/libguile/atomics-internal.h
+++ b/libguile/atomics-internal.h
@@ -57,6 +57,12 @@ scm_atomic_ref_pointer (void **loc)
atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc;
return (void *) atomic_load (a_loc);
}
+static inline void *
+scm_atomic_swap_pointer (void **loc, void *new_val)
+{
+ atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc;
+ return (void *) atomic_exchange (a_loc, (uintptr_t) new_val);
+}
static inline void
scm_atomic_set_bits (scm_t_bits *loc, scm_t_bits val)
{
@@ -141,6 +147,16 @@ scm_atomic_ref_pointer (void **loc)
scm_i_pthread_mutex_unlock (&atomics_lock);
return ret;
}
+static inline void *
+scm_atomic_swap_pointer (void **loc, void *new_val)
+{
+ void *ret;
+ scm_i_pthread_mutex_lock (&atomics_lock);
+ ret = *loc;
+ *loc = new_val;
+ scm_i_pthread_mutex_unlock (&atomics_lock);
+ return ret;
+}
static inline void
scm_atomic_set_bits (scm_t_bits *loc, scm_t_bits val)
diff --git a/libguile/ephemerons.c b/libguile/ephemerons.c
index 7a2f75076..9995d8e79 100644
--- a/libguile/ephemerons.c
+++ b/libguile/ephemerons.c
@@ -30,6 +30,7 @@
#include <stdio.h>
#include <unistd.h>
+#include "atomics-internal.h"
#include "extensions.h"
#include "gc-internal.h"
#include "gsubr.h"
@@ -147,7 +148,6 @@ SCM_DEFINE_STATIC (scm_make_ephemeron, "make-ephemeron", 2,
0, 0,
"as @var{key} and the ephemeron itself are alive.")
#define FUNC_NAME s_scm_make_ephemeron
{
- SCM_MAKE_VALIDATE (1, key, HEAP_OBJECT_P);
return PTR2SCM (scm_c_make_ephemeron (key, val));
}
#undef FUNC_NAME
@@ -299,6 +299,15 @@ scm_c_ephemeron_table_try_push_x (struct
scm_ephemeron_table *et, size_t idx,
return prev;
}
+static struct gc_ephemeron*
+scm_c_ephemeron_table_clear_x (struct scm_ephemeron_table *et, size_t idx)
+{
+ if (idx >= et->size)
+ abort();
+
+ return scm_atomic_swap_pointer ((void**) &et->contents[idx], NULL);
+}
+
struct scm_ephemeron_table*
scm_c_ephemeron_table_copy (struct scm_ephemeron_table *et)
{
@@ -408,6 +417,23 @@ SCM_DEFINE_STATIC (scm_ephemeron_table_try_push_x,
"ephemeron-table-try-push!",
}
#undef FUNC_NAME
+SCM_DEFINE_STATIC (scm_ephemeron_table_clear_x, "ephemeron-table-clear!",
+ 2, 0, 0, (SCM et, SCM idx),
+ "Clear the slot @var{idx} of the ephemeron table @var{et} "
+ "and return its previous value.")
+#define FUNC_NAME s_scm_ephemeron_table_clear_x
+{
+ SCM_VALIDATE_EPHEMERON_TABLE (1, et);
+ SCM_ASSERT_RANGE (2, idx,
+ scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size);
+
+ struct gc_ephemeron *prev =
+ scm_c_ephemeron_table_clear_x (scm_as_ephemeron_table (et),
+ scm_to_size_t (idx));
+ return prev ? PTR2SCM (prev) : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
int
scm_i_print_ephemeron_table (SCM exp, SCM port, scm_print_state *pstate
SCM_UNUSED)
{
diff --git a/module/ice-9/ephemerons.scm b/module/ice-9/ephemerons.scm
index a15062f9a..c80af6a0e 100644
--- a/module/ice-9/ephemerons.scm
+++ b/module/ice-9/ephemerons.scm
@@ -35,7 +35,8 @@
ephemeron-table-ref
ephemeron-table-push!
- ephemeron-table-try-push!))
+ ephemeron-table-try-push!
+ ephemeron-table-clear!))
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
diff --git a/test-suite/tests/ephemerons.test b/test-suite/tests/ephemerons.test
index fa08c2448..f37c0ff3b 100644
--- a/test-suite/tests/ephemerons.test
+++ b/test-suite/tests/ephemerons.test
@@ -27,14 +27,10 @@
(pass-if (ephemeron? (make-ephemeron (cons 42 42) 42)))
(with-test-prefix "ephemeron key not heap object"
- (pass-if-exception "fixnum" exception:wrong-type-arg
- (make-ephemeron 42 42))
- (pass-if-exception "char" exception:wrong-type-arg
- (make-ephemeron #\a 42))
- (pass-if-exception "bool" exception:wrong-type-arg
- (make-ephemeron #f 42))
- (pass-if-exception "bool" exception:wrong-type-arg
- (make-ephemeron #t 42)))
+ (pass-if "fixnum" (ephemeron? (make-ephemeron 42 42)))
+ (pass-if "char" (ephemeron? (make-ephemeron #\a 42)))
+ (pass-if "bool" (ephemeron? (make-ephemeron #f 42)))
+ (pass-if "bool" (ephemeron? (make-ephemeron #t 42))))
(let ((x (cons 42 69)))
(define e (make-ephemeron x 100))
