diff options
author | Andy Wingo <wingo@pobox.com> | 2025-05-13 14:55:38 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2025-05-13 14:55:38 +0200 |
commit | d457aaa57db79c299118e3b1094188b012d9f6f1 (patch) | |
tree | dc27dcb50fae1c31f4467cbbf76a6b68a8fa19fb | |
parent | c35cbd65f1544d5f5fde2c9b1e5fab2b676161e7 (diff) | |
download | guile-d457aaa57db79c299118e3b1094188b012d9f6f1.tar.gz |
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.
-rw-r--r-- | libguile/atomics-internal.h | 16 | ||||
-rw-r--r-- | libguile/ephemerons.c | 28 | ||||
-rw-r--r-- | module/ice-9/ephemerons.scm | 3 | ||||
-rw-r--r-- | 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)) |