Changes from arch/CVS synchronization

ChangeLog

@@ -1,3 +1,11 @@
+2007-10-20  Ludovic Courtès  <ludo@gnu.org>
+
+	* THANKS: Add Julian.
+
+2007-10-20  Julian Graham  <joolean@gmail.com>
+
+	* NEWS: Mention thread cancellation and cleanup API.
+
 2007-10-17  Ludovic Courtès  <ludo@gnu.org>
 
 	* NEWS: Mention reader bug-fix.

NEWS

@@ -26,6 +26,9 @@ be used for efficiently implementing a Scheme code coverage.
 ** Duplicate bindings among used modules are resolved lazily.
 This slightly improves program startup times.
 
+** New thread cancellation and thread cleanup API
+See `cancel-thread', `set-thread-cleanup!', and `thread-cleanup'.
+
 * Changes to the C interface
 
 ** Functions for handling `scm_option' now no longer require an argument

libguile/ChangeLog

@@ -1,3 +1,42 @@
+2007-10-20  Julian Graham  <joolean@gmail.com>
+
+	Add support for thread cancellation and user-defined thread
+	cleanup handlers.  Small rework by Ludovic Courtès.
+
+	* null-threads.h (scm_i_pthread_cancel,
+	scm_i_pthread_cleanup_push, scm_i_pthread_cleanup_pop): New.
+	* pthread-threads.h (scm_i_pthread_cancel,
+	scm_i_pthread_cleanup_push, scm_i_pthread_cleanup_pop): New.
+	* scmsigs.c (scm_i_signal_delivery_thread,
+	signal_delivery_thread_mutex): New.
+	(signal_delivery_thread): Leave when `read_without_guile ()'
+	returns zero.
+	(start_signal_delivery_thread): Acquire SIGNAL_DELIVERY_THREAD
+	before spawning the thread.  Initialize
+	SCM_I_SIGNAL_DELIVERY_THREAD.
+	(ensure_signal_delivery_thread): Renamed to...
+	(scm_i_ensure_signal_delivery_thread): this.
+	(scm_i_close_signal_pipe): New.
+	* scmsigs.h: Updated.
+	* threads.c (thread_mark): Mark `t->cleanup_handler'.
+	(guilify_self_1): Initialize `t->cleanup_handler' and
+	`t->canceled'.
+	(do_thread_exit): Invoke `t->cleanup_handler'.
+	(on_thread_exit): Call `scm_i_ensure_signal_delivery_thread ()'.
+	Call `scm_i_close_signal_pipe ()' when the next-to-last thread
+	vanishes.
+	(scm_leave_guile_cleanup): New.
+	(scm_i_with_guile_and_parent): Use `scm_i_pthread_cleanup_push ()' 
+	and `scm_leave_guile_cleanup ()' to leave guile mode, rather
+	than call `scm_leave_guile ()' after FUNC.
+	(scm_cancel_thread, scm_set_thread_cleanup_x,
+	scm_threads_cleanup): New.
+	(scm_all_threads): Remove SCM_I_SIGNAL_DELIVERY_THREAD from the
+	returned list.
+	* threads.h (scm_i_thread)[cleanup_handler, canceled]: New
+	fields.
+	Add declarations of new functions.
+	
 2007-10-17  Ludovic Courtès  <ludo@gnu.org>
 
 	* read.c (CHAR_IS_BLANK_): Add `\r' (ASCII 0x0d).  This fixes a

libguile/null-threads.h

@@ -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

libguile/pthread-threads.h

@@ -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

libguile/scmsigs.c

@@ -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,14 @@ static SCM *signal_handlers;
 static SCM signal_handler_asyncs;
 static SCM signal_handler_threads;
 
+/* The signal delivery thread.  */
+scm_i_thread *scm_i_signal_delivery_thread = NULL;
+
+/* The mutex held when launching the signal delivery thread.  */
+static scm_i_pthread_mutex_t signal_delivery_thread_mutex =
+  SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+
 /* 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,24 +194,34 @@ signal_delivery_thread (void *data)
 	  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 signal_thread;
+
+  scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex);
+
   if (pipe (signal_pipe) != 0)
     scm_syserror (NULL);
-  scm_spawn_thread (signal_delivery_thread, NULL,
+  signal_thread = scm_spawn_thread (signal_delivery_thread, NULL,
-		    scm_handle_by_message, "signal delivery thread");
+				    scm_handle_by_message,
+				    "signal delivery thread");
+  scm_i_signal_delivery_thread = SCM_I_THREAD_DATA (signal_thread);
+
+  scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
 }
 
-static void
+void
-ensure_signal_delivery_thread ()
+scm_i_ensure_signal_delivery_thread ()
 {
   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
   scm_i_pthread_once (&once, start_signal_delivery_thread);
@@ -228,8 +247,8 @@ take_signal (int signum)
 #endif
 }
 
-static void
+void
-ensure_signal_delivery_thread ()
+scm_i_ensure_signal_delivery_thread ()
 {
   return;
 }
@@ -332,7 +351,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
 	SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
     }
 
-  ensure_signal_delivery_thread ();
+  scm_i_ensure_signal_delivery_thread ();
 
   SCM_CRITICAL_SECTION_START;
   old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
@@ -652,6 +671,21 @@ SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
 
 
 
+void
+scm_i_close_signal_pipe()
+{
+  /* SIGNAL_DELIVERY_THREAD_MUTEX is only 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 ()
 {

libguile/scmsigs.h

@@ -3,7 +3,7 @@
 #ifndef SCM_SCMSIGS_H
 #define SCM_SCMSIGS_H
 
-/* Copyright (C) 1995,1996,1997,1998,2000, 2002, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000, 2002, 2006, 2007 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -23,6 +23,7 @@
 
 
 #include "libguile/__scm.h"
+#include "libguile/threads.h"
 
 
 
@@ -41,6 +42,11 @@ SCM_API SCM scm_usleep (SCM i);
 SCM_API SCM scm_raise (SCM sig);
 SCM_API void scm_init_scmsigs (void);
 
+SCM_API void scm_i_close_signal_pipe (void);
+SCM_API void scm_i_ensure_signal_delivery_thread (void);
+
+SCM_API scm_i_thread *scm_i_signal_delivery_thread;
+
 #endif  /* SCM_SCMSIGS_H */
 
 /*

libguile/threads.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -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 @@ thread_mark (SCM obj)
 {
   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);
@@ -415,6 +417,7 @@ guilify_self_1 (SCM_STACKITEM *base)
   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 +437,7 @@ guilify_self_1 (SCM_STACKITEM *base)
   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 +482,17 @@ guilify_self_2 (SCM parent)
 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 +503,7 @@ do_thread_exit (void *v)
     ;
 
   scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
   return NULL;
 }
 
@@ -496,10 +511,14 @@ static void
 on_thread_exit (void *v)
 {
   /* This handler is executed in non-guile mode.  */
