mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Use Whippet API to boot threads

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2025-04-22 10:21:20 +02:00
parent 55e9d0672b
commit 27f0490801
25 changed files with 299 additions and 217 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile/Makefile.am
View file

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

5
libguile/continuations.c
View file

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

3
libguile/evalext.c
View file

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

2
libguile/finalizers.c
View file

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

8
libguile/gc-internal.h
View file

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

10
libguile/gc.c
View file

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

3
libguile/gc.h
View file

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

6
libguile/goops.c
View file

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

9
libguile/init.c
View file

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

4
libguile/init.h
View file

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

7
libguile/jit.c
View file

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

5
libguile/print.c
View file

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

2
libguile/scm.h
View file

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

291
libguile/threads.c
View file

@ -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 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)
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)
{
int word;
struct scm_thread *t = (struct scm_thread *) addr;
/* FIXME: Untagged array. Perhaps this should be off-heap... or
interleaved on the main stack. */
trace_edge (gc_edge (&dynstack->base), 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;
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)
{
trace_edge (gc_edge (&thread->next_thread), 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->pending_asyncs), 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);
}
}
trace_edge (gc_edge (&thread->result), heap, trace_data);
mark_stack_ptr = scm_i_vm_mark_stack (&t->vm, mark_stack_ptr,
mark_stack_limit);
/* FIXME: This is not a tagged allocation. */
trace_edge (gc_edge (&thread->dynamic_state), heap, trace_data);
return mark_stack_ptr;
scm_trace_dynstack (&thread->dynstack, trace_edge, heap, trace_data);
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)
guilify_self_1 (struct gc_mutator *mut, struct gc_stack_addr base,
int needs_unregister)
{
scm_thread t;
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 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. */
/* 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));
memset (&t, 0, sizeof (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);
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);
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;
}
}
void
scm_init_guile ()
static void*
init_main_thread (struct gc_stack_addr base, void *unused)
{
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);
}
scm_i_init_thread_for_guile (base, default_dynamic_state);
return NULL;
}
void
scm_init_guile (void)
{
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);

25
libguile/threads.h
View file

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

56
libguile/trace.h Normal file
View file

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

4
libguile/vm-engine.c
View file

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

29
libguile/vm.c
View file

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

6
libguile/vm.h
View file

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

17
libguile/whippet-embedder.h
View file

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

3
module/language/cps/compile-bytecode.scm
View file

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

8
module/oop/goops.scm
View file

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

4
module/system/base/types.scm
View file

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

5
module/system/base/types/internal.scm
View file

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

3
module/system/vm/assembler.scm
View file

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