? thread-cancellation.HEAD.patch
Index: null-threads.h
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/null-threads.h,v
retrieving revision 1.12
diff -u -r1.12 null-threads.h
--- null-threads.h	17 Apr 2006 00:05:40 -0000	1.12
+++ null-threads.h	23 Sep 2007 04:57:27 -0000
@@ -41,6 +41,7 @@
 #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_sched_yield()                 0
 
 /* Signals
Index: pthread-threads.h
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/pthread-threads.h,v
retrieving revision 1.15
diff -u -r1.15 pthread-threads.h
--- pthread-threads.h	9 Oct 2006 23:21:00 -0000	1.15
+++ pthread-threads.h	23 Sep 2007 04:57:27 -0000
@@ -35,6 +35,7 @@
 #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_sched_yield                   sched_yield
 
 /* Signals
Index: threads.c
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.c,v
retrieving revision 1.88
diff -u -r1.88 threads.c
--- threads.c	15 Jan 2007 23:35:34 -0000	1.88
+++ threads.c	23 Sep 2007 04:57:31 -0000
@@ -131,6 +131,7 @@
 {
   scm_i_thread *t = SCM_I_THREAD_DATA (obj);
   scm_gc_mark (t->result);
+  scm_gc_mark (t->cleanup_handlers);
   scm_gc_mark (t->join_queue);
   scm_gc_mark (t->dynwinds);
   scm_gc_mark (t->active_asyncs);
@@ -415,6 +416,7 @@
   t->pthread = scm_i_pthread_self ();
   t->handle = SCM_BOOL_F;
   t->result = SCM_BOOL_F;
+  t->cleanup_handlers = SCM_EOL;
   t->join_queue = SCM_EOL;
   t->dynamic_state = SCM_BOOL_F;
   t->dynwinds = SCM_EOL;
@@ -434,6 +436,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;
@@ -473,12 +476,32 @@
   t->block_asyncs = 0;
 }
 
+static SCM handle_cleanup_handler(void *cont, SCM tag, SCM args) {
+  *((int *) cont) = 0;
+  return scm_handle_by_message_noexit(NULL, tag, args);
+  return SCM_UNDEFINED;
+}
+
 /* Perform thread tear-down, in guile mode.
  */
 static void *
 do_thread_exit (void *v)
 {
-  scm_i_thread *t = (scm_i_thread *)v;
+  scm_i_thread *t = (scm_i_thread *) v;
+
+  while(!scm_is_eq(t->cleanup_handlers, SCM_EOL)) 
+    {
+      int cont = 1;
+      SCM ptr = SCM_CAR(t->cleanup_handlers);
+      t->cleanup_handlers = SCM_CDR(t->cleanup_handlers);
+      t->result = scm_internal_catch (SCM_BOOL_T, 
+				      (scm_t_catch_body) scm_call_0, ptr, 
+				      handle_cleanup_handler, &cont);
+      if (!cont)
+	{
+	  break;
+	}
+    }
 
   scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
 
@@ -489,6 +512,7 @@
     ;
 
   scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
   return NULL;
 }
 
@@ -882,6 +906,78 @@
 }
 #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);
+  if (t == SCM_I_CURRENT_THREAD)
+    {
+      SCM_MISC_ERROR ("cannot cancel the current thread", SCM_EOL);
+    }
+  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  if (!t->canceled)
+    {
+      t->canceled = 1;
+      scm_i_pthread_cancel(t->pthread);
+    }
+  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_push_thread_cleanup, "push-thread-cleanup", 1, 0, 0,
+	    (SCM proc),
+"Add the thunk @var{proc} to the front of the list of cleanup handlers for "
+"the current thread. These handlers will be called in a LIFO manner when the "
+"current thread exits.")
+#define FUNC_NAME s_scm_push_thread_cleanup
+{
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+  if (!scm_is_eq (scm_thunk_p (proc), SCM_BOOL_T))
+    {
+      SCM_MISC_ERROR ("proc must be a thunk", SCM_EOL);
+    }
+  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  thread->cleanup_handlers = scm_cons (proc, thread->cleanup_handlers);
+  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_pop_thread_cleanup, "pop-thread-cleanup", 0, 1, 0,
+	    (SCM evalp),
+"Remove the most recently added cleanup handler from the current thread's "
+"list of cleanup handlers. If @car{evalp} is specified and evaluates to "
+"true, the cleanup handler will be called as it is removed.")
+#define FUNC_NAME s_scm_pop_thread_cleanup
+{
+  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+  scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+  if (!scm_is_eq (thread->cleanup_handlers, SCM_EOL))
+    {
+      SCM ret = SCM_BOOL_T;
+      SCM ptr = SCM_CAR (thread->cleanup_handlers);
+      thread->cleanup_handlers = SCM_CDR (thread->cleanup_handlers);
+      scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+      if (!scm_is_eq (evalp, SCM_BOOL_F))
+	{
+	  ret = scm_call_0 (ptr);
+	}
+      thread->cleanup_handlers = SCM_CDR (thread->cleanup_handlers);
+      return ret;
+    }
+  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+  return SCM_BOOL_F;
+}
+#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} "
Index: threads.h
===================================================================
RCS file: /sources/guile/guile/guile-core/libguile/threads.h,v
retrieving revision 1.48
diff -u -r1.48 threads.h
--- threads.h	17 Apr 2006 00:05:42 -0000	1.48
+++ threads.h	23 Sep 2007 04:57:31 -0000
@@ -49,9 +49,11 @@
 
   SCM handle;
   scm_i_pthread_t pthread;
-  
+
+  SCM cleanup_handlers;
   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_push_thread_cleanup (SCM thunk);
+SCM_API SCM scm_pop_thread_cleanup (SCM evalp);
 SCM_API SCM scm_join_thread (SCM t);
 
 SCM_API SCM scm_make_mutex (void);