Re: thread cancellation, take 2

["Julian Graham" <joolean@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1588 bytes --]

On 9/26/07, Ludovic Courtès <ludovic.courtes@laas.fr> wrote:

> Anyway, as long as you have a reference to an object (including a thread
> object), you can use the relevant procedures to mutate it.  For
> instance, if my code passes a list to yours, I have no guarantee that
> your code won't call `set-car!' on it.
>
> Just to say that hiding the data doesn't solve this authorization
> problem, it just makes it less visible.
>
> Beside, it may be useful in some cases to assign a thread finalizer from
> outside the thread itself.

Okay.  Here's the latest revision of the patch:

* Changed the API as Ludovic suggests above -- push-thread-cleanup and
pop-thread-cleanup are now, respectively, set-thread-cleanup! and
thread-cleanup, and you can set and get to / from whatever thread you
want.

* Updated threads.test.

* Modified the behavior of cancel-thread to allow for canceling the
current thread.  This necessitated some changes to scmsigs, so that
the signal delivery thread could be notified to shut down -- not
cleanly closing the signal pipe was leaving the process in a zombie
state -- specifically, the addition of an extra mutex and a function
in scmsigs.c. Let me know if this is too sloppy; rationale is provided
in the comments.

* Also (I realize this is a bit unrelated) changed the behavior of
all-threads so that it doesn't include the signal delivery thread,
because nobody has any business messing with it. Exposed a pointer to
the delivery thread from of scmsigs.o. I hope this isn't too sloppy,
either.


Regards,
Julian

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: thread-cancellation.HEAD.patch --]
[-- Type: text/x-patch; name="thread-cancellation.HEAD.patch", Size: 12837 bytes --]

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 @@
 \f
 
 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)))))))

[-- Attachment #3: Type: text/plain, Size: 143 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel