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

@@ -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				\

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                                  \

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);
+}

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 */

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;

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:

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 ();

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;

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

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"))

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>))

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)

module/system/vm/assembler.scm

@@ -137,6 +137,7 @@
             emit-weak-table?
             emit-array?
             emit-bitvector?
+            emit-ephemeron?
             emit-finalizer?
             emit-port?
             emit-smob?

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		\

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))))