timeouts on JOIN-THREAD

   Marking the return convention experimental for now, as I'm
   not sure if

   ...we should signal a separate condition type for timeouts.

   ...we should have a separate :TIMEOUT-VALUE argument.

   ...if that value should default to value of DEFAULT.

   Pfff. Interfaces are hard -- let's go shopping!

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 0361ec5..7b21c14 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -108,11 +108,18 @@ the symbol not having a thread-local value, or the target thread having
 exited. The offending symbol can be accessed using CELL-ERROR-NAME, and the
 offending thread using THREAD-ERROR-THREAD."))
 
-(define-condition join-thread-error (thread-error) ()
+(define-condition join-thread-error (thread-error)
+  ((problem :initarg :problem :reader join-thread-problem))
   (:report (lambda (c s)
-             (format s "Joining thread failed: thread ~A ~
-                        did not return normally."
-                     (thread-error-thread c))))
+             (ecase (join-thread-problem c)
+               (:abort
+                (format s "Joining thread failed: thread ~A ~
+                           did not return normally."
+                        (thread-error-thread c)))
+               (:timeout
+                (format s "Joining thread timed out: thread ~A ~
+                           did not exit in time."
+                        (thread-error-thread c))))))
   #!+sb-doc
   (:documentation
    "Signalled when joining a thread fails due to abnormal exit of the thread
@@ -1301,18 +1308,37 @@ around and can be retrieved by JOIN-THREAD."
           (wait-on-semaphore setup-sem)
           thread)))))
 
-(defun join-thread (thread &key (default nil defaultp))
+(defun join-thread (thread &key (default nil defaultp) timeout)
   #!+sb-doc
-  "Suspend current thread until THREAD exits. Returns the result
-values of the thread function. If the thread does not exit normally,
-return DEFAULT if given or else signal JOIN-THREAD-ERROR."
-  (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t)
-    (cond ((car (thread-result thread))
-           (return-from join-thread
-             (values-list (cdr (thread-result thread)))))
-          (defaultp
-           (return-from join-thread default))))
-  (error 'join-thread-error :thread thread))
+  "Suspend current thread until THREAD exits. Return the result values of the
+thread function.
+
+If the thread does not exit normally within TIMEOUT seconds return DEFAULT if
+given, or else signal JOIN-THREAD-ERROR.
+
+NOTE: Return convention in case of a timeout is exprimental and subject to
+change."
+  (let ((lock (thread-result-lock thread))
+        (got-it nil)
+        (problem :timeout))
+    (without-interrupts
+      (unwind-protect
+           (if (setf got-it
+                     (allow-with-interrupts
+                       ;; Don't use the timeout if the thread is not alive anymore.
+                       (grab-mutex lock :timeout (and (thread-alive-p thread) timeout))))
+               (cond ((car (thread-result thread))
+                      (return-from join-thread
+                        (values-list (cdr (thread-result thread)))))
+                     (defaultp
+                      (return-from join-thread default))
+                     (t
+                      (setf problem :abort)))
+               (when defaultp
+                 (return-from join-thread default)))
+        (when got-it
+          (release-mutex lock))))
+    (error 'join-thread-error :thread thread :problem problem)))
 
 (defun destroy-thread (thread)
   #!+sb-doc

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index d8ae4c4..c9db294 100644 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -583,3 +583,16 @@
     (let ((ok (count-if #'join-thread threads)))
       (unless (eql 20 ok)
         (error "Wanted 20, got ~S" ok)))))
+
+(with-test (:name (:join-thread :timeout)
+            :skipped-on '(not :sb-thread))
+  (assert (eq :error
+              (handler-case
+                  (join-thread (make-thread (lambda () (sleep 10))) :timeout 0.01)
+                (join-thread-error ()
+                  :error))))
+  (let ((cookie (cons t t)))
+    (assert (eq cookie
+                (join-thread (make-thread (lambda () (sleep 10)))
+                             :timeout 0.01
+                             :default cookie)))))