cancel-thread via asyncs, not pthread_cancel

* module/ice-9/threads.scm (cancel-tag): New variable.
  (cancel-thread): New Scheme function.
  (call-with-new-thread): Install a prompt around the thread.
* libguile/threads.h (scm_i_thread): Remove cancelled member.
* libguile/threads.c (scm_cancel_thread): Call out to Scheme.  Always
  available, and works on the current thread too.
  (scm_set_thread_cleanup_x, scm_thread_cleanup): Adapt.
  (scm_init_ice_9_threads): Capture cancel-thread var.
* doc/ref/api-scheduling.texi (Threads): Update.
* NEWS: Update.

5 files changed, 45 insertions, 44 deletions

diff --git a/NEWS b/NEWS
index 0702eb294..06f2e8c30 100644
--- a/NEWS
+++ b/NEWS
@@ -38,6 +38,9 @@ trivial unused data structure.  Now that we have deprecated the old
 only refer to "asyncs".
 
 * Bug fixes
+** cancel-thread uses asynchronous interrupts, not pthread_cancel
+
+See "Asyncs" in the manual, for more on asynchronous interrupts.
 
 
 Previous changes in 2.1.x (changes since the 2.0.x series):
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index 551b3fb38..45b5315ce 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -114,17 +114,14 @@ immediate context switch to one of them. Otherwise, yield has no effect.
 
 @deffn {Scheme Procedure} cancel-thread thread
 @deffnx {C Function} scm_cancel_thread (thread)
-Asynchronously notify @var{thread} to exit.  Immediately after
-receiving this notification, @var{thread} will call its cleanup handler
-(if one has been set) and then terminate, aborting any evaluation that
-is in progress.
-
-Because Guile threads are isomorphic with POSIX threads, @var{thread}
-will not receive its cancellation signal until it reaches a cancellation
-point.  See your operating system's POSIX threading documentation for
-more information on cancellation points; note that in Guile, unlike
-native POSIX threads, a thread can receive a cancellation notification
-while attempting to lock a mutex.
+Asynchronously interrupt @var{thread} and ask it to terminate.
+@code{dynamic-wind} post thunks will run, but throw handlers will not.
+If @var{thread} has already terminated or been signaled to terminate,
+this function is a no-op.
+
+Under this hood, thread cancellation uses @code{system-async-mark} and
+@code{abort-to-prompt}.  @xref{Asyncs} for more on asynchronous
+interrupts.
 @end deffn
 
 @deffn {Scheme Procedure} set-thread-cleanup! thread proc
diff --git a/libguile/threads.c b/libguile/threads.c
index 2a315e472..8ac0832c5 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -438,7 +438,6 @@ guilify_self_1 (struct GC_stack_base *base)
     abort ();
 
   scm_i_pthread_mutex_init (&t.admin_mutex, NULL);
-  t.canceled = 0;
   t.exited = 0;
   t.guile_mode = 0;
 
@@ -1012,34 +1011,14 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0,
 /* Some systems, notably Android, lack 'pthread_cancel'.  Don't provide
    'cancel-thread' on these systems.  */
 
-#if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL
+static SCM cancel_thread_var;
 
-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
+scm_cancel_thread (SCM thread)
 {
-  scm_i_thread *t = NULL;
-
-  SCM_VALIDATE_THREAD (1, thread);
-  t = SCM_I_THREAD_DATA (thread);
-  scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
-  if (!t->canceled)
-    {
-      t->canceled = 1;
-      scm_i_pthread_mutex_unlock (&t->admin_mutex);
-      scm_i_pthread_cancel (t->pthread);
-    }
-  else
-    scm_i_pthread_mutex_unlock (&t->admin_mutex);
-
+  scm_call_1 (scm_variable_ref (cancel_thread_var), thread);
   return SCM_UNSPECIFIED;
 }
-#undef FUNC_NAME
-
-#endif
 
 SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0,
 	    (SCM thread, SCM proc),
@@ -1056,7 +1035,7 @@ SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0,
   t = SCM_I_THREAD_DATA (thread);
   scm_i_pthread_mutex_lock (&t->admin_mutex);
 
-  if (!(t->exited || t->canceled))
+  if (!t->exited)
     t->cleanup_handler = proc;
 
   scm_i_pthread_mutex_unlock (&t->admin_mutex);
@@ -1077,7 +1056,7 @@ SCM_DEFINE (scm_thread_cleanup, "thread-cleanup", 1, 0, 0,
 
   t = SCM_I_THREAD_DATA (thread);
   scm_i_pthread_mutex_lock (&t->admin_mutex);
-  ret = (t->exited || t->canceled) ? SCM_BOOL_F : t->cleanup_handler;
+  ret = t->exited ? SCM_BOOL_F : t->cleanup_handler;
   scm_i_pthread_mutex_unlock (&t->admin_mutex);
 
   return ret;
@@ -2073,6 +2052,9 @@ scm_init_ice_9_threads (void *unused)
 {
 #include "libguile/threads.x"
 
+  cancel_thread_var =
+    scm_module_variable (scm_current_module (),
+                         scm_from_latin1_symbol ("cancel-thread"));
   call_with_new_thread_var =
     scm_module_variable (scm_current_module (),
                          scm_from_latin1_symbol ("call-with-new-thread"));
diff --git a/libguile/threads.h b/libguile/threads.h
index 241907db2..90bb66163 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -68,7 +68,6 @@ typedef struct scm_i_thread {
   scm_i_pthread_mutex_t *held_mutex;
 
   SCM result;
-  int canceled;
   int exited;
 
   /* Boolean indicating whether the thread is in guile mode.  */
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index f0f08e012..4b2f6c6eb 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -31,6 +31,7 @@
 
 (define-module (ice-9 threads)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 control)
   ;; These bindings are marked as #:replace because when deprecated code
   ;; is enabled, (ice-9 deprecated) also exports these names.
   ;; (Referencing one of the deprecated names prints a warning directing
@@ -86,6 +87,21 @@
 
 
 
+(define cancel-tag (make-prompt-tag "cancel"))
+(define (cancel-thread thread)
+  "Asynchronously interrupt the target @var{thread} and ask it to
+terminate.  @code{dynamic-wind} post thunks will run, but throw handlers
+will not.  If @var{thread} has already terminated or been signaled to
+terminate, this function is a no-op."
+  (system-async-mark
+   (lambda ()
+     (catch #t
+       (lambda ()
+         (abort-to-prompt cancel-tag))
+       (lambda _
+         (error "thread cancellation failed, throwing error instead???"))))
+   thread))
+
 (define* (call-with-new-thread thunk #:optional handler)
   "Call @code{thunk} in a new thread and with a new dynamic state,
 returning a new thread object representing the thread.  The procedure
@@ -106,11 +122,15 @@ Once @var{thunk} or @var{handler} returns, the return value is made the
     (with-mutex mutex
       (%call-with-new-thread
        (lambda ()
-         (lock-mutex mutex)
-         (set! thread (current-thread))
-         (signal-condition-variable cv)
-         (unlock-mutex mutex)
-         (thunk)))
+         (call-with-prompt cancel-tag
+           (lambda ()
+             (lock-mutex mutex)
+             (set! thread (current-thread))
+             (signal-condition-variable cv)
+             (unlock-mutex mutex)
+             (thunk))
+           (lambda (k . args)
+             (apply values args)))))
       (let lp ()
         (unless thread
           (wait-condition-variable cv mutex)