X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=57747fc659d91427c23f84e155bdaf67524cb4db;hb=78c2361d1d9e680230df412f4d1489725781c6d2;hp=9507b50a40c7f2389c55dbf1da1ea2ae6ea735f5;hpb=970dd272dc84f7420252eadb4829cc193f795716;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 9507b50..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) @@ -57,10 +59,18 @@ in future versions." (defvar *all-threads* ()) (defvar *all-threads-lock* (make-mutex :name "all threads lock")) +(defmacro with-all-threads-lock (&body body) + #!-sb-thread + `(locally ,@body) + #!+sb-thread + `(without-interrupts + (with-mutex (*all-threads-lock*) + ,@body))) + (defun list-all-threads () #!+sb-doc "Return a list of the live threads." - (with-mutex (*all-threads-lock*) + (with-all-threads-lock (copy-list *all-threads*))) (declaim (inline current-thread-sap)) @@ -97,7 +107,7 @@ in future versions." (define-alien-routine "signal_interrupt_thread" integer (os-thread unsigned-long)) - (define-alien-routine "block_blockable_signals" + (define-alien-routine "block_deferrable_signals" void) #!+sb-lutex @@ -117,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)) @@ -156,13 +169,18 @@ in future versions." int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts -#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) +#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) #!-sb-thread (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) (* n sb!vm:n-word-bytes))) +#!+sb-thread +(defun sb!vm::current-thread-offset-sap (n) + (declare (type (unsigned-byte 27) n)) + (sb!vm::current-thread-offset-sap n)) + ;;;; spinlocks (declaim (inline get-spinlock release-spinlock)) @@ -241,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) @@ -467,16 +485,22 @@ this semaphore, then N of them is woken up." ;;; Remove thread from its session, if it has one. #!+sb-thread (defun handle-thread-exit (thread) - (with-mutex (*all-threads-lock*) - (/show0 "HANDLING THREAD EXIT") - #!+sb-lutex - (when (thread-interruptions-lock thread) - (/show0 "FREEING MUTEX LUTEX") - (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread))) - (%lutex-destroy lutex))) - (setq *all-threads* (delete thread *all-threads*))) - (when *session* - (%delete-thread-from-session thread *session*))) + (/show0 "HANDLING THREAD EXIT") + ;; We're going down, can't handle interrupts sanely anymore. + ;; GC remains enabled. + (block-deferrable-signals) + ;; Lisp-side cleanup + (with-all-threads-lock + (setf (thread-%alive-p thread) nil) + (setf (thread-os-thread thread) nil) + (setq *all-threads* (delete thread *all-threads*)) + (when *session* + (%delete-thread-from-session thread *session*))) + #!+sb-lutex + (when (thread-interruptions-lock thread) + (/show0 "FREEING MUTEX LUTEX") + (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread))) + (%lutex-destroy lutex)))) (defun terminate-session () #!+sb-doc @@ -582,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 @@ -607,6 +632,7 @@ returns the thread exits." (sb!kernel::*restart-clusters* nil) (sb!kernel::*handler-clusters* nil) (sb!kernel::*condition-restarts* nil) + (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) @@ -615,37 +641,33 @@ 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-mutex (*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)) - ;; we're going down, can't handle - ;; interrupts sanely anymore - (let ((sb!impl::*gc-inhibit* t)) - (block-blockable-signals) - (setf (thread-%alive-p thread) nil) - (setf (thread-os-thread thread) nil) - ;; and remove what can be the last - ;; reference to this 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 @@ -659,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." @@ -757,3 +805,15 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta)) + +;;; Stepping + +(defun thread-stepping () + (sb!kernel:make-lisp-obj + (sap-ref-word (current-thread-sap) + (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)))) + +(defun (setf thread-stepping) (value) + (setf (sap-ref-word (current-thread-sap) + (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)) + (sb!kernel:get-lisp-obj-address value)))