Index: libguile/null-threads.h =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/null-threads.h,v retrieving revision 1.12 diff -a -u -r1.12 null-threads.h --- libguile/null-threads.h 17 Apr 2006 00:05:40 -0000 1.12 +++ libguile/null-threads.h 27 Sep 2007 02:20:32 -0000 @@ -41,6 +41,9 @@ #define scm_i_pthread_create(t,a,f,d) (*(t)=0, (void)(f), ENOSYS) #define scm_i_pthread_detach(t) do { } while (0) #define scm_i_pthread_exit(v) exit(0) +#define scm_i_pthread_cancel(t) 0 +#define scm_i_pthread_cleanup_push(t,v) 0 +#define scm_i_pthread_cleanup_pop(e) 0 #define scm_i_sched_yield() 0 /* Signals Index: libguile/pthread-threads.h =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/pthread-threads.h,v retrieving revision 1.15 diff -a -u -r1.15 pthread-threads.h --- libguile/pthread-threads.h 9 Oct 2006 23:21:00 -0000 1.15 +++ libguile/pthread-threads.h 27 Sep 2007 02:20:32 -0000 @@ -35,6 +35,9 @@ #define scm_i_pthread_create pthread_create #define scm_i_pthread_detach pthread_detach #define scm_i_pthread_exit pthread_exit +#define scm_i_pthread_cancel pthread_cancel +#define scm_i_pthread_cleanup_push pthread_cleanup_push +#define scm_i_pthread_cleanup_pop pthread_cleanup_pop #define scm_i_sched_yield sched_yield /* Signals Index: libguile/scmsigs.c =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/scmsigs.c,v retrieving revision 1.97 diff -a -u -r1.97 scmsigs.c --- libguile/scmsigs.c 7 Mar 2007 23:10:52 -0000 1.97 +++ libguile/scmsigs.c 27 Sep 2007 02:20:33 -0000 @@ -33,6 +33,7 @@ #include "libguile/eval.h" #include "libguile/root.h" #include "libguile/vectors.h" +#include "libguile/threads.h" #include "libguile/validate.h" #include "libguile/scmsigs.h" @@ -99,6 +100,9 @@ static SCM signal_handler_asyncs; static SCM signal_handler_threads; +scm_i_thread *scm_i_signal_delivery_thread; +static scm_i_pthread_mutex_t signal_delivery_thread_mutex; + /* saves the original C handlers, when a new handler is installed. set to SIG_ERR if the original handler is installed. */ #ifdef HAVE_SIGACTION @@ -185,20 +189,25 @@ if (scm_is_true (h)) scm_system_async_mark_for_thread (h, t); } + else if (n == 0) + break; /* the signal pipe was closed. */ else if (n < 0 && errno != EINTR) perror ("error in signal delivery thread"); } - return SCM_UNSPECIFIED; /* not reached */ + return SCM_UNSPECIFIED; /* not reached unless all other threads exited */ } static void start_signal_delivery_thread (void) { + scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex); if (pipe (signal_pipe) != 0) scm_syserror (NULL); - scm_spawn_thread (signal_delivery_thread, NULL, - scm_handle_by_message, "signal delivery thread"); + scm_i_signal_delivery_thread = SCM_I_THREAD_DATA + (scm_spawn_thread (signal_delivery_thread, NULL, + scm_handle_by_message, "signal delivery thread")); + scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex); } static void @@ -653,10 +662,29 @@ void +scm_i_close_signal_pipe() +{ + /* signal_delivery_thread_mutex will only be locked while the signal + delivery thread is being launched. The thread that calls this function + is already holding the thread admin mutex, so if the delivery thread + hasn't been launched at this point, it never will be before shutdown. + */ + scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex); + if (scm_i_signal_delivery_thread != NULL) + { + close (signal_pipe[1]); + } + scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex); +} + +void scm_init_scmsigs () { int i; + scm_i_pthread_mutex_init (&signal_delivery_thread_mutex, NULL); + scm_i_signal_delivery_thread = NULL; + signal_handlers = SCM_VARIABLE_LOC (scm_c_define ("signal-handlers", scm_c_make_vector (NSIG, SCM_BOOL_F))); Index: libguile/scmsigs.h =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/scmsigs.h,v retrieving revision 1.17 diff -a -u -r1.17 scmsigs.h --- libguile/scmsigs.h 17 Apr 2006 00:05:40 -0000 1.17 +++ libguile/scmsigs.h 27 Sep 2007 02:20:33 -0000 @@ -41,6 +41,8 @@ SCM_API SCM scm_raise (SCM sig); SCM_API void scm_init_scmsigs (void); +SCM_API void scm_i_close_signal_pipe (void); + #endif /* SCM_SCMSIGS_H */ /* Index: libguile/threads.c =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v retrieving revision 1.88 diff -a -u -r1.88 threads.c --- libguile/threads.c 15 Jan 2007 23:35:34 -0000 1.88 +++ libguile/threads.c 27 Sep 2007 02:20:34 -0000 @@ -48,6 +48,7 @@ #include "libguile/continuations.h" #include "libguile/gc.h" #include "libguile/init.h" +#include "libguile/scmsigs.h" #ifdef __MINGW32__ #ifndef ETIMEDOUT @@ -131,6 +132,7 @@ { scm_i_thread *t = SCM_I_THREAD_DATA (obj); scm_gc_mark (t->result); + scm_gc_mark (t->cleanup_handler); scm_gc_mark (t->join_queue); scm_gc_mark (t->dynwinds); scm_gc_mark (t->active_asyncs); @@ -405,6 +407,8 @@ static SCM scm_i_default_dynamic_state; +extern scm_i_thread *scm_i_signal_delivery_thread; + /* Perform first stage of thread initialisation, in non-guile mode. */ static void @@ -415,6 +419,7 @@ t->pthread = scm_i_pthread_self (); t->handle = SCM_BOOL_F; t->result = SCM_BOOL_F; + t->cleanup_handler = SCM_BOOL_F; t->join_queue = SCM_EOL; t->dynamic_state = SCM_BOOL_F; t->dynwinds = SCM_EOL; @@ -434,6 +439,7 @@ scm_i_pthread_mutex_init (&t->heap_mutex, NULL); t->clear_freelists_p = 0; t->gc_running_p = 0; + t->canceled = 0; t->exited = 0; t->freelist = SCM_EOL; @@ -478,7 +484,16 @@ static void * do_thread_exit (void *v) { - scm_i_thread *t = (scm_i_thread *)v; + scm_i_thread *t = (scm_i_thread *) v; + + if (!scm_is_false (t->cleanup_handler)) + { + SCM ptr = t->cleanup_handler; + t->cleanup_handler = SCM_BOOL_F; + t->result = scm_internal_catch (SCM_BOOL_T, + (scm_t_catch_body) scm_call_0, ptr, + scm_handle_by_message_noexit, NULL); + } scm_i_scm_pthread_mutex_lock (&thread_admin_mutex); @@ -489,6 +504,7 @@ ; scm_i_pthread_mutex_unlock (&thread_admin_mutex); + return NULL; } @@ -517,6 +533,17 @@ break; } thread_count--; + + /* If there's only one other thread, it could be the signal delivery thread, + so we need to notify it to shut down by closing its read pipe. If it's not + the signal delivery thread, then closing the read pipe isn't going to + hurt. + */ + if (thread_count <= 1) + { + scm_i_close_signal_pipe (); + } + scm_i_pthread_mutex_unlock (&thread_admin_mutex); scm_i_pthread_setspecific (scm_i_thread_key, NULL); @@ -882,6 +909,74 @@ } #undef FUNC_NAME +SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0, + (SCM thread), +"Asynchronously force the target @var{thread} to terminate. @var{thread} " +"cannot be the current thread, and if @var{thread} has already terminated or " +"been signaled to terminate, this function is a no-op.") +#define FUNC_NAME s_scm_cancel_thread +{ + scm_i_thread *t = NULL; + + SCM_VALIDATE_THREAD (1, thread); + t = SCM_I_THREAD_DATA (thread); + scm_i_scm_pthread_mutex_lock (&thread_admin_mutex); + if (!t->canceled) + { + t->canceled = 1; + scm_i_pthread_mutex_unlock (&thread_admin_mutex); + scm_i_pthread_cancel (t->pthread); + } + else + { + scm_i_pthread_mutex_unlock (&thread_admin_mutex); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0, + (SCM thread, SCM proc), +"Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. " +"This handler will be called when the thread exits.") +#define FUNC_NAME s_scm_set_thread_cleanup_x +{ + scm_i_thread *t; + + SCM_VALIDATE_THREAD (1, thread); + if (scm_is_true (proc) && scm_is_false (scm_thunk_p (proc))) + { + SCM_MISC_ERROR ("proc must be a thunk", SCM_EOL); + } + + scm_i_pthread_mutex_lock (&thread_admin_mutex); + t = SCM_I_THREAD_DATA (thread); + if (!(t->exited || t->canceled)) + { + t->cleanup_handler = proc; + } + scm_i_pthread_mutex_unlock (&thread_admin_mutex); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_current_thread_cleanup, "thread-cleanup", 1, 0, 0, + (SCM thread), +"Return the cleanup handler installed for the thread @var{thread}.") +#define FUNC_NAME s_scm_current_thread_cleanup +{ + scm_i_thread *t; + SCM ret; + + SCM_VALIDATE_THREAD (1, thread); + scm_i_pthread_mutex_lock (&thread_admin_mutex); + t = SCM_I_THREAD_DATA (thread); + ret = (t->exited || t->canceled) ? SCM_BOOL_F : t->cleanup_handler; + scm_i_pthread_mutex_unlock (&thread_admin_mutex); + return ret; +} +#undef FUNC_NAME + SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, (SCM thread), "Suspend execution of the calling thread until the target @var{thread} " @@ -1539,8 +1634,11 @@ l = &list; for (t = all_threads; t && n > 0; t = t->next_thread) { - SCM_SETCAR (*l, t->handle); - l = SCM_CDRLOC (*l); + if (t != scm_i_signal_delivery_thread) + { + SCM_SETCAR (*l, t->handle); + l = SCM_CDRLOC (*l); + } n--; } *l = SCM_EOL; @@ -1694,6 +1792,7 @@ scm_set_smob_free (scm_tc16_condvar, fat_cond_free); scm_i_default_dynamic_state = SCM_BOOL_F; + scm_i_pthread_setspecific (scm_i_thread_key, SCM_I_CURRENT_THREAD); guilify_self_2 (SCM_BOOL_F); threads_initialized_p = 1; Index: libguile/threads.h =================================================================== RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v retrieving revision 1.48 diff -a -u -r1.48 threads.h --- libguile/threads.h 17 Apr 2006 00:05:42 -0000 1.48 +++ libguile/threads.h 27 Sep 2007 02:20:34 -0000 @@ -49,9 +49,11 @@ SCM handle; scm_i_pthread_t pthread; - + + SCM cleanup_handler; SCM join_queue; SCM result; + int canceled; int exited; SCM sleep_object; @@ -153,6 +155,9 @@ 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); +SCM_API SCM scm_set_thread_cleanup_x (SCM thread, SCM proc); +SCM_API SCM scm_current_thread_cleanup (SCM thread); SCM_API SCM scm_join_thread (SCM t); SCM_API SCM scm_make_mutex (void); Index: test-suite/tests/threads.test =================================================================== RCS file: /sources/guile/guile/guile-core/test-suite/tests/threads.test,v retrieving revision 1.6 diff -a -u -r1.6 threads.test --- test-suite/tests/threads.test 17 Jun 2006 23:08:23 -0000 1.6 +++ test-suite/tests/threads.test 27 Sep 2007 02:20:35 -0000 @@ -133,4 +133,54 @@ (lambda (n) (set! result (cons n result))) (lambda (n) (* 2 n)) '(0 1 2 3 4 5)) - (equal? result '(10 8 6 4 2 0))))))) + (equal? result '(10 8 6 4 2 0))))) + + ;; + ;; thread cancellation + ;; + + (with-test-prefix "cancel-thread" + + (pass-if "cancel succeeds" + (let ((m (make-mutex))) + (lock-mutex m) + (let ((t (begin-thread (begin (lock-mutex m) 'foo)))) + (cancel-thread t) + (join-thread t) + #t))) + + (pass-if "handler result passed to join" + (let ((m (make-mutex))) + (lock-mutex m) + (let ((t (begin-thread (lock-mutex m)))) + (set-thread-cleanup! t (lambda () 'foo)) + (cancel-thread t) + (eq? (join-thread t) 'foo)))) + + (pass-if "can cancel self" + (let ((m (make-mutex))) + (lock-mutex m) + (let ((t (begin-thread (begin + (set-thread-cleanup! (current-thread) + (lambda () 'foo)) + (cancel-thread (current-thread)) + (lock-mutex m))))) + (eq? (join-thread t) 'foo)))) + + (pass-if "handler supplants final expr" + (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread) + (lambda () 'bar)) + 'foo)))) + (eq? (join-thread t) 'bar))) + + (pass-if "remove handler by setting false" + (let ((m (make-mutex))) + (lock-mutex m) + (let ((t (begin-thread (lock-mutex m) 'bar))) + (set-thread-cleanup! t (lambda () 'foo)) + (set-thread-cleanup! t #f) + (unlock-mutex m) + (eq? (join-thread t) 'bar)))) + + (pass-if "initial handler is false" + (not (thread-cleanup (current-thread)))))))