wingo pushed a commit to branch wip-whippet
in repository guile.
commit c1caabaa2427dd63e8399341a6257077403f717f
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon May 5 10:13:11 2025 +0200
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.
---
am/bootstrap.am | 1 +
libguile/Makefile.am | 4 +
libguile/ephemerons.c | 158 ++++++++++++++++++++++++++++++++++
libguile/ephemerons.h | 32 +++++++
libguile/evalext.c | 1 +
libguile/goops.c | 3 +
libguile/init.c | 2 +
libguile/print.c | 4 +
libguile/scm.h | 2 +-
module/ice-9/ephemerons.scm | 32 +++++++
module/oop/goops.scm | 3 +-
module/system/base/types/internal.scm | 2 +-
module/system/vm/assembler.scm | 1 +
test-suite/Makefile.am | 3 +-
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))))
