Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv19673/src/code
Modified Files:
target-thread.lisp timer.lisp
Log Message:
1.0.3.45: added JOIN-THREAD
Implementation by NIIMI Satoshi. Added more docstrings and changed the
interface according to the styling advice of Thomas F. Burdick.
Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- target-thread.lisp 20 Nov 2006 04:51:38 -0000 1.62
+++ target-thread.lisp 18 Mar 2007 19:30:25 -0000 1.63
@@ -30,7 +30,9 @@
%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)
@@ -604,7 +606,8 @@
(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
@@ -638,30 +641,34 @@
(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.
@@ -674,6 +681,32 @@
(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 (errorp t) default)
+ #!+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 or signal JOIN-THREAD-ERROR depending on ERRORP."
+ (with-mutex ((thread-result-lock thread))
+ (cond ((car (thread-result thread))
+ (values-list (cdr (thread-result thread))))
+ (errorp
+ (error 'join-thread-error :thread thread))
+ (t
+ default))))
+
(defun destroy-thread (thread)
#!+sb-doc
"Deprecated. Same as TERMINATE-THREAD."
Index: timer.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/timer.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- timer.lisp 7 Sep 2006 08:49:39 -0000 1.7
+++ timer.lisp 18 Mar 2007 19:30:25 -0000 1.8
@@ -338,7 +338,8 @@
(sb!thread:interrupt-thread thread function)
(sb!thread:interrupt-thread-error (c)
(declare (ignore c))
- (warn "Timer ~S failed to interrupt thread ~S." timer thread)))))))
+ (warn "Timer ~S failed to interrupt thread ~S."
+ timer thread)))))))
;; Called from the signal handler.
(defun run-expired-timers ()
|