-  scm_i_thread *t = (scm_i_thread *)v, **tp;
+  scm_i_thread *t = (scm_i_thread *) v, **tp;
 
   scm_i_pthread_setspecific (scm_i_thread_key, v);
 
+  /* Ensure the signal handling thread has been launched, because we might be
+     shutting it down.  */
+  scm_i_ensure_signal_delivery_thread ();
+
   /* Unblocking the joining threads needs to happen in guile mode
      since the queue is a SCM data structure.  */
   scm_with_guile (do_thread_exit, v);
@@ -515,6 +534,14 @@ on_thread_exit (void *v)
 	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);
@@ -684,17 +711,30 @@ scm_with_guile (void *(*func)(void *), void *data)
 				      scm_i_default_dynamic_state);
 }
 
+static void
+scm_leave_guile_cleanup (void *x)
+{
+  scm_leave_guile ();
+}
+
 void *
-scm_i_with_guile_and_parent (void *(*func)(void *), void *data,
+scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
-			     SCM parent)
 {
   void *res;
   int really_entered;
   SCM_STACKITEM base_item;
+
   really_entered = scm_i_init_thread_for_guile (&base_item, parent);
-  res = scm_c_with_continuation_barrier (func, data);
   if (really_entered)
-    scm_leave_guile ();
+    {
+      scm_i_pthread_cleanup_push (scm_leave_guile_cleanup, NULL);
+      res = scm_c_with_continuation_barrier (func, data);
+      scm_i_pthread_cleanup_pop (0);
+      scm_leave_guile ();
+    }
+  else 
+    res = scm_c_with_continuation_barrier (func, data);
+
   return res;
 }
 
@@ -880,6 +920,74 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0,
 }
 #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_false (proc))
+    SCM_VALIDATE_THUNK (2, proc);
+
+  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_thread_cleanup, "thread-cleanup", 1, 0, 0,
+	    (SCM thread),
+"Return the cleanup handler installed for the thread @var{thread}.")
+#define FUNC_NAME s_scm_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} "
@@ -891,7 +999,7 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
 
   SCM_VALIDATE_THREAD (1, thread);
   if (scm_is_eq (scm_current_thread (), thread))
-    SCM_MISC_ERROR ("can not join the current thread", SCM_EOL);
+    SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL);
 
   scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
 
@@ -911,10 +1019,13 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
   res = t->result;
 
   scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
   return res;
 }
 #undef FUNC_NAME
 
+
+
 /*** Fat mutexes */
 
 /* We implement our own mutex type since we want them to be 'fair', we
@@ -1537,8 +1648,11 @@ SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
   l = &list;
   for (t = all_threads; t && n > 0; t = t->next_thread)
     {
-      SCM_SETCAR (*l, t->handle);
+      if (t != scm_i_signal_delivery_thread)
-      l = SCM_CDRLOC (*l);
+	{
+	  SCM_SETCAR (*l, t->handle);
+	  l = SCM_CDRLOC (*l);
+	}
       n--;
     }
   *l = SCM_EOL;

libguile/threads.h

@@ -3,7 +3,7 @@
 #ifndef SCM_THREADS_H
 #define SCM_THREADS_H
 
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -49,9 +49,11 @@ typedef struct scm_i_thread {
 
   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 @@ do { \
 
 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_thread_cleanup (SCM thread);
 SCM_API SCM scm_join_thread (SCM t);
 
 SCM_API SCM scm_make_mutex (void);

test-suite/ChangeLog

@@ -1,3 +1,10 @@
+2007-10-20  Julian Graham  <joolean@gmail.com>
+
+	* tests/threads.test: Use proper `define-module'.
+	(cancel-thread, handler result passed to join, can cancel self,
+	handler supplants final expr, remove handler by setting false,
+	initial handler is false): New tests.
+
 2007-10-17  Ludovic Courtès  <ludo@gnu.org>
 
 	* tests/reader.test (reading)[CR recognized as a token

test-suite/tests/threads.test

@@ -1,6 +1,6 @@
 ;;;; threads.test --- Tests for Guile threading.    -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -17,8 +17,10 @@
 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 ;;;; Boston, MA 02110-1301 USA
 
-(use-modules (ice-9 threads)
+(define-module (test-threads)
-	     (test-suite lib))
+  :use-module (ice-9 threads)
+  :use-module (test-suite lib))
+
 
 (if (provided? 'threads)
     (begin
@@ -133,4 +135,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)))))))