wingo pushed a commit to branch wip-whippet
in repository guile.
commit 27f0490801c77d3bd97aee9e9edd33d58176e08f
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue Apr 22 10:21:20 2025 +0200
Use Whippet API to boot threads
* libguile/scm.h (scm_tc7_thread): Give threads their own tc7.
* libguile/threads.h (struct scm_thread): Add a tag, so that struct
thread can be a SCM directly. Add a struct gc_mutator* member.
(scm_thread_handle): New inline function.
(SCM_I_IS_THREAD, SCM_I_THREAD_DATA, SCM_VALIDATE_THREAD): Update to use
tc7 instead of SMOB tags.
* libguile/continuations.c (scm_i_with_continuation_barrier)
* libguile/finalizers.c (queue_finalizer_async)
* libguile/jit.c (compile_current_thread)
* libguile/threads.c (block_self, guilify_self_2)
(lock_mutex, unlock_mutex, timed_wait scm_current_thread)
(scm_all_threads)
* libguile/vm-engine.c (current-thread): Use scm_thread_handle instead
of thread->handle.
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (class_thread, scm_class_of, scm_sys_goops_early_init)
* libguile/print.c (iprin1)
* module/language/cps/compile-bytecode.scm (compile-function)
* module/oop/goops.scm (<thread>)
* module/system/base/types.scm (cell->object)
* module/system/base/types/internal.scm (heap-tags)
* module/system/vm/assembler.scm: (emit-thread?): Adapt to
scm_tc7_thread.
* libguile/gc-internal.h: Move init functions that take "struct
gc_stack_addr" here, so that internal Whippet uses don't cause Whippet
to be added to public headers.
* libguile/gc.c (scm_storage_prehistory): Take struct gc_stack_addr as
arg, and pass to gc_init. Return a mutator pointer.
* libguile/init.c (scm_i_init_guile): Pass mutator and stack base to GC
and thread init routines.
* libguile/threads.c (scm_trace_dynstack, scm_trace_thread)
(scm_trace_thread_mutator_roots): New infra for marking threads in terms
of Whippet API.
* libguile/threads.c (guilify_self_1): Since we don't use a separate GC
kind for threads any more, and thread marking is keyed off
gc_mutator_set_roots, we can avoid some of the gnarly synchronization.
(on_thread_exit): Arrange to gc_finish_for_thread.
(scm_i_init_thread_for_guile): Use gc_init_for_thread.
(init_main_thread, with_guile, scm_i_with_guile): Use Whippet API.
(scm_threads_prehistory): Take main-thread mutator and the stack base as
arguments.
* libguile/vm.c (scm_trace_vm): Rework in terms of Whippet API.
* libguile/whippet-embedder.h (gc_trace_mutator_roots): Arrange to trace
the current mutator's SCM thread object.
* libguile/trace.h: New file, to declare implementations of trace
routines.
* libguile/Makefile.am (noinst_HEADERS): Add trace.h.
---
libguile/Makefile.am | 1 +
libguile/continuations.c | 5 +-
libguile/evalext.c | 3 +-
libguile/finalizers.c | 2 +-
libguile/gc-internal.h | 8 +
libguile/gc.c | 10 +-
libguile/gc.h | 3 +-
libguile/goops.c | 6 +-
libguile/init.c | 9 +-
libguile/init.h | 4 +-
libguile/jit.c | 7 +-
libguile/print.c | 5 +-
libguile/scm.h | 2 +-
libguile/threads.c | 293 +++++++++++++++----------------
libguile/threads.h | 25 ++-
libguile/trace.h | 56 ++++++
libguile/vm-engine.c | 4 +-
libguile/vm.c | 29 ++-
libguile/vm.h | 6 +-
libguile/whippet-embedder.h | 17 +-
module/language/cps/compile-bytecode.scm | 3 +-
module/oop/goops.scm | 8 +-
module/system/base/types.scm | 4 +-
module/system/base/types/internal.scm | 5 +-
module/system/vm/assembler.scm | 3 +-
25 files changed, 300 insertions(+), 218 deletions(-)
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 285e4fb76..dbd91e7fe 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -544,6 +544,7 @@ noinst_HEADERS = custom-ports.h
\
private-options.h \
ports-internal.h \
syntax.h \
+ trace.h \
weak-list.h \
whippet-embedder.h
diff --git a/libguile/continuations.c b/libguile/continuations.c
index b8b6e1dca..cf7be4cb7 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-1996,1998,2000-2001,2004,2006,2008-2014,2017-2018
+/* Copyright 1995-1996,1998,2000-2001,2004,2006,2008-2014,2017-2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -359,7 +359,8 @@ scm_i_with_continuation_barrier (scm_t_catch_body body,
*/
old_controot = thread->continuation_root;
old_contbase = thread->continuation_base;
- thread->continuation_root = scm_cons (thread->handle, old_controot);
+ thread->continuation_root = scm_cons (scm_thread_handle (thread),
+ old_controot);
thread->continuation_base = &stack_item;
/* Call FUNC inside a catch all. This is now guaranteed to return
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 4ac434343..853b20333 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -1,4 +1,4 @@
-/* Copyright 1998-2003,2006,2008-2013,2015,2018
+/* Copyright 1998-2003,2006,2008-2013,2015,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -95,6 +95,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0,
0,
case scm_tc7_bytevector:
case scm_tc7_array:
case scm_tc7_bitvector:
+ case scm_tc7_thread:
case scm_tcs_struct:
return SCM_BOOL_T;
default:
diff --git a/libguile/finalizers.c b/libguile/finalizers.c
index f6e67d5d7..231e8c723 100644
--- a/libguile/finalizers.c
+++ b/libguile/finalizers.c
@@ -164,7 +164,7 @@ queue_finalizer_async (void)
GC_invoke_finalizers call there after the thread spins up. */
if (!t) return;
- scm_system_async_mark_for_thread (run_finalizers_subr, t->handle);
+ scm_system_async_mark_for_thread (run_finalizers_subr, scm_thread_handle
(t));
}
diff --git a/libguile/gc-internal.h b/libguile/gc-internal.h
index b7bbe641f..e100be3d4 100644
--- a/libguile/gc-internal.h
+++ b/libguile/gc-internal.h
@@ -21,8 +21,16 @@
+#include "libguile/scmconfig.h"
#include <gc-api.h>
+SCM_INTERNAL struct gc_heap* the_gc_heap;
+
+SCM_INTERNAL void scm_i_init_guile (struct gc_stack_addr base);
+SCM_INTERNAL struct gc_mutator* scm_storage_prehistory (struct gc_stack_addr);
+SCM_INTERNAL void scm_threads_prehistory (struct gc_mutator *,
+ struct gc_stack_addr);
+
#endif /* SCM_GC_INTERNAL_H */
diff --git a/libguile/gc.c b/libguile/gc.c
index ad0794a9d..ec9002e42 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -79,7 +79,7 @@ struct scm_gc_event_listener_mutator {
void *stats;
};
-static struct gc_heap *the_gc_heap;
+struct gc_heap *the_gc_heap;
static struct scm_gc_event_listener the_gc_event_listener;
@@ -638,8 +638,8 @@ scm_gc_unregister_roots (SCM *b, unsigned long n)
-void
-scm_storage_prehistory (void)
+struct gc_mutator *
+scm_storage_prehistory (struct gc_stack_addr base)
{
struct gc_options *options = gc_allocate_options ();
gc_options_set_int(options, GC_OPTION_HEAP_SIZE_POLICY,
GC_HEAP_SIZE_GROWABLE);
@@ -657,7 +657,7 @@ scm_storage_prehistory (void)
#endif
struct gc_mutator *mut;
- if (!gc_init (options, gc_empty_stack_addr (), &the_gc_heap, &mut,
+ if (!gc_init (options, base, &the_gc_heap, &mut,
SCM_GC_EVENT_LISTENER, &the_gc_event_listener))
{
fprintf (stderr, "Failed to initialize GC\n");
@@ -673,6 +673,8 @@ scm_storage_prehistory (void)
scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
+
+ return mut;
}
void
diff --git a/libguile/gc.h b/libguile/gc.h
index fcba9ef45..e9779a7a3 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -1,7 +1,7 @@
#ifndef SCM_GC_H
#define SCM_GC_H
-/* Copyright 1995-1996,1998-2004,2006-2014,2018
+/* Copyright 1995-1996,1998-2004,2006-2014,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -283,7 +283,6 @@ SCM_API void scm_gc_unregister_root (SCM *p);
SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
SCM_INTERNAL void scm_gc_after_nonlocal_exit (void);
-SCM_INTERNAL void scm_storage_prehistory (void);
SCM_INTERNAL void scm_init_gc_protect_object (void);
SCM_INTERNAL void scm_init_gc (void);
diff --git a/libguile/goops.c b/libguile/goops.c
index fd312a8f1..8d8b0a3fa 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,4 +1,4 @@
-/* Copyright 1998-2004,2008-2015,2017-2018
+/* Copyright 1998-2004,2008-2015,2017-2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -132,6 +132,7 @@ static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
static SCM class_array;
+static SCM class_thread;
static SCM class_bitvector;
static SCM vtable_class_map = SCM_BOOL_F;
@@ -256,6 +257,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_array;
case scm_tc7_bitvector:
return class_bitvector;
+ case scm_tc7_thread:
+ return class_thread;
case scm_tc7_string:
return class_string;
case scm_tc7_number:
@@ -935,6 +938,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init",
0, 0, 0,
class_bytevector = scm_variable_ref (scm_c_lookup ("<bytevector>"));
class_uvec = scm_variable_ref (scm_c_lookup ("<uvec>"));
class_array = scm_variable_ref (scm_c_lookup ("<array>"));
+ class_thread = scm_variable_ref (scm_c_lookup ("<thread>"));
class_bitvector = scm_variable_ref (scm_c_lookup ("<bitvector>"));
class_number = scm_variable_ref (scm_c_lookup ("<number>"));
class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
diff --git a/libguile/init.c b/libguile/init.c
index 3df8c5ae5..06280efec 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2004,2006,2009-2014,2016-2021,2023
+/* Copyright 1995-2004,2006,2009-2014,2016-2021,2023,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -78,6 +78,7 @@
#include "fports.h"
#include "frames.h"
#include "gc.h"
+#include "gc-internal.h"
#include "generalized-vectors.h"
#include "gettext.h"
#include "goops.h"
@@ -352,13 +353,13 @@ cleanup_for_exit ()
}
void
-scm_i_init_guile (void *base)
+scm_i_init_guile (struct gc_stack_addr base)
{
if (scm_initialized_p)
return;
- scm_storage_prehistory ();
- scm_threads_prehistory (base); /* requires storage_prehistory */
+ struct gc_mutator *mut = scm_storage_prehistory (base);
+ scm_threads_prehistory (mut, base); /* requires storage_prehistory */
scm_weak_table_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
diff --git a/libguile/init.h b/libguile/init.h
index 4d597ec24..6426d3599 100644
--- a/libguile/init.h
+++ b/libguile/init.h
@@ -1,7 +1,7 @@
#ifndef SCM_INIT_H
#define SCM_INIT_H
-/* Copyright 1995-1997,2000,2006,2008,2011,2018
+/* Copyright 1995-1997,2000,2006,2008,2011,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -36,8 +36,6 @@ SCM_API void scm_boot_guile (int argc, char **argv,
char **argv),
void *closure);
-SCM_INTERNAL void scm_i_init_guile (void *base);
-
SCM_API void scm_load_startup_files (void);
#endif /* SCM_INIT_H */
diff --git a/libguile/jit.c b/libguile/jit.c
index a20a8e7f7..cb96088b7 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -1,4 +1,4 @@
-/* Copyright 2018-2021, 2023-2024
+/* Copyright 2018-2021, 2023-2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -229,7 +229,6 @@ static const uint32_t frame_overhead_slots = 3;
static const uint32_t thread_offset_##f = \
offsetof (struct scm_thread, f)
-DEFINE_THREAD_OFFSET (handle);
DEFINE_THREAD_OFFSET (pending_asyncs);
DEFINE_THREAD_OFFSET (block_asyncs);
@@ -3500,8 +3499,8 @@ compile_load_s64_slow (scm_jit_state *j, uint32_t dst,
int64_t a)
static void
compile_current_thread (scm_jit_state *j, uint32_t dst)
{
- emit_ldxi (j, T0, THREAD, thread_offset_handle);
- emit_sp_set_scm (j, dst, T0);
+ /* Inline scm_thread_handle. */
+ emit_sp_set_scm (j, dst, THREAD);
}
static void
compile_current_thread_slow (scm_jit_state *j, uint32_t dst)
diff --git a/libguile/print.c b/libguile/print.c
index b10f0f8a8..58b88e908 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2004,2006,2008-2019
+/* Copyright 1995-2004,2006,2008-2019,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -760,6 +760,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_bitvector:
scm_i_print_bitvector (exp, port, pstate);
break;
+ case scm_tc7_thread:
+ scm_i_print_thread (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_puts ("#w(", port);
diff --git a/libguile/scm.h b/libguile/scm.h
index 4156d1612..4974b571c 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -493,7 +493,7 @@ typedef uintptr_t scm_t_bits;
#define scm_tc7_program 0x45
#define scm_tc7_vm_cont 0x47
#define scm_tc7_bytevector 0x4d
-#define scm_tc7_unused_4f 0x4f
+#define scm_tc7_thread 0x4f
#define scm_tc7_weak_set 0x55
#define scm_tc7_weak_table 0x57
#define scm_tc7_array 0x5d
diff --git a/libguile/threads.c b/libguile/threads.c
index 6b4510d53..0efd2c60a 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -49,7 +49,7 @@
#include "extensions.h"
#include "finalizers.h"
#include "fluids.h"
-#include "gc-inline.h"
+#include "gc-internal.h"
#include "gc.h"
#include "gsubr.h"
#include "hashtab.h"
@@ -64,9 +64,11 @@
#include "scmsigs.h"
#include "strings.h"
#include "symbols.h"
+#include "trace.h"
#include "variable.h"
#include "version.h"
#include "vm.h"
+#include "whippet-embedder.h"
#include "threads.h"
@@ -75,49 +77,72 @@
-/* The GC "kind" for threads that allow them to mark their VM
- stacks. */
-static int thread_gc_kind;
+static void
+scm_trace_dynstack (scm_t_dynstack *dynstack,
+ void (*trace_edge) (struct gc_edge edge,
+ struct gc_heap *heap,
+ void *trace_data),
+ struct gc_heap *heap, void *trace_data)
+{
+ /* FIXME: Untagged array. Perhaps this should be off-heap... or
+ interleaved on the main stack. */
+ trace_edge (gc_edge (&dynstack->base), heap, trace_data);
+}
-static struct GC_ms_entry *
-thread_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
- struct GC_ms_entry *mark_stack_limit, GC_word env)
+void
+scm_trace_thread (struct scm_thread *thread,
+ void (*trace_edge) (struct gc_edge edge,
+ struct gc_heap *heap,
+ void *trace_data),
+ struct gc_heap *heap, void *trace_data)
{
- int word;
- struct scm_thread *t = (struct scm_thread *) addr;
+ trace_edge (gc_edge (&thread->next_thread), heap, trace_data);
- if (SCM_UNPACK (t->handle) == 0)
- /* T must be on the free-list; ignore. (See warning in
- gc_mark.h.) */
- return mark_stack_ptr;
+ trace_edge (gc_edge (&thread->pending_asyncs), heap, trace_data);
- /* Mark T. We could be more precise, but it doesn't matter. */
- for (word = 0; word * sizeof (*addr) < sizeof (*t); word++)
- mark_stack_ptr = GC_MARK_AND_PUSH ((void *) addr[word],
- mark_stack_ptr, mark_stack_limit,
- NULL);
+ trace_edge (gc_edge (&thread->result), heap, trace_data);
- /* The pointerless freelists are threaded through their first word,
- but GC doesn't know to trace them (as they are pointerless), so we
- need to do that here. See the comments at the top of libgc's
- gc_inline.h. */
- for (size_t n = 0; n < SCM_INLINE_GC_FREELIST_COUNT; n++)
- {
- void *chain = t->pointerless_freelists[n];
- if (chain)
- {
- /* The first link is already marked by the thread itsel, so we
- just have to mark the tail. */
- while ((chain = *(void **)chain))
- mark_stack_ptr = GC_mark_and_push (chain, mark_stack_ptr,
- mark_stack_limit, NULL);
- }
- }
+ /* FIXME: This is not a tagged allocation. */
+ trace_edge (gc_edge (&thread->dynamic_state), heap, trace_data);
- mark_stack_ptr = scm_i_vm_mark_stack (&t->vm, mark_stack_ptr,
- mark_stack_limit);
+ scm_trace_dynstack (&thread->dynstack, trace_edge, heap, trace_data);
- return mark_stack_ptr;
+ trace_edge (gc_edge (&thread->continuation_root), heap, trace_data);
+}
+
+/* Guile-level thread objects are themselves GC-allocated. A thread
+ object has two states: active and finished. A thread is active if it
+ is attached to the gc_mutator_roots of a mutator. The thread has an
+ associated VM stack only during the active state.
+
+ Threads contain conservative roots, as the VM stack is only marked
+ partially precisely; it's possible that a frame doesn't have a stack
+ map for a given instruction pointer. This is the case for the hot
+ frame, but can also be the case for colder frames if there was a
+ per-instruction VM hook active. Therefore in a GC configuration that
+ only traces roots conservatively and assumes that intraheap edges are
+ precise, threads need to be traced during root identification.
+*/
+void
+scm_trace_thread_mutator_roots (struct scm_thread *thread,
+ void (*trace_edge) (struct gc_edge edge,
+ struct gc_heap *heap,
+ void *trace_data),
+ struct gc_heap *heap, void *trace_data)
+{
+ scm_trace_vm (&thread->vm, trace_edge, heap, trace_data);
+
+ /* FIXME: Remove these in favor of Whippet inline allocation. */
+ for (size_t i = 0; i < SCM_INLINE_GC_FREELIST_COUNT; i++)
+ trace_edge (gc_edge (&thread->freelists[i]), heap, trace_data);
+ for (size_t i = 0; i < SCM_INLINE_GC_FREELIST_COUNT; i++)
+ for (void **loc = &thread->pointerless_freelists[i];
+ *loc;
+ loc = (void **) *loc)
+ trace_edge (gc_edge (loc), heap, trace_data);
+
+ /* FIXME: Call instead via gc_trace_object. */
+ scm_trace_thread (thread, trace_edge, heap, trace_data);
}
@@ -234,11 +259,8 @@ dequeue (SCM q)
}
}
-/*** Thread smob routines */
-
-
-static int
-thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+int
+scm_i_print_thread (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
/* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
struct. A cast like "(unsigned long) t->pthread" is a syntax error in
@@ -309,7 +331,7 @@ block_self (SCM queue, scm_i_pthread_mutex_t *mutex,
return EINTR;
t->block_asyncs++;
- q_handle = enqueue (queue, t->handle);
+ q_handle = enqueue (queue, scm_thread_handle (t));
if (waittime == NULL)
err = scm_i_scm_pthread_cond_wait (&t->sleep_cond, mutex);
else
@@ -370,64 +392,64 @@ static int thread_count;
static SCM default_dynamic_state;
+struct scm_thread_and_roots
+{
+ struct scm_thread thread;
+ struct gc_mutator_roots roots;
+};
+
/* Perform first stage of thread initialisation, in non-guile mode.
*/
static void
-guilify_self_1 (struct GC_stack_base *base, int needs_unregister)
-{
- scm_thread t;
-
- /* We must arrange for SCM_I_CURRENT_THREAD to point to a valid value
- before allocating anything in this thread, because allocation could
- cause GC to run, and GC could cause finalizers, which could invoke
- Scheme functions, which need the current thread to be set. */
-
- memset (&t, 0, sizeof (t));
-
- t.pthread = scm_i_pthread_self ();
- t.handle = SCM_BOOL_F;
- t.result = SCM_BOOL_F;
- t.pending_asyncs = SCM_EOL;
- t.block_asyncs = 1;
- t.base = base->mem_base;
- t.continuation_root = SCM_EOL;
- t.continuation_base = t.base;
- scm_i_pthread_cond_init (&t.sleep_cond, NULL);
- scm_i_vm_prepare_stack (&t.vm);
+guilify_self_1 (struct gc_mutator *mut, struct gc_stack_addr base,
+ int needs_unregister)
+{
+ struct scm_thread_and_roots *thread_and_roots =
+ gc_allocate (mut, sizeof (*thread_and_roots), GC_ALLOCATION_TAGGED);
+ scm_thread *t = &thread_and_roots->thread;
+ struct gc_mutator_roots *roots = &thread_and_roots->roots;
+
+ /* We'll be referring to this object from thread-locals and other
+ places that are gnarly to relocate. */
+ gc_pin_object (mut, gc_ref_from_heap_object (t));
+
+ t->tag = scm_tc7_thread;
+ t->pthread = scm_i_pthread_self ();
+ t->result = SCM_BOOL_F;
+ t->pending_asyncs = SCM_EOL;
+ t->block_asyncs = 1;
+ t->mutator = mut;
+ t->base = (SCM_STACKITEM *) gc_stack_addr_as_pointer (base);
+ t->continuation_root = SCM_EOL;
+ t->continuation_base = t->base;
+ scm_i_pthread_cond_init (&t->sleep_cond, NULL);
+ scm_i_vm_prepare_stack (&t->vm);
- if (pipe2 (t.sleep_pipe, O_CLOEXEC) != 0)
+ if (pipe2 (t->sleep_pipe, O_CLOEXEC) != 0)
/* FIXME: Error conditions during the initialization phase are handled
gracelessly since public functions such as `scm_init_guile ()'
currently have type `void'. */
abort ();
- t.exited = 0;
- t.guile_mode = 0;
- t.needs_unregister = needs_unregister;
+ t->exited = 0;
+ t->guile_mode = 0;
+ t->needs_unregister = needs_unregister;
- /* The switcheroo. */
- {
- scm_thread *t_ptr = &t;
-
- GC_disable ();
- t_ptr = GC_generic_malloc (sizeof (*t_ptr), thread_gc_kind);
- memcpy (t_ptr, &t, sizeof t);
-
- scm_i_pthread_setspecific (scm_i_thread_key, t_ptr);
+ scm_i_pthread_setspecific (scm_i_thread_key, t);
#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
- /* Cache the current thread in TLS for faster lookup. */
- scm_i_current_thread = t_ptr;
+ /* Cache the current thread in TLS for faster lookup. */
+ scm_i_current_thread = t;
#endif
- scm_i_pthread_mutex_lock (&thread_admin_mutex);
- t_ptr->next_thread = all_threads;
- all_threads = t_ptr;
- thread_count++;
- scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ roots->thread = t;
+ gc_mutator_set_roots (mut, roots);
- GC_enable ();
- }
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+ t->next_thread = all_threads;
+ all_threads = t;
+ thread_count++;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
}
/* Perform second stage of thread initialisation, in guile mode.
@@ -439,9 +461,7 @@ guilify_self_2 (SCM dynamic_state)
t->guile_mode = 1;
- SCM_NEWSMOB (t->handle, scm_tc16_thread, t);
-
- t->continuation_root = scm_cons (t->handle, SCM_EOL);
+ t->continuation_root = scm_cons (scm_thread_handle (t), SCM_EOL);
t->continuation_base = t->base;
t->dynamic_state = scm_gc_typed_calloc (scm_t_dynamic_state);
@@ -469,6 +489,9 @@ on_thread_exit (void *v)
that isn't an issue as we have the all_threads list. */
scm_thread *t = (scm_thread *) v, **tp;
+ gc_finish_for_thread (t->mutator);
+ t->mutator = NULL;
+
t->exited = 1;
close (t->sleep_pipe[0]);
@@ -488,10 +511,6 @@ on_thread_exit (void *v)
}
thread_count--;
- /* Prevent any concurrent or future marker from visiting this
- thread. */
- t->handle = SCM_PACK (0);
-
/* If there's only one other thread, it could be the signal delivery
thread, in which case we should shut it down also by closing its
read pipe. */
@@ -517,11 +536,6 @@ on_thread_exit (void *v)
#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
scm_i_current_thread = NULL;
#endif
-
-#if SCM_USE_PTHREAD_THREADS
- if (t->needs_unregister)
- GC_unregister_my_thread ();
-#endif
}
static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT;
@@ -549,8 +563,7 @@ init_thread_key (void)
be sure. New threads are put into guile mode implicitly. */
static int
-scm_i_init_thread_for_guile (struct GC_stack_base *base,
- SCM dynamic_state)
+scm_i_init_thread_for_guile (struct gc_stack_addr base, SCM dynamic_state)
{
scm_i_pthread_once (&init_thread_key_once, init_thread_key);
@@ -573,47 +586,36 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base,
*/
scm_i_init_guile (base);
-#if SCM_USE_PTHREAD_THREADS
- /* Allow other threads to come in later. */
- GC_allow_register_threads ();
-#endif
-
scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
}
else
{
- int needs_unregister = 0;
-
/* Guile is already initialized, but this thread enters it for
the first time. Only initialize this thread.
*/
scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
- /* Register this thread with libgc. */
-#if SCM_USE_PTHREAD_THREADS
- if (GC_register_my_thread (base) == GC_SUCCESS)
- needs_unregister = 1;
-#endif
+ struct gc_mutator *mut = gc_init_for_thread (base, the_gc_heap);
+ int needs_unregister = 1;
- guilify_self_1 (base, needs_unregister);
+ guilify_self_1 (mut, base, needs_unregister);
guilify_self_2 (dynamic_state);
}
return 1;
}
}
+static void*
+init_main_thread (struct gc_stack_addr base, void *unused)
+{
+ scm_i_init_thread_for_guile (base, default_dynamic_state);
+ return NULL;
+}
+
void
-scm_init_guile ()
+scm_init_guile (void)
{
- struct GC_stack_base stack_base;
-
- if (GC_get_stack_base (&stack_base) == GC_SUCCESS)
- scm_i_init_thread_for_guile (&stack_base, default_dynamic_state);
- else
- {
- fprintf (stderr, "Failed to get stack base for current thread.\n");
- exit (EXIT_FAILURE);
- }
+ gc_call_with_stack_addr (init_main_thread, NULL);
}
struct with_guile_args
@@ -632,7 +634,7 @@ with_guile_trampoline (void *data)
}
static void *
-with_guile (struct GC_stack_base *base, void *data)
+with_guile (struct gc_stack_addr base, void *data)
{
void *res;
int new_thread;
@@ -666,11 +668,11 @@ with_guile (struct GC_stack_base *base, void *data)
when this thread was first guilified. Thus, `base' must be
updated. */
#if SCM_STACK_GROWS_UP
- if (SCM_STACK_PTR (base->mem_base) < t->base)
- t->base = SCM_STACK_PTR (base->mem_base);
+ if (SCM_STACK_PTR (gc_stack_addr_as_pointer (base)) < t->base)
+ t->base = SCM_STACK_PTR (gc_stack_addr_as_pointer (base));
#else
- if (SCM_STACK_PTR (base->mem_base) > t->base)
- t->base = SCM_STACK_PTR (base->mem_base);
+ if (SCM_STACK_PTR (gc_stack_addr_as_pointer (base)) > t->base)
+ t->base = SCM_STACK_PTR (gc_stack_addr_as_pointer (base));
#endif
t->guile_mode = 1;
@@ -689,7 +691,7 @@ scm_i_with_guile (void *(*func)(void *), void *data, SCM
dynamic_state)
args.data = data;
args.dynamic_state = dynamic_state;
- return GC_call_with_stack_base (with_guile, &args);
+ return gc_call_with_stack_addr (with_guile, &args);
}
void *
@@ -1002,19 +1004,19 @@ lock_mutex (enum scm_mutex_kind kind, struct scm_mutex
*m,
if (scm_is_eq (m->owner, SCM_BOOL_F))
{
- m->owner = current_thread->handle;
+ m->owner = scm_thread_handle (current_thread);
scm_i_pthread_mutex_unlock (&m->lock);
return SCM_BOOL_T;
}
else if (kind == SCM_MUTEX_RECURSIVE &&
- scm_is_eq (m->owner, current_thread->handle))
+ scm_is_eq (m->owner, scm_thread_handle (current_thread)))
{
m->level++;
scm_i_pthread_mutex_unlock (&m->lock);
return SCM_BOOL_T;
}
else if (kind == SCM_MUTEX_STANDARD &&
- scm_is_eq (m->owner, current_thread->handle))
+ scm_is_eq (m->owner, scm_thread_handle (current_thread)))
{
scm_i_pthread_mutex_unlock (&m->lock);
SCM_MISC_ERROR ("mutex already locked by thread", SCM_EOL);
@@ -1051,7 +1053,7 @@ lock_mutex (enum scm_mutex_kind kind, struct scm_mutex *m,
maybe_acquire:
if (scm_is_eq (m->owner, SCM_BOOL_F))
{
- m->owner = current_thread->handle;
+ m->owner = scm_thread_handle (current_thread);
scm_i_pthread_mutex_unlock (&m->lock);
return SCM_BOOL_T;
}
@@ -1138,7 +1140,7 @@ unlock_mutex (enum scm_mutex_kind kind, struct scm_mutex
*m,
{
scm_i_scm_pthread_mutex_lock (&m->lock);
- if (!scm_is_eq (m->owner, current_thread->handle))
+ if (!scm_is_eq (m->owner, scm_thread_handle (current_thread)))
{
if (scm_is_eq (m->owner, SCM_BOOL_F))
{
@@ -1302,7 +1304,7 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex
*m, struct scm_cond *c,
{
scm_i_scm_pthread_mutex_lock (&m->lock);
- if (!scm_is_eq (m->owner, current_thread->handle))
+ if (!scm_is_eq (m->owner, scm_thread_handle (current_thread)))
{
if (scm_is_eq (m->owner, SCM_BOOL_F))
{
@@ -1354,7 +1356,7 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex
*m, struct scm_cond *c,
interrupts while reaquiring a mutex after a wait. */
current_thread->block_asyncs++;
if (kind == SCM_MUTEX_RECURSIVE &&
- scm_is_eq (m->owner, current_thread->handle))
+ scm_is_eq (m->owner, scm_thread_handle (current_thread)))
{
m->level++;
scm_i_pthread_mutex_unlock (&m->lock);
@@ -1364,7 +1366,7 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex
*m, struct scm_cond *c,
{
if (scm_is_eq (m->owner, SCM_BOOL_F))
{
- m->owner = current_thread->handle;
+ m->owner = scm_thread_handle (current_thread);
scm_i_pthread_mutex_unlock (&m->lock);
break;
}
@@ -1664,7 +1666,7 @@ SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0,
"Return the thread that called this function.")
#define FUNC_NAME s_scm_current_thread
{
- return SCM_I_CURRENT_THREAD->handle;
+ return scm_thread_handle (SCM_I_CURRENT_THREAD);
}
#undef FUNC_NAME
@@ -1696,7 +1698,7 @@ SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
&& !scm_i_is_signal_delivery_thread (t)
&& !scm_i_is_finalizer_thread (t))
{
- SCM_SETCAR (*l, t->handle);
+ SCM_SETCAR (*l, scm_thread_handle (t));
l = SCM_CDRLOC (*l);
}
n--;
@@ -1775,7 +1777,7 @@ pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
#endif
void
-scm_threads_prehistory (void *base)
+scm_threads_prehistory (struct gc_mutator *mut, struct gc_stack_addr base)
{
#if SCM_USE_PTHREAD_THREADS
pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive);
@@ -1786,15 +1788,9 @@ scm_threads_prehistory (void *base)
scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL);
scm_i_pthread_cond_init (&wake_up_cond, NULL);
- thread_gc_kind =
- GC_new_kind (GC_new_free_list (),
- GC_MAKE_PROC (GC_new_proc (thread_mark), 0),
- 0, 1);
-
- guilify_self_1 ((struct GC_stack_base *) base, 0);
+ guilify_self_1 (mut, base, 0);
}
-scm_t_bits scm_tc16_thread;
scm_t_bits scm_tc16_mutex;
scm_t_bits scm_tc16_condvar;
@@ -1817,9 +1813,6 @@ scm_init_ice_9_threads (void *unused)
void
scm_init_threads ()
{
- scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_thread));
- scm_set_smob_print (scm_tc16_thread, thread_print);
-
scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (struct scm_mutex));
scm_set_smob_print (scm_tc16_mutex, scm_mutex_print);
diff --git a/libguile/threads.h b/libguile/threads.h
index e6a60e96b..fd912c1cc 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -1,7 +1,7 @@
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
-/* Copyright 1996-1998,2000-2004,2006-2009,2011-2014,2018-2019
+/* Copyright 1996-1998,2000-2004,2006-2009,2011-2014,2018-2019,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -53,13 +53,15 @@
/* smob tags for the thread datatypes */
-SCM_API scm_t_bits scm_tc16_thread;
SCM_API scm_t_bits scm_tc16_mutex;
SCM_API scm_t_bits scm_tc16_condvar;
struct scm_thread_wake_data;
+struct gc_mutator;
struct scm_thread {
+ scm_t_bits tag;
+
struct scm_thread *next_thread;
/* VM state for this thread. */
@@ -72,11 +74,13 @@ struct scm_thread {
unsigned int block_asyncs; /* Non-zero means that asyncs should
not be run. */
+ /* Every thread is a mutator for the GC. */
+ struct gc_mutator *mutator;
+
/* Thread-local freelists; see gc-inline.h. */
void *freelists[SCM_INLINE_GC_FREELIST_COUNT];
void *pointerless_freelists[SCM_INLINE_GC_FREELIST_COUNT];
- SCM handle;
scm_i_pthread_t pthread;
SCM result;
@@ -127,11 +131,17 @@ struct scm_thread {
struct scm_jit_state *jit_state;
};
-#define SCM_I_IS_THREAD(x) SCM_SMOB_PREDICATE (scm_tc16_thread, x)
-#define SCM_I_THREAD_DATA(x) ((scm_thread *) SCM_SMOB_DATA (x))
+static inline SCM
+scm_thread_handle (struct scm_thread *thread)
+{
+ return SCM_PACK_POINTER (thread);
+}
+
+#define SCM_I_IS_THREAD(obj) SCM_HAS_TYP7 ((obj), scm_tc7_thread)
+#define SCM_I_THREAD_DATA(x) ((scm_thread *) SCM_UNPACK_POINTER (x))
#define SCM_VALIDATE_THREAD(pos, a) \
- scm_assert_smob_type (scm_tc16_thread, (a))
+ SCM_ASSERT_TYPE (SCM_I_IS_THREAD (a), (a), (pos), FUNC_NAME, "thread")
#define SCM_VALIDATE_MUTEX(pos, a) \
scm_assert_smob_type (scm_tc16_mutex, (a))
#define SCM_VALIDATE_CONDVAR(pos, a) \
@@ -143,12 +153,13 @@ SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void
*body_data,
SCM_API void *scm_without_guile (void *(*func)(void *), void *data);
SCM_API void *scm_with_guile (void *(*func)(void *), void *data);
-SCM_INTERNAL void scm_threads_prehistory (void *);
SCM_INTERNAL void scm_init_threads (void);
SCM_INTERNAL void scm_init_threads_default_dynamic_state (void);
SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs
(scm_i_pthread_mutex_t *mutex);
+SCM_INTERNAL int scm_i_print_thread (SCM t, SCM port, scm_print_state *pstate);
+
SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
SCM_API SCM scm_yield (void);
SCM_API SCM scm_cancel_thread (SCM t);
diff --git a/libguile/trace.h b/libguile/trace.h
new file mode 100644
index 000000000..e05050470
--- /dev/null
+++ b/libguile/trace.h
@@ -0,0 +1,56 @@
+#ifndef SCM_THREADS_INTERNAL_H
+#define SCM_THREADS_INTERNAL_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"
+#include "gc-edge.h"
+
+
+
+struct scm_thread;
+struct scm_vm;
+struct gc_heap;
+
+SCM_INTERNAL void
+scm_trace_thread_mutator_roots (struct scm_thread *thread,
+ void (*trace_edge)(struct gc_edge edge,
+ struct gc_heap *heap,
+ void *trace_data),
+ struct gc_heap *heap,
+ void *trace_data);
+
+SCM_INTERNAL void scm_trace_thread (struct scm_thread *thread,
+ void (*trace_edge)(struct gc_edge edge,
+ struct gc_heap *heap,
+ void *trace_data),
+ struct gc_heap *heap,
+ void *trace_data);
+
+SCM_INTERNAL void scm_trace_vm (struct scm_vm *vp,
+ void (*trace_edge)(struct gc_edge edge,
+ struct gc_heap *heap,
+ void *trace_data),
+ struct gc_heap *heap,
+ void *trace_data);
+
+
+#endif /* SCM_THREADS_INTERNAL_H */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index e2ea81190..37e290fe5 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2017-2021,2023
+/* Copyright 2001,2009-2015,2017-2021,2023,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -1802,7 +1802,7 @@ VM_NAME (scm_thread *thread)
uint32_t dst;
UNPACK_24 (op, dst);
- SP_SET (dst, thread->handle);
+ SP_SET (dst, scm_thread_handle (thread));
NEXT (1);
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 6dc05e883..1c6670967 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2017-2020,2022-2023
+/* Copyright 2001,2009-2015,2017-2020,2022-2023,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -67,6 +67,7 @@
#include "smob.h"
#include "stackchk.h"
#include "symbols.h"
+#include "trace.h"
#include "values.h"
#include "vectors.h"
#include "version.h"
@@ -708,10 +709,12 @@ enum slot_desc
SLOT_DESC_UNUSED = 3
};
-/* Mark the active VM stack region. */
-struct GC_ms_entry *
-scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
- struct GC_ms_entry *mark_stack_limit)
+void
+scm_trace_vm (struct scm_vm *vp,
+ void (*trace_edge) (struct gc_edge edge,
+ struct gc_heap *heap,
+ void *trace_data),
+ struct gc_heap *heap, void *trace_data)
{
union scm_vm_stack_element *sp, *fp;
/* The first frame will be marked conservatively (without a slot map).
@@ -720,8 +723,6 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry
*mark_stack_ptr,
providing slot maps for all points in a program would take a
prohibitive amount of space. */
const uint8_t *slot_map = NULL;
- void *upper = (void *) GC_greatest_plausible_heap_addr;
- void *lower = (void *) GC_least_plausible_heap_addr;
struct slot_map_cache cache;
memset (&cache, 0, sizeof (cache));
@@ -745,12 +746,8 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry
*mark_stack_ptr,
break;
case SLOT_DESC_UNUSED:
case SLOT_DESC_LIVE_GC:
- if (SCM_NIMP (sp->as_scm) &&
- sp->as_ptr >= lower && sp->as_ptr <= upper)
- mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
- mark_stack_ptr,
- mark_stack_limit,
- NULL);
+ if (SCM_NIMP (sp->as_scm))
+ trace_edge (gc_edge (sp), heap, trace_data);
break;
case SLOT_DESC_DEAD:
/* This value may become dead as a result of GC,
@@ -768,8 +765,6 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry
*mark_stack_ptr,
}
return_unused_stack_to_os (vp);
-
- return mark_stack_ptr;
}
/* Free the VM stack, as this thread is exiting. */
@@ -1401,7 +1396,7 @@ scm_i_vm_emergency_abort (SCM *tag_and_argv, size_t n)
fp = vp->stack_top - fp_offset;
sp = vp->stack_top - sp_offset;
- /* Restore FP first so that a concurrent 'scm_i_vm_mark_stack' does
+ /* Restore FP first so that a concurrent 'scm_trace_vm' does
not overwrite the 'abort' arguments assigned below (see
<https://bugs.gnu.org/28211>). */
vp->fp = fp;
@@ -1476,7 +1471,7 @@ abort_to_prompt (scm_thread *thread, uint8_t *saved_mra)
/* Continuation gets nargs+1 values: the one more is for the cont. */
sp = sp - nargs - 1;
- /* Restore FP first so that a concurrent 'scm_i_vm_mark_stack' does
+ /* Restore FP first so that a concurrent 'scm_trace_vm' does
not overwrite the 'abort' arguments assigned below (see
<https://bugs.gnu.org/28211>). */
vp->fp = fp;
diff --git a/libguile/vm.h b/libguile/vm.h
index d5b7138d3..d6175ff8e 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,4 +1,4 @@
-/* Copyright 2001,2009-2015,2017-2018
+/* Copyright 2001,2009-2015,2017-2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@@ -88,10 +88,6 @@ SCM_API void scm_c_set_vm_engine_x (int engine);
SCM_API void scm_c_set_default_vm_engine_x (int engine);
SCM_INTERNAL void scm_i_vm_prepare_stack (struct scm_vm *vp);
-struct GC_ms_entry;
-SCM_INTERNAL struct GC_ms_entry * scm_i_vm_mark_stack (struct scm_vm *,
- struct GC_ms_entry *,
- struct GC_ms_entry *);
SCM_INTERNAL void scm_i_vm_free_stack (struct scm_vm *vp);
#define SCM_F_VM_CONT_PARTIAL 0x1
diff --git a/libguile/whippet-embedder.h b/libguile/whippet-embedder.h
index 2b5b15a36..aa82eb4f1 100644
--- a/libguile/whippet-embedder.h
+++ b/libguile/whippet-embedder.h
@@ -29,13 +29,19 @@
-#include "scm.h"
+#include "libguile/scm.h"
+#include "libguile/trace.h"
#include "gc-config.h"
#include "gc-embedder-api.h"
+struct scm_thread;
+struct gc_mutator_roots {
+ struct scm_thread *thread;
+};
+
#define GC_EMBEDDER_EPHEMERON_HEADER uintptr_t tag;
#define GC_EMBEDDER_FINALIZER_HEADER uintptr_t tag;
@@ -84,12 +90,15 @@ static inline void gc_trace_object (struct gc_ref ref,
#endif
}
+
static inline void gc_trace_mutator_roots (struct gc_mutator_roots *roots,
- void (*trace_edge)(struct gc_edge
edge,
- struct gc_heap
*heap,
- void
*trace_data),
+ void (*trace_edge) (struct gc_edge
edge,
+ struct gc_heap
*heap,
+ void
*trace_data),
struct gc_heap *heap,
void *trace_data) {
+ trace_edge (gc_edge (&roots->thread), heap, trace_data);
+ scm_trace_thread_mutator_roots (roots->thread, trace_edge, heap, trace_data);
}
static inline void gc_trace_heap_roots (struct gc_heap_roots *roots,
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 1756274c6..bb530c7c6 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013-2021, 2023 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2021, 2023, 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
@@ -504,6 +504,7 @@
(#('program? #f (a)) (unary emit-program? a))
(#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
(#('bytevector? #f (a)) (unary emit-bytevector? a))
+ (#('thread? #f (a)) (unary emit-thread? a))
(#('weak-set? #f (a)) (unary emit-weak-set? a))
(#('weak-table? #f (a)) (unary emit-weak-table? a))
(#('array? #f (a)) (unary emit-array? a))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 5b1f7978b..098803be3 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
;;;; goops.scm -- The Guile Object-Oriented Programming System
;;;;
-;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018,2021
+;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018,2021,2025
;;;; Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <e...@unice.fr>
;;;;
@@ -69,7 +69,7 @@
<boolean> <char> <list> <pair> <null> <string> <symbol>
<vector> <bytevector> <uvec> <foreign> <hashtable>
<fluid> <dynamic-state> <frame> <vm> <vm-continuation>
- <keyword> <syntax> <atomic-box>
+ <keyword> <syntax> <atomic-box> <thread>
;; Numbers.
<number> <complex> <real> <integer> <fraction>
@@ -81,7 +81,7 @@
;; corresponding classes, which may be obtained via class-of,
;; once you have an instance. Perhaps FIXME to provide a
;; smob-type-name->class procedure.
- <promise> <thread> <mutex> <condition-variable>
+ <promise> <mutex> <condition-variable>
<regexp> <hook> <bitvector> <random-state>
<directory> <array> <character-set>
<dynamic-object> <guardian> <macro>
@@ -1078,6 +1078,7 @@ slots as we go."
(define-standard-class <uvec> (<bytevector>))
(define-standard-class <array> (<top>))
(define-standard-class <bitvector> (<top>))
+(define-standard-class <thread> (<top>))
(define-standard-class <number> (<top>))
(define-standard-class <complex> (<number>))
(define-standard-class <real> (<complex>))
@@ -3525,7 +3526,6 @@ var{initargs}."
;;;
(define <promise> (find-subclass <top> '<promise>))
-(define <thread> (find-subclass <top> '<thread>))
(define <mutex> (find-subclass <top> '<mutex>))
(define <condition-variable> (find-subclass <top> '<condition-variable>))
(define <regexp> (find-subclass <top> '<regexp>))
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 7ed038d3a..75235ea07 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -1,5 +1,5 @@
;;; 'SCM' type tag decoding.
-;;; Copyright (C) 2014, 2015, 2017, 2018, 2022 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017, 2018, 2022, 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
@@ -417,6 +417,8 @@ using BACKEND."
(((_ & #x7f = %tc7-bytevector) len address)
(let ((bv-port (memory-port backend address len)))
(get-bytevector-n bv-port len)))
+ (((_ & #x7f = %tc7-thread))
+ (inferior-object 'thread address))
((((len << 8) || %tc7-vector))
(let ((words (get-bytevector-n port (* len %word-size)))
(vector (make-vector len)))
diff --git a/module/system/base/types/internal.scm
b/module/system/base/types/internal.scm
index 546c6d26c..a30a73bbc 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -1,5 +1,5 @@
;;; Details on internal value representation.
-;;; Copyright (C) 2014, 2015, 2017, 2018, 2020, 2021 Free Software Foundation,
Inc.
+;;; Copyright (C) 2014, 2015, 2017, 2018, 2020, 2021, 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
@@ -51,6 +51,7 @@
%tc7-program
%tc7-vm-continuation
%tc7-bytevector
+ %tc7-thread
%tc7-weak-set
%tc7-weak-table
%tc7-array
@@ -147,7 +148,7 @@
(program program? #b1111111 #b1000101)
(vm-continuation vm-continuation? #b1111111 #b1000111)
(bytevector bytevector? #b1111111 #b1001101)
- ;;(unused unused #b1111111 #b1001111)
+ (thread thread? #b1111111 #b1001111)
(weak-set weak-set? #b1111111 #b1010101)
(weak-table weak-table? #b1111111 #b1010111)
(array array? #b1111111 #b1011101)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 4114c221a..46f75482b 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1,6 +1,6 @@
;;; Guile bytecode assembler
-;;; Copyright (C) 2001, 2009-2023 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009-2023, 2025, 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
@@ -132,6 +132,7 @@
emit-program?
emit-vm-continuation?
emit-bytevector?
+ emit-thread?
emit-weak-set?
emit-weak-table?
emit-array?
