From 0c5c2fec5aae5fc87fc392192b009d234ea99462 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Sun, 18 Mar 2007 19:30:25 +0000 Subject: [PATCH] 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. --- NEWS | 1 + doc/manual/threading.texinfo | 3 ++ package-data-list.lisp-expr | 1 + src/code/target-thread.lisp | 85 +++++++++++++++++++++++++++++------------- src/code/timer.lisp | 3 +- tests/threads.impure.lisp | 37 ++++++++++++------ version.lisp-expr | 2 +- 7 files changed, 93 insertions(+), 39 deletions(-) diff --git a/NEWS b/NEWS index 2c64fc9..04d4735 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,7 @@ changes in sbcl-1.0.4 relative to sbcl-1.0.3: * change: runtimes with embedded cores (i.e. saved with :EXECUTABLE T) don't print the startup banner, but behave as if --noinform was passed as a command line argument. (thanks to Kevin Reid) + * new feature: added JOIN-THREAD (by NIIMI Satoshi) * optimization: code using alien values with undeclared types is much faster. * optimization: the compiler is now able to open code SEARCH in more cases. * optimization: more compact typechecks on x86-64 (thanks to Lutz Euler) diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index 7462466..759ab0f 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -33,6 +33,9 @@ threading on Darwin (Mac OS X) and FreeBSD on the x86 is experimental. @include struct-sb-thread-thread.texinfo @include var-sb-thread-star-current-thread-star.texinfo @include fun-sb-thread-make-thread.texinfo +@include fun-sb-thread-join-thread.texinfo +@include condition-sb-thread-join-thread-error.texinfo +@include fun-sb-thread-join-thread-error-thread.texinfo @include fun-sb-thread-thread-alive-p.texinfo @include fun-sb-thread-list-all-threads.texinfo @include condition-sb-thread-interrupt-thread-error.texinfo diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 89f0d84..fe1ab00 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1642,6 +1642,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." :export ("*CURRENT-THREAD*" "THREAD" "MAKE-THREAD" "THREAD-NAME" "THREAD-ALIVE-P" "LIST-ALL-THREADS" + "JOIN-THREAD" "JOIN-THREAD-ERROR" "JOIN-THREAD-ERROR-THREAD" "INTERRUPT-THREAD-ERROR" "INTERRUPT-THREAD-ERROR-THREAD" "INTERRUPT-THREAD" "TERMINATE-THREAD" "DESTROY-THREAD" diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 06002df..5d1009b 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) @@ -604,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 @@ -638,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 - "~~@" - *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 + "~~@" + *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 @@ 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 (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." diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 3ad04ea..2d4c67a 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -338,7 +338,8 @@ triggers." (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 () diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp index 0d5453b..97f98f4 100644 --- a/tests/threads.impure.lisp +++ b/tests/threads.impure.lisp @@ -14,9 +14,11 @@ (in-package "SB-THREAD") ; this is white-box testing, really (use-package :test-util) +(use-package "ASSERTOID") (defun wait-for-threads (threads) - (loop while (some #'sb-thread:thread-alive-p threads) do (sleep 0.01))) + (mapc #'sb-thread:join-thread threads) + (assert (not (some #'sb-thread:thread-alive-p threads)))) (assert (eql 1 (length (list-all-threads)))) @@ -50,6 +52,20 @@ (sleep 3) (assert (not (thread-alive-p thread)))) +(with-test (:name '(:join-thread :nlx :default)) + (let ((sym (gensym))) + (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit))) + :default sym))))) + +(with-test (:name '(:join-thread :nlx :error)) + (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))) + :errorp t))) + +(with-test (:name '(:join-thread :multiple-values)) + (assert (equal '(1 2 3) + (multiple-value-list + (join-thread (make-thread (lambda () (values 1 2 3)))))))) + ;;; We had appalling scaling properties for a while. Make sure they ;;; don't reappear. (defun scaling-test (function &optional (nthreads 5)) @@ -641,16 +657,15 @@ (let* ((ok t) (threads (loop for i from 0 to 10 collect (sb-thread:make-thread - (let ((i i)) - (lambda () - (dotimes (j 100) - (write-char #\-) - (finish-output) - (let ((n (infodb-test))) - (unless (zerop n) - (setf ok nil) - (format t "N != 0 (~A)~%" n) - (quit)))))))))) + (lambda () + (dotimes (j 100) + (write-char #\-) + (finish-output) + (let ((n (infodb-test))) + (unless (zerop n) + (setf ok nil) + (format t "N != 0 (~A)~%" n) + (sb-ext:quit))))))))) (wait-for-threads threads) (assert ok))) diff --git a/version.lisp-expr b/version.lisp-expr index c6340dd..60c34a1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.3.44" +"1.0.3.45" -- 1.7.10.4