wingo pushed a commit to branch wip-whippet
in repository guile.
commit 1f96d1bf4b7b810b5862855d9def548c3daeba60
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed May 7 09:56:10 2025 +0200
Move to store thread join cond/lock/results directly
* libguile/threads.h: Add join data directly on the thread instead of
using a Scheme-side weak table. It's less complicated and it will let
the weak table implementation use locks in Scheme; otherwise you would
have threads depending on weak tables and vice versa.
* libguile/threads.c (scm_trace_thread, guilify_self_1): Init and mark
the new members.
(thread_join_cond, thread_join_lock, thread_join_results)
(thread_init_joinable_x, thread_set_join_results_x): New accessors.
* module/ice-9/threads.scm (call-with-new-thread, join-thread): Use the
new accessors.
---
libguile/threads.c | 56 +++++++++++++++++++++++++++++++++++++++++++++
libguile/threads.h | 6 +++++
module/ice-9/threads.scm | 59 ++++++++++++++++--------------------------------
3 files changed, 82 insertions(+), 39 deletions(-)
diff --git a/libguile/threads.c b/libguile/threads.c
index bf9997ed7..380864f6f 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -108,6 +108,10 @@ scm_trace_thread (struct scm_thread *thread,
scm_trace_dynstack (&thread->dynstack, trace_edge, heap, trace_data);
trace_edge (gc_edge (&thread->continuation_root), heap, trace_data);
+
+ trace_edge (gc_edge (&thread->join_cond), heap, trace_data);
+ trace_edge (gc_edge (&thread->join_lock), heap, trace_data);
+ trace_edge (gc_edge (&thread->join_results), heap, trace_data);
}
/* Guile-level thread objects are themselves GC-allocated. A thread
@@ -413,6 +417,8 @@ guilify_self_1 (struct gc_mutator *mut, struct
gc_stack_addr base,
t->base = (SCM_STACKITEM *) gc_stack_addr_as_pointer (base);
t->continuation_root = SCM_EOL;
t->continuation_base = t->base;
+ t->join_cond = t->join_lock = t->join_results = SCM_BOOL_F;
+
scm_i_pthread_cond_init (&t->sleep_cond, NULL);
scm_i_vm_prepare_stack (&t->vm);
@@ -840,6 +846,56 @@ scm_cancel_thread (SCM thread)
static SCM join_thread_var;
+SCM_DEFINE_STATIC (thread_join_cond, "%thread-join-cond", 1, 0, 0,
+ (SCM thread), "")
+#define FUNC_NAME s_thread_join_cond
+{
+ SCM_VALIDATE_THREAD (1, thread);
+ return SCM_I_THREAD_DATA (thread)->join_cond;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_STATIC (thread_join_lock, "%thread-join-lock", 1, 0, 0,
+ (SCM thread), "")
+#define FUNC_NAME s_thread_join_lock
+{
+ SCM_VALIDATE_THREAD (1, thread);
+ return SCM_I_THREAD_DATA (thread)->join_lock;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_STATIC (thread_join_results, "%thread-join-results", 1, 0, 0,
+ (SCM thread), "")
+#define FUNC_NAME s_thread_join_results
+{
+ SCM_VALIDATE_THREAD (1, thread);
+ return SCM_I_THREAD_DATA (thread)->join_results;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_STATIC (thread_init_joinable_x, "%thread-init-joinable!", 3, 0, 0,
+ (SCM thread, SCM cond, SCM lock), "")
+#define FUNC_NAME s_thread_init_joinable_x
+{
+ SCM_VALIDATE_THREAD (1, thread);
+ SCM_VALIDATE_CONDVAR (2, cond);
+ SCM_VALIDATE_MUTEX (3, lock);
+ SCM_I_THREAD_DATA (thread)->join_cond = cond;
+ SCM_I_THREAD_DATA (thread)->join_lock = lock;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE_STATIC (thread_set_join_results_x, "%thread-set-join-results!",
+ 2, 0, 0, (SCM thread, SCM results), "")
+#define FUNC_NAME s_thread_set_join_results_x
+{
+ SCM_VALIDATE_THREAD (1, thread);
+ SCM_I_THREAD_DATA (thread)->join_results = results;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM
scm_join_thread (SCM thread)
{
diff --git a/libguile/threads.h b/libguile/threads.h
index 2e184391c..918e87c41 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -123,6 +123,12 @@ struct scm_thread {
SCM_STACKITEM *auxiliary_stack_base;
#endif
+ /* For joinable threads, a cond to wait on joining, and a lock to
+ protect the results. #f if not joinable. */
+ SCM join_cond;
+ SCM join_lock;
+ SCM join_results;
+
/* JIT state; NULL until this thread needs to JIT-compile something. */
struct scm_jit_state *jit_state;
};
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index 0d3880d69..dec380c38 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -102,9 +102,6 @@ no-op."
(error "thread cancellation failed, throwing error instead???"))))
thread))
-(define thread-join-data (make-object-property))
-(define %thread-results (make-object-property))
-
(define* (call-with-new-thread thunk #:optional handler)
"Call @code{thunk} in a new thread and with a new dynamic state,
returning a new thread object representing the thread. The procedure
@@ -146,15 +143,7 @@ Once @var{thunk} or @var{handler} returns, the return
value is made the
(lambda ()
(lock-mutex mutex)
(set! thread (current-thread))
- ;; Rather than use the 'set!' syntax here, we use the
- ;; underlying 'setter' generic function to set the
- ;; 'thread-join-data' property on 'thread'. This is
- ;; because 'set!' will try to resolve 'setter' in the
- ;; '(guile)' module, which means acquiring the
- ;; 'autoload' mutex. If the calling thread is
- ;; already holding that mutex, this will result in
- ;; deadlock. See <https://bugs.gnu.org/62691>.
- ((setter thread-join-data) thread (cons cv mutex))
+ (%thread-init-joinable! thread cv mutex)
(signal-condition-variable cv)
(unlock-mutex mutex)
(call-with-unblocked-asyncs
@@ -163,16 +152,7 @@ Once @var{thunk} or @var{handler} returns, the return
value is made the
(apply values args))))
(lambda vals
(lock-mutex mutex)
- ;; Probably now you're wondering why we are going to use
- ;; the cond variable as the key into the thread results
- ;; object property. It's because there is a possibility
- ;; that the thread object itself ends up as part of the
- ;; result, and if that happens we create a cycle whereby
- ;; the strong reference to a thread in the value of the
- ;; weak-key hash table used by the object property prevents
- ;; the thread from ever being collected. So instead we use
- ;; the cv as the key. Weak-key hash tables, amirite?
- (set! (%thread-results cv) vals)
+ (%thread-set-join-results! thread vals)
(broadcast-condition-variable cv)
(unlock-mutex mutex)
(apply values vals)))))
@@ -185,23 +165,24 @@ Once @var{thunk} or @var{handler} returns, the return
value is made the
(define* (join-thread thread #:optional timeout timeoutval)
"Suspend execution of the calling thread until the target @var{thread}
terminates, unless the target @var{thread} has already terminated."
- (match (thread-join-data thread)
- (#f (error "foreign thread cannot be joined" thread))
- ((cv . mutex)
- (lock-mutex mutex)
- (let lp ()
- (cond
- ((%thread-results cv)
- => (lambda (results)
- (unlock-mutex mutex)
- (apply values results)))
- ((if timeout
- (wait-condition-variable cv mutex timeout)
- (wait-condition-variable cv mutex))
- (lp))
- (else
- (unlock-mutex mutex)
- timeoutval))))))
+ (define cv (%thread-join-cond thread))
+ (define mutex (%thread-join-lock thread))
+ (unless cv
+ (error "foreign thread cannot be joined" thread))
+ (lock-mutex mutex)
+ (let lp ()
+ (cond
+ ((%thread-join-results thread)
+ => (lambda (results)
+ (unlock-mutex mutex)
+ (apply values results)))
+ ((if timeout
+ (wait-condition-variable cv mutex timeout)
+ (wait-condition-variable cv mutex))
+ (lp))
+ (else
+ (unlock-mutex mutex)
+ timeoutval))))
(define* (try-mutex mutex)
"Try to lock @var{mutex}. If the mutex is already locked, return
