X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=57747fc659d91427c23f84e155bdaf67524cb4db;hb=78c2361d1d9e680230df412f4d1489725781c6d2;hp=ed47314e0764e2f28d2c6e51a21b3d2d044455da;hpb=bfb7c2d573bacfd9c5f3f243b7c1589f81f11406;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index ed47314..57747fc 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -30,7 +30,9 @@ in future versions."
   %alive-p
   os-thread
   interruptions
-  (interruptions-lock (make-mutex :name "thread interruptions lock")))
+  (interruptions-lock (make-mutex :name "thread interruptions lock"))
+  result
+  (result-lock (make-mutex :name "thread result lock")))
 
 #!+sb-doc
 (setf (sb!kernel:fdocumentation 'thread-name 'function)
@@ -125,6 +127,9 @@ in future versions."
     (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
         int (lutex unsigned-long))
 
+    (sb!alien:define-alien-routine ("lutex_trylock" %lutex-trylock)
+        int (lutex unsigned-long))
+
     (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
         int (lutex unsigned-long))
 
@@ -254,11 +259,11 @@ until it is available"
       (format *debug-io* "Thread: ~A~%" *current-thread*)
       (sb!debug:backtrace most-positive-fixnum *debug-io*)
       (force-output *debug-io*))
-    ;; FIXME: sb-lutex and (not wait-p)
     #!+sb-lutex
-    (when wait-p
-      (with-lutex-address (lutex (mutex-lutex mutex))
-        (%lutex-lock lutex))
+    (when (zerop (with-lutex-address (lutex (mutex-lutex mutex))
+                   (if wait-p
+                       (%lutex-lock lutex)
+                       (%lutex-trylock lutex))))
       (setf (mutex-value mutex) new-value))
     #!-sb-lutex
     (let (old)
@@ -601,7 +606,8 @@ have the foreground next."
 (defun make-thread (function &key name)
   #!+sb-doc
   "Create a new thread of NAME that runs FUNCTION. When the function
-returns the thread exits."
+returns the thread exits. The return values of FUNCTION are kept
+around and can be retrieved by JOIN-THREAD."
   #!-sb-thread (declare (ignore function name))
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
@@ -635,30 +641,34 @@ returns the thread exits."
                   (sb!impl::*internal-symbol-output-fun* nil)
                   (sb!impl::*descriptor-handlers* nil)) ; serve-event
               (setf (thread-os-thread thread) (current-thread-sap-id))
-              (with-all-threads-lock
-                (push thread *all-threads*))
-              (with-session-lock (*session*)
-                (push thread (session-threads *session*)))
-              (setf (thread-%alive-p thread) t)
-              (signal-semaphore setup-sem)
-              ;; can't use handling-end-of-the-world, because that flushes
-              ;; output streams, and we don't necessarily have any (or we
-              ;; could be sharing them)
-              (catch 'sb!impl::toplevel-catcher
-                (catch 'sb!impl::%end-of-the-world
-                  (with-simple-restart
-                      (terminate-thread
-                       (format nil
-                               "~~@<Terminate this thread (~A)~~@:>"
-                               *current-thread*))
-                    (unwind-protect
-                         (progn
-                           ;; now that most things have a chance to
-                           ;; work properly without messing up other
-                           ;; threads, it's time to enable signals
-                           (sb!unix::reset-signal-mask)
-                           (funcall real-function))
-                      (handle-thread-exit thread))))))
+              (with-mutex ((thread-result-lock thread))
+                (with-all-threads-lock
+                  (push thread *all-threads*))
+                (with-session-lock (*session*)
+                  (push thread (session-threads *session*)))
+                (setf (thread-%alive-p thread) t)
+                (signal-semaphore setup-sem)
+                ;; can't use handling-end-of-the-world, because that flushes
+                ;; output streams, and we don't necessarily have any (or we
+                ;; could be sharing them)
+                (catch 'sb!impl::toplevel-catcher
+                  (catch 'sb!impl::%end-of-the-world
+                    (with-simple-restart
+                        (terminate-thread
+                         (format nil
+                                 "~~@<Terminate this thread (~A)~~@:>"
+                                 *current-thread*))
+                      (unwind-protect
+                           (progn
+                             ;; now that most things have a chance to
+                             ;; work properly without messing up other
+                             ;; threads, it's time to enable signals
+                             (sb!unix::reset-signal-mask)
+                             (setf (thread-result thread)
+                                   (cons t
+                                         (multiple-value-list
+                                          (funcall real-function)))))
+                        (handle-thread-exit thread)))))))
             (values))))
     ;; Keep INITIAL-FUNCTION pinned until the child thread is
     ;; initialized properly.
@@ -671,6 +681,32 @@ returns the thread exits."
         (wait-on-semaphore setup-sem)
         thread))))
 
+(define-condition join-thread-error (error)
+  ((thread :reader join-thread-error-thread :initarg :thread))
+  #!+sb-doc
+  (:documentation "Joining thread failed.")
+  (:report (lambda (c s)
+             (format s "Joining thread failed: thread ~A ~
+                        has not returned normally."
+                     (join-thread-error-thread c)))))
+
+#!+sb-doc
+(setf (sb!kernel:fdocumentation 'join-thread-error-thread 'function)
+      "The thread that we failed to join.")
+
+(defun join-thread (thread &key (default nil defaultp))
+  #!+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-mutex ((thread-result-lock thread))
+    (cond ((car (thread-result thread))
+           (values-list (cdr (thread-result thread))))
+          (defaultp
+           default)
+          (t
+           (error 'join-thread-error :thread thread)))))
+
 (defun destroy-thread (thread)
   #!+sb-doc
   "Deprecated. Same as TERMINATE-THREAD."