diff options
author | Andy Wingo <wingo@pobox.com> | 2025-05-05 10:13:11 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2025-05-05 11:04:44 +0200 |
commit | c1caabaa2427dd63e8399341a6257077403f717f (patch) | |
tree | a76b0af1b062a4410f863863a77ccf95b7de9203 | |
parent | e6f550697fe453694b5ebb0673a13a1bdbfe7788 (diff) | |
download | guile-c1caabaa2427dd63e8399341a6257077403f717f.tar.gz |
Add ephemeron objects
* module/ice-9/ephemerons.scm:
* libguile/ephemerons.c:
* libguile/ephemerons.h:
* test-suite/tests/ephemerons.test: New files.
* am/bootstrap.am (SOURCES):
* test-suite/Makefile.am (SCM_TESTS):
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
(DOT_X_FILES, DOT_DOC_FILES, noinst_HEADERS): Wire ephemerons into build.
* libguile/scm.h (scm_tc7_ephemeron): New tc7.
* module/oop/goops.scm (<ephemeron>):
* module/system/base/types/internal.scm (heap-tags):
* module/system/vm/assembler.scm (system):
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (scm_class_of):
* libguile/init.c (scm_i_init_guile):
* libguile/print.c (iprin1): Add cases for new tc7.
-rw-r--r-- | am/bootstrap.am | 1 | ||||
-rw-r--r-- | libguile/Makefile.am | 4 | ||||
-rw-r--r-- | libguile/ephemerons.c | 158 | ||||
-rw-r--r-- | libguile/ephemerons.h | 32 | ||||
-rw-r--r-- | libguile/evalext.c | 1 | ||||
-rw-r--r-- | libguile/goops.c | 3 | ||||
-rw-r--r-- | libguile/init.c | 2 | ||||
-rw-r--r-- | libguile/print.c | 4 | ||||
-rw-r--r-- | libguile/scm.h | 2 | ||||
-rw-r--r-- | module/ice-9/ephemerons.scm | 32 | ||||
-rw-r--r-- | module/oop/goops.scm | 3 | ||||
-rw-r--r-- | module/system/base/types/internal.scm | 2 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 1 | ||||
-rw-r--r-- | test-suite/Makefile.am | 3 | ||||
-rw-r--r-- | test-suite/tests/ephemerons.test | 51 |
15 files changed, 295 insertions, 4 deletions
diff --git a/am/bootstrap.am b/am/bootstrap.am index 66d91a165..d367a17e9 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -138,6 +138,7 @@ SOURCES = \ ice-9/custom-ports.scm \ ice-9/deprecated.scm \ ice-9/documentation.scm \ + ice-9/ephemerons.scm \ ice-9/eval-string.scm \ ice-9/exceptions.scm \ ice-9/expect.scm \ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 03e204941..5ea566da2 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -151,6 +151,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ deprecation.c \ dynstack.c \ dynwind.c \ + ephemerons.c \ eq.c \ error.c \ eval.c \ @@ -270,6 +271,7 @@ DOT_X_FILES = \ deprecation.x \ dynl.x \ dynwind.x \ + ephemerons.x \ eq.x \ error.x \ eval.x \ @@ -376,6 +378,7 @@ DOT_DOC_FILES = \ deprecation.doc \ dynl.doc \ dynwind.doc \ + ephemerons.doc \ eq.doc \ error.doc \ eval.doc \ @@ -531,6 +534,7 @@ uninstall-hook: ## working. noinst_HEADERS = custom-ports.h \ elf.h \ + ephemerons.h \ integers.h \ intrinsics.h \ quicksort.i.c \ diff --git a/libguile/ephemerons.c b/libguile/ephemerons.c new file mode 100644 index 000000000..1eb179bc7 --- /dev/null +++ b/libguile/ephemerons.c @@ -0,0 +1,158 @@ +/* Copyright 2025 Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <assert.h> +#include <errno.h> +#include <fcntl.h> +#include <full-write.h> +#include <stdio.h> +#include <unistd.h> + +#include "extensions.h" +#include "gc-internal.h" +#include "gsubr.h" +#include "ports.h" +#include "threads.h" +#include "version.h" + +#include <gc-ephemeron.h> + +#include "ephemerons.h" + + + + +#define SCM_EPHEMERON_P(X) (SCM_HAS_TYP7 (X, scm_tc7_ephemeron)) + +#define SCM_VALIDATE_EPHEMERON(pos, x) \ + SCM_MAKE_VALIDATE_MSG (pos, x, EPHEMERON_P, "ephemeron") + +static inline SCM ref_to_scm (struct gc_ref ref) +{ + return SCM_PACK (gc_ref_value (ref)); +} +static inline struct gc_ref scm_to_ref (SCM scm) +{ + return gc_ref (SCM_UNPACK (scm)); +} + +SCM_DEFINE_STATIC (scm_ephemeron_p, "ephemeron?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an ephemeron, or " + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_ephemeron_p +{ + return scm_from_bool (SCM_EPHEMERON_P (x)); +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_make_ephemeron, "make-ephemeron", 2, 0, 0, + (SCM key, SCM val), + "Make an ephemeron that will reference @var{val} as long " + "as @var{key} and the ephemeron itself are alive.") +#define FUNC_NAME s_scm_make_ephemeron +{ + SCM_MAKE_VALIDATE (1, key, HEAP_OBJECT_P); + + struct scm_thread *thread = SCM_I_CURRENT_THREAD; + struct gc_ephemeron *ephemeron = gc_allocate_ephemeron (thread->mutator); + SCM ret = SCM_PACK_POINTER (ephemeron); + SCM_SET_CELL_WORD_0 (ret, scm_tc7_ephemeron); + gc_ephemeron_init (thread->mutator, ephemeron, scm_to_ref (key), + scm_to_ref (val)); + return ret; +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_ephemeron_key, "ephemeron-key", 1, 0, 0, + (SCM ephemeron), + "Return the key for an ephemeron, or @code{#f} if the " + "ephemeron is dead.") +#define FUNC_NAME s_scm_ephemeron_key +{ + SCM_VALIDATE_EPHEMERON (1, ephemeron); + + struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron); + struct gc_ref ret = gc_ephemeron_key (e); + return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret); +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_ephemeron_value, "ephemeron-value", 1, 0, 0, + (SCM ephemeron), + "Return the value for an ephemeron, or @code{#f} if the " + "ephemeron is dead.") +#define FUNC_NAME s_scm_ephemeron_value +{ + SCM_VALIDATE_EPHEMERON (1, ephemeron); + + struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron); + struct gc_ref ret = gc_ephemeron_value (e); + return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret); +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_ephemeron_mark_dead_x, "ephemeron-mark-dead!", 1, 0, 0, + (SCM ephemeron), + "Remove the key-value association for this ephemeron.") +#define FUNC_NAME s_scm_ephemeron_mark_dead_x +{ + SCM_VALIDATE_EPHEMERON (1, ephemeron); + + struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron); + gc_ephemeron_mark_dead (e); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +int +scm_i_print_ephemeron (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + scm_puts ("#<ephemeron ", port); + scm_uintprint (SCM_UNPACK (exp), 16, port); + scm_puts (")>", port); + return 1; +} + + + + +static void +scm_init_ephemerons (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "ephemerons.x" +#endif +} + +void +scm_register_ephemerons (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ephemerons", + (scm_t_extension_init_func)scm_init_ephemerons, + NULL); +} diff --git a/libguile/ephemerons.h b/libguile/ephemerons.h new file mode 100644 index 000000000..4829ffd2e --- /dev/null +++ b/libguile/ephemerons.h @@ -0,0 +1,32 @@ +#ifndef SCM_EPHEMERONS_H +#define SCM_EPHEMERONS_H + +/* Copyright 2025 Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + +#include "libguile/scm.h" + + + +SCM_INTERNAL int scm_i_print_ephemeron (SCM exp, SCM port, + scm_print_state *pstate SCM_UNUSED); +SCM_INTERNAL void scm_register_ephemerons (void); + +#endif /* SCM_EPHEMERONS_H */ diff --git a/libguile/evalext.c b/libguile/evalext.c index f2486d7da..3d92cf10d 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -96,6 +96,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_array: case scm_tc7_bitvector: case scm_tc7_finalizer: + case scm_tc7_ephemeron: case scm_tc7_thread: case scm_tcs_struct: return SCM_BOOL_T; diff --git a/libguile/goops.c b/libguile/goops.c index 1ce1a490b..d5770bc99 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -135,6 +135,7 @@ static SCM class_array; static SCM class_thread; static SCM class_bitvector; static SCM class_finalizer; +static SCM class_ephemeron; static SCM vtable_class_map = SCM_BOOL_F; @@ -260,6 +261,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_bitvector; case scm_tc7_finalizer: return class_finalizer; + case scm_tc7_ephemeron: + return class_ephemeron; case scm_tc7_thread: return class_thread; case scm_tc7_string: diff --git a/libguile/init.c b/libguile/init.c index 592024d01..049e18f9a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -58,6 +58,7 @@ #include "deprecation.h" #include "dynl.h" #include "dynwind.h" +#include "ephemerons.h" #include "eq.h" #include "error.h" #include "eval.h" @@ -368,6 +369,7 @@ scm_i_init_guile (struct gc_stack_addr base) scm_bootstrap_vm (); scm_register_atomic (); scm_register_custom_ports (); + scm_register_ephemerons (); scm_register_fdes_finalizers (); scm_register_finalizers (); scm_register_foreign (); diff --git a/libguile/print.c b/libguile/print.c index 44204b2d3..937454158 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -38,6 +38,7 @@ #include "chars.h" #include "continuations.h" #include "control.h" +#include "ephemerons.h" #include "eval.h" #include "finalizers.h" #include "fluids.h" @@ -764,6 +765,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_finalizer: scm_i_print_finalizer (exp, port, pstate); break; + case scm_tc7_ephemeron: + scm_i_print_ephemeron (exp, port, pstate); + break; case scm_tc7_thread: scm_i_print_thread (exp, port, pstate); break; diff --git a/libguile/scm.h b/libguile/scm.h index b215993e8..75f02e7ce 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -499,7 +499,7 @@ typedef uintptr_t scm_t_bits; #define scm_tc7_array 0x5d #define scm_tc7_bitvector 0x5f #define scm_tc7_finalizer 0x65 -#define scm_tc7_unused_67 0x67 +#define scm_tc7_ephemeron 0x67 #define scm_tc7_unused_6d 0x6d #define scm_tc7_unused_6f 0x6f #define scm_tc7_unused_75 0x75 diff --git a/module/ice-9/ephemerons.scm b/module/ice-9/ephemerons.scm new file mode 100644 index 000000000..a48b4127f --- /dev/null +++ b/module/ice-9/ephemerons.scm @@ -0,0 +1,32 @@ +;;; Copyright (C) 2025 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 as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; +;;; Code: + + +(define-module (ice-9 ephemerons) + #:export (ephemeron? + make-ephemeron + ephemeron-key + ephemeron-value + ephemeron-mark-dead!)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_ephemerons")) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index caa4bc3fe..34888f7b5 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -70,7 +70,7 @@ <vector> <bytevector> <uvec> <foreign> <hashtable> <fluid> <dynamic-state> <frame> <vm> <vm-continuation> <keyword> <syntax> <atomic-box> <thread> <bitvector> - <finalizer> + <finalizer> <ephemeron> ;; Numbers. <number> <complex> <real> <integer> <fraction> @@ -1080,6 +1080,7 @@ slots as we go." (define-standard-class <array> (<top>)) (define-standard-class <bitvector> (<top>)) (define-standard-class <finalizer> (<top>)) +(define-standard-class <ephemeron> (<top>)) (define-standard-class <thread> (<top>)) (define-standard-class <number> (<top>)) (define-standard-class <complex> (<number>)) diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm index 24e8e14c9..6b774a48c 100644 --- a/module/system/base/types/internal.scm +++ b/module/system/base/types/internal.scm @@ -154,7 +154,7 @@ (array array? #b1111111 #b1011101) (bitvector bitvector? #b1111111 #b1011111) (finalizer finalizer? #b1111111 #b1100101) - ;;(unused unused #b1111111 #b1100111) + (ephemeron ephemeron? #b1111111 #b1100111) ;;(unused unused #b1111111 #b1101101) ;;(unused unused #b1111111 #b1101111) ;;(unused unused #b1111111 #b1110101) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 6bfb703f2..a1d748df7 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -137,6 +137,7 @@ emit-weak-table? emit-array? emit-bitvector? + emit-ephemeron? emit-finalizer? emit-port? emit-smob? diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 6014b1f1f..7e5fd0eac 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright 2001-2020, 2023, 2024 Software Foundation, Inc. +## Copyright 2001-2020, 2023, 2024, 2025 Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -51,6 +51,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/encoding-iso88591.test \ tests/encoding-iso88597.test \ tests/encoding-utf8.test \ + tests/ephemerons.test \ tests/error-handling.test \ tests/eval.test \ tests/eval-string.test \ diff --git a/test-suite/tests/ephemerons.test b/test-suite/tests/ephemerons.test new file mode 100644 index 000000000..af8108a59 --- /dev/null +++ b/test-suite/tests/ephemerons.test @@ -0,0 +1,51 @@ +;;; -*- scheme -*- +;;; Copyright (C) 2025 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 as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (test-ephemerons) + #:use-module (test-suite lib) + #:use-module (ice-9 ephemerons)) + + +(with-test-prefix "ephemerons" + + (pass-if (not (ephemeron? 42))) + (pass-if (not (ephemeron? (cons 42 42)))) + (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))) + + (let ((x (cons 42 69))) + (define e (make-ephemeron x 100)) + (gc) + (gc) + (gc) + (pass-if (ephemeron? e)) + (pass-if (eq? x (ephemeron-key e))) + (pass-if-equal 100 (ephemeron-value e)) + + (ephemeron-mark-dead! e) + (pass-if (ephemeron? e)) + (pass-if-equal #f (ephemeron-key e)) + (pass-if-equal #f (ephemeron-value e)))) |