X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=c534ca01fb2e94e0b61973ecc1322602059ac56a;hb=37200d73dfca16507809778574092cfb998711d5;hp=38549a3d55592328a111101d3fc572d867ae0e86;hpb=3ac386bf6520a67343aadce1b3e61f580406b740;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 38549a3..c534ca0 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -39,14 +39,22 @@ in future versions." "The name of the thread. Setfable.") (def!method print-object ((thread thread) stream) - (if (thread-name thread) - (print-unreadable-object (thread stream :type t :identity t) - (prin1 (thread-name thread) stream)) - (print-unreadable-object (thread stream :type t :identity t) - ;; body is empty => there is only one space between type and - ;; identity - )) - thread) + (print-unreadable-object (thread stream :type t :identity t) + (let* ((cookie (list thread)) + (info (if (thread-alive-p thread) + :running + (multiple-value-list (join-thread thread :default cookie)))) + (state (if (eq :running info) + info + (if (eq cookie (car info)) + :aborted + :finished))) + (values (when (eq :finished state) info))) + (format stream "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]" + (thread-name thread) + (eq :finished state) + state + values)))) (defun thread-alive-p (thread) #!+sb-doc @@ -59,8 +67,11 @@ in future versions." (defvar *all-threads* ()) (defvar *all-threads-lock* (make-mutex :name "all threads lock")) +(defvar *default-alloc-signal* nil) + (defmacro with-all-threads-lock (&body body) - `(call-with-system-mutex (lambda () ,@body) *all-threads-lock*)) + `(with-system-mutex (*all-threads-lock*) + ,@body)) (defun list-all-threads () #!+sb-doc @@ -72,8 +83,8 @@ in future versions." (defun current-thread-sap () (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot)) -(declaim (inline current-thread-sap-id)) -(defun current-thread-sap-id () +(declaim (inline current-thread-os-thread)) +(defun current-thread-os-thread () (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) @@ -81,7 +92,7 @@ in future versions." (/show0 "Entering INIT-INITIAL-THREAD") (let ((initial-thread (%make-thread :name "initial thread" :%alive-p t - :os-thread (current-thread-sap-id)))) + :os-thread (current-thread-os-thread)))) (setq *current-thread* initial-thread) ;; Either *all-threads* is empty or it contains exactly one thread ;; in case we are in reinit since saving core with multiple @@ -193,8 +204,9 @@ in future versions." (error "Recursive lock attempt on ~S." spinlock)) #!+sb-thread (flet ((cas () - (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) - (return-from get-spinlock t)))) + (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new) + (thread-yield) + (return-from get-spinlock t)))) (if (and (not *interrupts-enabled*) *allow-with-interrupts*) ;; If interrupts are enabled, but we are allowed to enabled them, ;; check for pending interrupts every once in a while. @@ -375,41 +387,50 @@ time we reacquire MUTEX and return to the caller." (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread - (let ((owner (mutex-%owner mutex))) + (let ((me *current-thread*)) + (assert (eq me (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex - (progn - ;; FIXME: This doesn't look interrupt safe! - (setf (mutex-%owner mutex) nil) - (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) - (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) - (%lutex-wait queue-lutex-address mutex-lutex-address))) - (setf (mutex-%owner mutex) owner)) + ;; Need to disable interrupts so that we don't miss setting the owner on + ;; our way out. (pthread_cond_wait handles the actual re-acquisition.) + (without-interrupts + (unwind-protect + (progn + (setf (mutex-%owner mutex) nil) + (with-lutex-address (queue-lutex-address (waitqueue-lutex queue)) + (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) + (with-local-interrupts + (%lutex-wait queue-lutex-address mutex-lutex-address))))) + (setf (mutex-%owner mutex) me))) #!-sb-lutex - (unwind-protect - (let ((me *current-thread*)) - ;; FIXME: should we do something to ensure that the result - ;; of this setf is visible to all CPUs? - (setf (waitqueue-data queue) me) - (release-mutex mutex) - ;; Now we go to sleep using futex-wait. If anyone else - ;; manages to grab MUTEX and call CONDITION-NOTIFY during - ;; this comment, it will change queue->data, and so - ;; futex-wait returns immediately instead of sleeping. - ;; Ergo, no lost wakeup. We may get spurious wakeups, - ;; but that's ok. - (multiple-value-bind (to-sec to-usec) (decode-timeout nil) - (when (= 1 (with-pinned-objects (queue me) - (futex-wait (waitqueue-data-address queue) - (get-lisp-obj-address me) - (or to-sec -1) ;; our way if saying "no timeout" - (or to-usec 0)))) - (signal-deadline)))) - ;; If we are interrupted while waiting, we should do these things - ;; before returning. Ideally, in the case of an unhandled signal, - ;; we should do them before entering the debugger, but this is - ;; better than nothing. - (get-mutex mutex owner)))) + ;; Need to disable interrupts so that we don't miss grabbing the mutex + ;; on our way out. + (without-interrupts + (unwind-protect + (let ((me *current-thread*)) + ;; FIXME: should we do something to ensure that the result + ;; of this setf is visible to all CPUs? + (setf (waitqueue-data queue) me) + (release-mutex mutex) + ;; Now we go to sleep using futex-wait. If anyone else + ;; manages to grab MUTEX and call CONDITION-NOTIFY during + ;; this comment, it will change queue->data, and so + ;; futex-wait returns immediately instead of sleeping. + ;; Ergo, no lost wakeup. We may get spurious wakeups, + ;; but that's ok. + (multiple-value-bind (to-sec to-usec) (decode-timeout nil) + (when (= 1 (with-pinned-objects (queue me) + (allow-with-interrupts + (futex-wait (waitqueue-data-address queue) + (get-lisp-obj-address me) + (or to-sec -1) ;; our way if saying "no timeout" + (or to-usec 0))))) + (signal-deadline)))) + ;; If we are interrupted while waiting, we should do these things + ;; before returning. Ideally, in the case of an unhandled signal, + ;; we should do them before entering the debugger, but this is + ;; better than nothing. + (get-mutex mutex))))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc @@ -454,6 +475,7 @@ should be considered an implementation detail, and may change in the future." (name nil :type (or null simple-string)) (%count 0 :type (integer 0)) + (waitcount 0 :type (integer 0)) (mutex (make-mutex)) (queue (make-waitqueue))) @@ -474,21 +496,37 @@ future." #!+sb-doc "Decrement the count of SEMAPHORE if the count would not be negative. Else blocks until the semaphore can be decremented." - ;; a more direct implementation based directly on futexes should be - ;; possible - (with-mutex ((semaphore-mutex semaphore)) - (loop until (> (semaphore-%count semaphore) 0) - do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore)) - finally (decf (semaphore-%count semaphore))))) + ;; A more direct implementation based directly on futexes should be + ;; possible. + ;; + ;; We need to disable interrupts so that we don't forget to decrement the + ;; waitcount (which would happen if an asynch interrupt should catch us on + ;; our way out from the loop.) + (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) + ;; Quick check: is it positive? If not, enter the wait loop. + (let ((count (semaphore-%count semaphore))) + (if (plusp count) + (setf (semaphore-%count semaphore) (1- count)) + (unwind-protect + (progn + (incf (semaphore-waitcount semaphore)) + (loop until (plusp (setf count (semaphore-%count semaphore))) + do (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore))) + (setf (semaphore-%count semaphore) (1- count))) + (decf (semaphore-waitcount semaphore))))))) (defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc "Increment the count of SEMAPHORE by N. If there are threads waiting on this semaphore, then N of them is woken up." (declare (type (integer 1) n)) - (with-mutex ((semaphore-mutex semaphore)) - (when (= n (incf (semaphore-%count semaphore) n)) - (condition-notify (semaphore-queue semaphore) n)))) + ;; Need to disable interrupts so that we don't lose a wakeup after we have + ;; incremented the count. + (with-system-mutex ((semaphore-mutex semaphore)) + (let ((waitcount (semaphore-waitcount semaphore)) + (count (incf (semaphore-%count semaphore) n))) + (when (plusp waitcount) + (condition-notify (semaphore-queue semaphore) (min waitcount count)))))) ;;;; job control, independent listeners @@ -500,11 +538,21 @@ on this semaphore, then N of them is woken up." (defvar *session* nil) -;;; the debugger itself tries to acquire the session lock, don't let +;;; The debugger itself tries to acquire the session lock, don't let ;;; funny situations (like getting a sigint while holding the session -;;; lock) occur +;;; lock) occur. At the same time we need to allow interrupts while +;;; *waiting* for the session lock for things like GET-FOREGROUND +;;; to be interruptible. +;;; +;;; Take care: we sometimes need to obtain the session lock while holding +;;; on to *ALL-THREADS-LOCK*, so we must _never_ obtain it _after_ getting +;;; a session lock! (Deadlock risk.) +;;; +;;; FIXME: It would be good to have ordered locks to ensure invariants like +;;; the above. (defmacro with-session-lock ((session) &body body) - `(call-with-system-mutex (lambda () ,@body) (session-lock ,session))) + `(with-system-mutex ((session-lock ,session) :allow-with-interrupts t) + ,@body)) (defun new-session () (make-session :threads (list *current-thread*) @@ -679,20 +727,23 @@ around and can be retrieved by JOIN-THREAD." ;; of Allegro's *cl-default-special-bindings*, as that is at ;; least accessible to users to secure their own libraries. ;; --njf, 2006-07-15 - (let ((*current-thread* thread) - (*restart-clusters* nil) - (*handler-clusters* nil) - (*condition-restarts* nil) - (sb!impl::*deadline* nil) - (sb!impl::*step-out* nil) - ;; internal printer variables - (sb!impl::*previous-case* nil) - (sb!impl::*previous-readtable-case* nil) - (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small! - (sb!impl::*zap-array-data-temp* (vector)) ; - (sb!impl::*internal-symbol-output-fun* nil) - (sb!impl::*descriptor-handlers* nil)) ; serve-event - (setf (thread-os-thread thread) (current-thread-sap-id)) + (let* ((*current-thread* thread) + (*restart-clusters* nil) + (*handler-clusters* (sb!kernel::initial-handler-clusters)) + (*condition-restarts* nil) + (sb!impl::*deadline* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (empty (vector)) + (sb!impl::*merge-sort-temp-vector* empty) + (sb!impl::*zap-array-data-temp* empty) + (sb!impl::*internal-symbol-output-fun* nil) + (sb!impl::*descriptor-handlers* nil)) ; serve-event + ;; Binding from C + (setf sb!vm:*alloc-signal* *default-alloc-signal*) + (setf (thread-os-thread thread) (current-thread-os-thread)) (with-mutex ((thread-result-lock thread)) (with-all-threads-lock (push thread *all-threads*)) @@ -777,7 +828,8 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(call-with-system-mutex (lambda () ,@body) (thread-interruptions-lock ,thread))) + `(with-system-mutex ((thread-interruptions-lock ,thread)) + ,@body)) ;; Called from the signal handler in C. (defun run-interruption () @@ -827,31 +879,61 @@ won't like the effect." SB-EXT:QUIT - the usual cleanup forms will be evaluated" (interrupt-thread thread 'sb!ext:quit)) -;;; internal use only. If you think you need to use this, either you +(define-alien-routine "thread_yield" int) + +#!+sb-doc +(setf (fdocumentation 'thread-yield 'function) + "Yield the processor to other threads.") + +;;; internal use only. If you think you need to use these, either you ;;; are an SBCL developer, are doing something that you should discuss ;;; with an SBCL developer first, or are doing something that you ;;; should probably discuss with a professional psychiatrist first #!+sb-thread -(defun thread-sap-for-id (id) - (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))) - (loop - (when (sap= thread-sap (int-sap 0)) (return nil)) - (let ((os-thread (sap-ref-word thread-sap - (* sb!vm:n-word-bytes - sb!vm::thread-os-thread-slot)))) - (when (= os-thread id) (return thread-sap)) - (setf thread-sap - (sap-ref-sap thread-sap (* sb!vm:n-word-bytes - sb!vm::thread-next-slot))))))) - -#!+sb-thread -(defun symbol-value-in-thread (symbol thread-sap) - (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sap-ref-word thread-sap - (* sb!vm:n-word-bytes index)))) - (if (eql tl-val sb!vm::no-tls-value-marker-widetag) - (sb!vm::symbol-global-value symbol) - (make-lisp-obj tl-val)))) +(progn + (defun %thread-sap (thread) + (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t)))) + (target (thread-os-thread thread))) + (loop + (when (sap= thread-sap (int-sap 0)) (return nil)) + (let ((os-thread (sap-ref-word thread-sap + (* sb!vm:n-word-bytes + sb!vm::thread-os-thread-slot)))) + (when (= os-thread target) (return thread-sap)) + (setf thread-sap + (sap-ref-sap thread-sap (* sb!vm:n-word-bytes + sb!vm::thread-next-slot))))))) + + (defun %symbol-value-in-thread (symbol thread) + (tagbody + ;; Prevent the dead from dying completely while we look for the TLS area... + (with-all-threads-lock + (if (thread-alive-p thread) + (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol))) + (tl-val (sap-ref-word (%thread-sap thread) offset))) + (if (eql tl-val sb!vm::no-tls-value-marker-widetag) + (go :unbound) + (return-from %symbol-value-in-thread (values (make-lisp-obj tl-val) t)))) + (return-from %symbol-value-in-thread (values nil nil)))) + :unbound + (error "Cannot read thread-local symbol value: ~S unbound in ~S" symbol thread))) + + (defun %set-symbol-value-in-thread (symbol thread value) + (tagbody + (with-pinned-objects (value) + ;; Prevent the dead from dying completely while we look for the TLS area... + (with-all-threads-lock + (if (thread-alive-p thread) + (let* ((offset (* sb!vm:n-word-bytes (sb!vm::symbol-tls-index symbol))) + (sap (%thread-sap thread)) + (tl-val (sap-ref-word sap offset))) + (if (eql tl-val sb!vm::no-tls-value-marker-widetag) + (go :unbound) + (setf (sap-ref-word sap offset) (get-lisp-obj-address value))) + (return-from %set-symbol-value-in-thread (values value t))) + (return-from %set-symbol-value-in-thread (values nil nil))))) + :unbound + (error "Cannot set thread-local symbol value: ~S unbound in ~S" symbol thread)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta))