Index: guile-core/libguile/Makefile.am =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/Makefile.am,v retrieving revision 1.195 diff -a -u -r1.195 Makefile.am --- guile-core/libguile/Makefile.am 24 Sep 2004 02:12:09 -0000 1.195 +++ guile-core/libguile/Makefile.am 7 Nov 2004 02:43:34 -0000 @@ -104,10 +104,11 @@ lang.c list.c \ load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \ options.c pairs.c ports.c print.c procprop.c procs.c properties.c \ - random.c rdelim.c read.c root.c rw.c scmsigs.c script.c simpos.c smob.c \ - sort.c srcprop.c stackchk.c stacks.c stime.c strings.c srfi-13.c srfi-14.c \ - strorder.c strports.c struct.c symbols.c threads.c throw.c values.c \ - variable.c vectors.c version.c vports.c weaks.c + pthread-threads.c random.c rdelim.c read.c root.c rw.c scmsigs.c \ + script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c stime.c \ + strings.c srfi-13.c srfi-14.c strorder.c strports.c struct.c symbols.c \ + threads.c threads-plugin.c throw.c values.c variable.c vectors.c \ + version.c vports.c weaks.c DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ @@ -208,12 +209,10 @@ # and people feel like maintaining them. For now, this is not the case. noinst_SCRIPTS = guile-doc-snarf guile-snarf-docs guile-func-name-check -EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ - ChangeLog-1996-1999 ChangeLog-2000 cpp_signal.c \ - cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ - cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ - c-tokenize.lex threads-plugin.c version.h.in pthread-threads.c \ - scmconfig.h.top gettext.h +EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads ChangeLog-1996-1999 \ + ChangeLog-2000 cpp_signal.c cpp_errno.c cpp_err_symbols.in \ + cpp_err_symbols.c cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ + c-tokenize.lex version.h.in scmconfig.h.top gettext.h # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi Index: guile-core/libguile/pthread-threads.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/pthread-threads.c,v retrieving revision 1.9 diff -a -u -r1.9 pthread-threads.c --- guile-core/libguile/pthread-threads.c 5 Apr 2003 19:10:22 -0000 1.9 +++ guile-core/libguile/pthread-threads.c 7 Nov 2004 02:43:39 -0000 @@ -22,7 +22,9 @@ # include #endif -#include "libguile/scmconfig.h" +#include "pthread-threads.h" +#include "scmconfig.h" +#include "threads-plugin.h" /* Should go to threads-plugin */ scm_t_mutexattr scm_i_plugin_mutex; Index: guile-core/libguile/pthread-threads.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/pthread-threads.h,v retrieving revision 1.9 diff -a -u -r1.9 pthread-threads.h --- guile-core/libguile/pthread-threads.h 5 Apr 2003 19:10:22 -0000 1.9 +++ guile-core/libguile/pthread-threads.h 7 Nov 2004 02:43:40 -0000 @@ -46,6 +46,15 @@ #define scm_i_plugin_thread_detach pthread_detach #define scm_i_plugin_thread_self pthread_self #define scm_i_plugin_thread_yield sched_yield +#define scm_i_plugin_thread_equal pthread_equal + +/* N.B.: pthread_cleanup_push and _pop are macros! */ +#define scm_i_plugin_thread_cancel pthread_cancel +#define scm_i_plugin_thread_cleanup_push pthread_cleanup_push +#define scm_i_plugin_thread_cleanup_pop pthread_cleanup_pop +#define scm_i_plugin_thread_setcancelstate pthread_setcancelstate +#define SCM_THREAD_CANCEL_ENABLE PTHREAD_CANCEL_ENABLE +#define SCM_THREAD_CANCEL_DISABLE PTHREAD_CANCEL_DISABLE extern scm_t_mutexattr scm_i_plugin_mutex; /* The "fast" mutex. */ Index: guile-core/libguile/threads-plugin.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/threads-plugin.c,v retrieving revision 1.4 diff -a -u -r1.4 threads-plugin.c --- guile-core/libguile/threads-plugin.c 5 Apr 2003 19:10:22 -0000 1.4 +++ guile-core/libguile/threads-plugin.c 7 Nov 2004 02:43:40 -0000 @@ -22,6 +22,12 @@ # include #endif +#include +#include + +#include "pthread-threads.h" +#include "threads.h" + int scm_i_plugin_mutex_size = 0; int (*scm_i_plugin_mutex_init) (scm_t_mutex *, const scm_t_mutexattr *); int (*scm_i_plugin_mutex_lock) (scm_t_mutex *); Index: guile-core/libguile/threads-plugin.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/threads-plugin.h,v retrieving revision 1.5 diff -a -u -r1.5 threads-plugin.h --- guile-core/libguile/threads-plugin.h 27 Apr 2004 22:59:04 -0000 1.5 +++ guile-core/libguile/threads-plugin.h 7 Nov 2004 02:43:40 -0000 @@ -21,7 +21,8 @@ */ -#include /* This file should *not* need to include pthread.h */ + +#include "scmconfig.h" /* Size is checked in scm_init_threads_plugin. For reference, sizes encountered include, @@ -59,6 +60,7 @@ extern scm_t_rec_mutex_trylock scm_i_plugin_rec_mutex_trylock; extern scm_t_rec_mutex_unlock scm_i_plugin_rec_mutex_unlock; + /*fixme*/ #define scm_t_cond pthread_cond_t Index: guile-core/libguile/threads.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/threads.c,v retrieving revision 1.68 diff -a -u -r1.68 threads.c --- guile-core/libguile/threads.c 22 Sep 2004 17:41:37 -0000 1.68 +++ guile-core/libguile/threads.c 7 Nov 2004 02:43:43 -0000 @@ -33,6 +33,8 @@ #include #endif +#include + #include "libguile/validate.h" #include "libguile/root.h" #include "libguile/eval.h" @@ -114,6 +116,7 @@ scm_root_state *root; SCM handle; scm_t_thread thread; + SCM cleanup_handlers; SCM result; int exited; @@ -133,6 +136,7 @@ t = SCM_THREAD_DATA (z); t->handle = z; t->result = creation_protects; + t->cleanup_handlers = SCM_EOL; t->base = NULL; scm_i_plugin_cond_init (&t->sleep_cond, 0); scm_i_plugin_mutex_init (&t->heap_mutex, &scm_i_plugin_mutex); @@ -156,6 +160,7 @@ { scm_thread *t = SCM_THREAD_DATA (obj); scm_gc_mark (t->result); + scm_gc_mark (t->cleanup_handlers); return t->root->handle; /* mark root-state of this thread */ } @@ -285,6 +290,26 @@ void *handler_data; } launch_data; +static void +handler_cancellation (scm_thread* thread) +{ + while (!scm_is_eq(scm_length(thread->cleanup_handlers), SCM_INUM0)) { + thread->result = scm_i_eval + (SCM_CAR(thread->cleanup_handlers), scm_current_module()); + thread->cleanup_handlers = SCM_CDR(thread->cleanup_handlers); + } + + scm_i_plugin_mutex_lock (&thread_admin_mutex); + scm_i_leave_guile(); + + all_threads = scm_delq_x (thread->handle, all_threads); + thread->exited = 1; + thread_count--; + scm_thread_detach (thread->thread); + scm_i_plugin_mutex_unlock (&thread_admin_mutex); + return; +} + static SCM body_bootstrip (launch_data* data) { @@ -315,11 +340,16 @@ init_thread_creatant (thread, base); /* must own the heap */ data->rootcont = SCM_BOOL_F; + + scm_i_plugin_thread_cleanup_push + ((void (*) (void *)) handler_cancellation, (void *) t); t->result = scm_internal_cwdr ((scm_t_catch_body) body_bootstrip, data, (scm_t_catch_handler) handler_bootstrip, data, base); + scm_i_plugin_thread_cleanup_pop(0); + scm_i_leave_guile (); /* release the heap */ free (data); @@ -370,7 +400,9 @@ data->body_data = body_data; data->handler = handler; data->handler_data = handler_data; + t = SCM_THREAD_DATA (thread); + /* must initialize root state pointer before the thread is linked into all_threads */ t->root = SCM_ROOT_STATE (root); @@ -471,11 +503,77 @@ scm_i_enter_guile (c); } res = t->result; - t->result = SCM_BOOL_F; + /* t->result = SCM_BOOL_F; */ return res; } #undef FUNC_NAME +SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0, + (SCM thread), +"Force the target @var{thread} to terminate, causing all of its " +"currently registered cleanup handlers to be called.") +#define FUNC_NAME s_scm_cancel_thread +{ + scm_thread *t = SCM_THREAD_DATA (thread); + if (scm_is_eq(scm_member(t->handle, all_threads), SCM_BOOL_F)) { + return SCM_BOOL_F; + } + + if (!t->exited) + { + scm_thread *c = scm_i_leave_guile (); + while (!THREAD_INITIALIZED_P (t)) { + scm_i_plugin_thread_yield (); + } + scm_i_enter_guile (c); + scm_thread_cancel (t->thread); + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_push_thread_cleanup, "push-thread-cleanup", 1, 0, 0, + (SCM expr), +"Add an expression @var{expr} to the front of the list of cleanup " +"handlers for the current thread. These handlers will be evaluated " +"in a LIFO manner if the current thread is cancelled by another " +"Scheme thread or by C code, via scm_c_thread_cancel().") +#define FUNC_NAME s_scm_push_thread_cleanup +{ + scm_thread *t = SCM_CURRENT_THREAD; + if (scm_is_eq(scm_member(t->handle, all_threads), SCM_BOOL_F)) { + return SCM_BOOL_F; + } + t->cleanup_handlers = scm_cons(expr, t->cleanup_handlers); + return SCM_BOOL_T; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_pop_thread_cleanup, "pop-thread-cleanup", 0, 1, 0, + (SCM exec), +"Remove the most recently added cleanup handler expression from the " +"current thread's queue of cleanup handlers. If a boolean expression " +"@var{exec} is provided and is true, the cleanup handler will be " +"evaluated as it is removed.") +#define FUNC_NAME s_scm_pop_thread_cleanup +{ + scm_thread *t = SCM_CURRENT_THREAD; + if (scm_is_eq(scm_member(t->handle, all_threads), SCM_BOOL_F)) { + return SCM_BOOL_F; + } + + SCM result = SCM_EOL; + if (t->cleanup_handlers != SCM_EOL) { + SCM expr = SCM_CAR(t->cleanup_handlers); + t->cleanup_handlers = SCM_CDR(t->cleanup_handlers); + if (scm_is_true(exec)) { + result = scm_i_eval(expr, scm_current_module()); + } + } + return result; +} +#undef FUNC_NAME + /*** Fair mutexes */ /* We implement our own mutex type since we want them to be 'fair', we @@ -1098,6 +1196,48 @@ return tv.tv_sec; } +/* Thread cleanup handler pushing and popping functions. These are + the same for all threading libraries, because they operate on + Guile's internal representation of the thread, not the threading + library's. */ + +static scm_thread* +scm_t_thread_to_scm_thread(scm_t_thread* needle) { + scm_thread* ret = NULL; + SCM all_threads = scm_all_threads(); + while(!scm_is_eq(all_threads, SCM_EOL)) { + SCM single_thread = scm_car(all_threads); + if (scm_i_plugin_thread_equal(scm_c_scm2thread(single_thread), *needle)) { + ret = SCM_THREAD_DATA(single_thread); + break; + } + all_threads = scm_cdr(all_threads); + } + return ret; +} + +SCM +scm_internal_thread_cleanup_push(scm_t_thread* thread, SCM expr) +{ + scm_thread* t = scm_t_thread_to_scm_thread(thread); + if (t != NULL) + t->cleanup_handlers = scm_cons(expr, t->cleanup_handlers); + return SCM_EOL; +} + +SCM +scm_internal_thread_cleanup_pop(scm_t_thread* thread, int exec) +{ + SCM ret = SCM_EOL; + scm_thread* t = scm_t_thread_to_scm_thread(thread); + if ((t != NULL) && (!scm_is_eq(t->cleanup_handlers, SCM_EOL))) { + SCM expr = scm_car(t->cleanup_handlers); + t->cleanup_handlers = scm_cdr(t->cleanup_handlers); + if (exec) ret = scm_eval(expr, t->root->handle); + } + return ret; +} + /*** Misc */ SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0, @@ -1217,9 +1357,9 @@ scm_t_rec_mutex scm_i_defer_mutex; #if SCM_USE_PTHREAD_THREADS -# include "libguile/pthread-threads.c" +#include "libguile/pthread-threads.h" #endif -#include "libguile/threads-plugin.c" +#include "libguile/threads-plugin.h" /*** Initialization */ Index: guile-core/libguile/threads.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/threads.h,v retrieving revision 1.38 diff -a -u -r1.38 threads.h --- guile-core/libguile/threads.h 23 Jul 2004 23:51:58 -0000 1.38 +++ guile-core/libguile/threads.h 7 Nov 2004 02:43:44 -0000 @@ -64,9 +64,9 @@ SCM_API void scm_init_thread_procs (void); #if SCM_USE_PTHREAD_THREADS -# include "libguile/pthread-threads.h" +#include "libguile/pthread-threads.h" #else -# include "libguile/null-threads.h" +#include "libguile/null-threads.h" #endif /*----------------------------------------------------------------------*/ @@ -97,6 +97,14 @@ #define scm_thread_detach scm_i_plugin_thread_detach #define scm_thread_self scm_i_plugin_thread_self #define scm_thread_yield scm_i_plugin_thread_yield +#define scm_thread_cancel scm_i_plugin_thread_cancel +#define scm_thread_setcancelstate scm_i_plugin_thread_setcancelstate +/* N.B.: scm_i_plugin_thread_cleanup_push and _pop are defined, + but we don't use them here because of the way certain thread libraries + implement them; the ones here use a mechanism built into thread creation + from thread.c... */ +#define scm_thread_cleanup_push scm_internal_thread_cleanup_push +#define scm_thread_cleanup_pop scm_internal_thread_cleanup_pop #define scm_mutex_init scm_i_plugin_mutex_init #define scm_mutex_destroy scm_i_plugin_mutex_destroy @@ -165,6 +173,9 @@ SCM_API unsigned long scm_thread_sleep (unsigned long); SCM_API unsigned long scm_thread_usleep (unsigned long); +SCM_API SCM scm_internal_thread_cleanup_push(scm_t_thread*, SCM); +SCM_API SCM scm_internal_thread_cleanup_pop(scm_t_thread*, int); + /* End of low-level C API */ /*----------------------------------------------------------------------*/ @@ -210,6 +221,9 @@ SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler); SCM_API SCM scm_yield (void); SCM_API SCM scm_join_thread (SCM t); +SCM_API SCM scm_cancel_thread (SCM t); +SCM_API SCM scm_push_thread_cleanup (SCM expr); +SCM_API SCM scm_pop_thread_cleanup (SCM exec); SCM_API SCM scm_make_mutex (void); SCM_API SCM scm_make_fair_mutex (void); SCM_API SCM scm_lock_mutex (SCM m);