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 . - ((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