X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=080c17323b7f8a16df28af8eee3a7a01d84811a6;hb=625c9493a8a7b5186144d21302437cf4f4f3571c;hp=1bff9ad1ed04dd816584e2a08fba24a00a7d8fc2;hpb=c0f78c213b7ef4c9e439ddc4bf9ae862f27fb42f;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 1bff9ad..080c173 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -58,9 +58,6 @@ WITH-CAS-LOCK can be entered recursively." do (sb!ext:spin-loop-hint)) do (thread-yield))) ,@body) - ;; FIXME: SETF + write barrier should to be enough here. - ;; ...but GET-CAS-EXPANSION doesn't return a WRITE-FORM. - ;; ...maybe it should? (unless (eq ,owner ,self) (let ((,old ,self) (,new nil)) @@ -81,10 +78,16 @@ read by the function THREAD-ERROR-THREAD.")) ((cycle :initarg :cycle :reader thread-deadlock-cycle)) (:report (lambda (condition stream) - (let ((*print-circle* t)) - (format stream "Deadlock cycle detected:~%~@< ~@;~ - ~{~:@_~S~:@_~}~:@>" - (mapcar #'car (thread-deadlock-cycle condition))))))) + (let* ((*print-circle* t) + (cycle (thread-deadlock-cycle condition)) + (start (caar cycle))) + (format stream "Deadlock cycle detected:~%") + (loop for part = (pop cycle) + while part + do (format stream " ~S~% waited for:~% ~S~% owned by:~%" + (car part) + (cdr part))) + (format stream " ~S~%" start))))) #!+sb-doc (setf @@ -365,6 +368,8 @@ HOLDING-MUTEX-P." ;; Make sure to get the current value. (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil)) +(sb!ext:defglobal **deadlock-lock** nil) + ;;; Signals an error if owner of LOCK is waiting on a lock whose release ;;; depends on the current thread. Does not detect deadlocks from sempahores. (defun check-deadlock () @@ -376,18 +381,21 @@ HOLDING-MUTEX-P." (let ((other-thread (mutex-%owner lock))) (cond ((not other-thread)) ((eq self other-thread) - (let* ((chain (deadlock-chain self origin)) - (barf - (format nil - "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@< ~@;~ - ~{~:@_~S~:@_~}~:@>~ - ~%END OF CYCLE~%" - (mapcar #'car chain)))) - ;; Barf to stderr in case the system is too tied up - ;; to report the error properly -- to avoid cross-talk - ;; build the whole string up first. - (write-string barf sb!sys:*stderr*) - (finish-output sb!sys:*stderr*) + (let ((chain + (with-cas-lock ((symbol-value '**deadlock-lock**)) + (prog1 (deadlock-chain self origin) + ;; We're now committed to signaling the + ;; error and breaking the deadlock, so + ;; mark us as no longer waiting on the + ;; lock. This ensures that a single + ;; deadlock is reported in only one + ;; thread, and that we don't look like + ;; we're waiting on the lock when print + ;; stuff -- because that may lead to + ;; further deadlock checking, in turn + ;; possibly leading to a bogus vicious + ;; metacycle on PRINT-OBJECT. + (setf (thread-waiting-for self) nil))))) (error 'thread-deadlock :thread *current-thread* :cycle chain))) @@ -420,7 +428,7 @@ HOLDING-MUTEX-P." (list (list thread lock))) (t (if other-lock - (cons (list thread lock) + (cons (cons thread lock) (deadlock-chain other-thread other-lock)) ;; Again, the deadlock is gone? (return-from check-deadlock nil))))))) @@ -438,11 +446,11 @@ HOLDING-MUTEX-P." #!-sb-thread (when old (error "Strange deadlock on ~S in an unithreaded build?" mutex)) - #!-sb-futex + #!-(and sb-thread sb-futex) (and (not old) ;; Don't even bother to try to CAS if it looks bad. (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) - #!+sb-futex + #!+(and sb-thread sb-futex) ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper. (when (eql +lock-free+ (sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ @@ -609,7 +617,7 @@ IF-NOT-OWNER is :FORCE)." ;; FIXME: Is a :memory barrier too strong here? Can we use a :write ;; barrier instead? (barrier (:memory))) - #!+sb-futex + #!+(and sb-thread sb-futex) (when old-owner ;; FIXME: once ATOMIC-INCF supports struct slots with word sized ;; unsigned-byte type this can be used: @@ -636,7 +644,7 @@ IF-NOT-OWNER is :FORCE)." #!+sb-doc "Waitqueue type." (name nil :type (or null thread-name)) - #!+sb-futex + #!+(and sb-thread sb-futex) (token nil)) #!+(and sb-thread (not sb-futex)) @@ -669,17 +677,18 @@ IF-NOT-OWNER is :FORCE)." (setf (thread-waiting-for thread) nil) (let ((head (waitqueue-%head queue))) (do ((list head (cdr list)) - (prev nil)) - ((eq (car list) thread) - (let ((rest (cdr list))) - (cond (prev - (setf (cdr prev) rest)) - (t - (setf (waitqueue-%head queue) rest - prev rest))) - (unless rest - (setf (waitqueue-%tail queue) prev)))) - (setf prev list))) + (prev nil list)) + ((or (null list) + (eq (car list) thread)) + (when list + (let ((rest (cdr list))) + (cond (prev + (setf (cdr prev) rest)) + (t + (setf (waitqueue-%head queue) rest + prev rest))) + (unless rest + (setf (waitqueue-%tail queue) prev))))))) nil) (defun %waitqueue-wakeup (queue n) (declare (fixnum n)) @@ -779,8 +788,7 @@ around the call, checking the the associated data: (setf status (or (flet ((wakeup () (barrier (:read)) - (when (neq queue - (thread-waiting-for me)) + (unless (eq queue (thread-waiting-for me)) :ok))) (declare (dynamic-extent #'wakeup)) (allow-with-interrupts @@ -912,8 +920,38 @@ future." (setf (fdocumentation 'semaphore-name 'function) "The name of the semaphore INSTANCE. Setfable.") +(defstruct (semaphore-notification (:constructor make-semaphore-notification ()) + (:copier nil)) + #!+sb-doc + "Semaphore notification object. Can be passed to WAIT-ON-SEMAPHORE and +TRY-SEMAPHORE as the :NOTIFICATION argument. Consequences are undefined if +multiple threads are using the same notification object in parallel." + (%status nil :type boolean)) + +(setf (fdocumentation 'make-semaphore-notification 'function) + "Constructor for SEMAPHORE-NOTIFICATION objects. SEMAPHORE-NOTIFICATION-STATUS +is initially NIL.") + +(declaim (inline semaphore-notification-status)) +(defun semaphore-notification-status (semaphore-notification) + #!+sb-doc + "Returns T if a WAIT-ON-SEMAPHORE or TRY-SEMAPHORE using +SEMAPHORE-NOTICATION has succeeded since the notification object was created +or cleared." + (barrier (:read)) + (semaphore-notification-%status semaphore-notification)) + +(declaim (inline clear-semaphore-notification)) +(defun clear-semaphore-notification (semaphore-notification) + #!+sb-doc + "Resets the SEMAPHORE-NOTIFICATION object for use with another call to +WAIT-ON-SEMAPHORE or TRY-SEMAPHORE." + (barrier (:write) + (setf (semaphore-notification-%status semaphore-notification) nil))) + (declaim (inline semaphore-count)) (defun semaphore-count (instance) + #!+sb-doc "Returns the current count of the semaphore INSTANCE." (barrier (:read)) (semaphore-%count instance)) @@ -923,14 +961,23 @@ future." "Create a semaphore with the supplied COUNT and NAME." (%make-semaphore name count)) -(defun wait-on-semaphore (semaphore &key timeout) +(defun wait-on-semaphore (semaphore &key timeout notification) #!+sb-doc "Decrement the count of SEMAPHORE if the count would not be negative. Else blocks until the semaphore can be decremented. Returns T on success. If TIMEOUT is given, it is the maximum number of seconds to wait. If the count cannot be decremented in that time, returns NIL without decrementing the -count." +count. + +If NOTIFICATION is given, it must be a SEMAPHORE-NOTIFICATION object whose +SEMAPHORE-NOTIFICATION-STATUS is NIL. If WAIT-ON-SEMAPHORE succeeds and +decrements the count, the status is set to T." + (when (and notification (semaphore-notification-status notification)) + (with-simple-restart (continue "Clear notification status and continue.") + (error "~@" + 'wait-on-semaphore semaphore)) + (clear-semaphore-notification notification)) ;; A more direct implementation based directly on futexes should be ;; possible. ;; @@ -942,36 +989,55 @@ count." (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 - ;; Need to use ATOMIC-INCF despite the lock, because on our - ;; way out from here we might not be locked anymore -- so - ;; another thread might be tweaking this in parallel using - ;; ATOMIC-DECF. No danger over overflow, since there it - ;; at most one increment per thread waiting on the semaphore. - (sb!ext:atomic-incf (semaphore-waitcount semaphore)) - (loop until (plusp (setf count (semaphore-%count semaphore))) - do (or (condition-wait (semaphore-queue semaphore) - (semaphore-mutex semaphore) - :timeout timeout) - (return-from wait-on-semaphore nil))) - (setf (semaphore-%count semaphore) (1- count))) - ;; Need to use ATOMIC-DECF instead of DECF, as CONDITION-WAIT - ;; may unwind without the lock being held due to timeouts. - (sb!ext:atomic-decf (semaphore-waitcount semaphore)))))) + (cond ((plusp count) + (setf (semaphore-%count semaphore) (1- count)) + (when notification + (setf (semaphore-notification-%status notification) t))) + (t + (unwind-protect + (progn + ;; Need to use ATOMIC-INCF despite the lock, because on our + ;; way out from here we might not be locked anymore -- so + ;; another thread might be tweaking this in parallel using + ;; ATOMIC-DECF. No danger over overflow, since there it + ;; at most one increment per thread waiting on the semaphore. + (sb!ext:atomic-incf (semaphore-waitcount semaphore)) + (loop until (plusp (setf count (semaphore-%count semaphore))) + do (or (condition-wait (semaphore-queue semaphore) + (semaphore-mutex semaphore) + :timeout timeout) + (return-from wait-on-semaphore nil))) + (setf (semaphore-%count semaphore) (1- count)) + (when notification + (setf (semaphore-notification-%status notification) t))) + ;; Need to use ATOMIC-DECF as we may unwind without the lock + ;; being held! + (sb!ext:atomic-decf (semaphore-waitcount semaphore))))))) t) -(defun try-semaphore (semaphore &optional (n 1)) +(defun try-semaphore (semaphore &optional (n 1) notification) #!+sb-doc "Try to decrement the count of SEMAPHORE by N. If the count were to -become negative, punt and return NIL, otherwise return true." +become negative, punt and return NIL, otherwise return true. + +If NOTIFICATION is given it must be a semaphore notification object +with SEMAPHORE-NOTIFICATION-STATUS of NIL. If the count is decremented, +the status is set to T." (declare (type (integer 1) n)) + (when (and notification (semaphore-notification-status notification)) + (with-simple-restart (continue "Clear notification status and continue.") + (error "~@" + 'try-semaphore semaphore)) + (clear-semaphore-notification notification)) (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) (let ((new-count (- (semaphore-%count semaphore) n))) (when (not (minusp new-count)) - (setf (semaphore-%count semaphore) new-count))))) + (setf (semaphore-%count semaphore) new-count) + (when notification + (setf (semaphore-notification-%status notification) t)) + ;; FIXME: We don't actually document this -- should we just + ;; return T, or document new count as the return? + new-count)))) (defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc @@ -1472,34 +1538,17 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD." (with-all-threads-lock (loop (if (thread-alive-p thread) - (let* ((epoch sb!kernel::*gc-epoch*) - (offset (sb!kernel:get-lisp-obj-address + (let* ((offset (sb!kernel:get-lisp-obj-address (sb!vm::symbol-tls-index symbol))) - (tl-val (sap-ref-word (%thread-sap thread) offset))) + (obj (sap-ref-lispobj (%thread-sap thread) offset)) + (tl-val (sb!kernel:get-lisp-obj-address obj))) (cond ((zerop offset) (return (values nil :no-tls-value))) ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) (eql tl-val sb!vm:unbound-marker-widetag)) (return (values nil :unbound-in-thread))) (t - (multiple-value-bind (obj ok) (make-lisp-obj tl-val nil) - ;; The value we constructed may be invalid if a GC has - ;; occurred. That is harmless, though, since OBJ is - ;; either in a register or on stack, and we are - ;; conservative on both on GENCGC -- so a bogus object - ;; is safe here as long as we don't return it. If we - ;; ever port threads to a non-conservative GC we must - ;; pin the TL-VAL address before constructing OBJ, or - ;; make WITH-ALL-THREADS-LOCK imply WITHOUT-GCING. - ;; - ;; The reason we don't just rely on TL-VAL pinning the - ;; object is that the call to MAKE-LISP-OBJ may cause - ;; bignum allocation, at which point TL-VAL might not - ;; be alive anymore -- hence the epoch check. - (when (eq epoch sb!kernel::*gc-epoch*) - (if ok - (return (values obj :ok)) - (return (values obj :invalid-tls-value)))))))) + (return (values obj :ok))))) (return (values nil :thread-dead)))))) (defun %set-symbol-value-in-thread (symbol thread value) @@ -1513,8 +1562,8 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD." (cond ((zerop offset) (values nil :no-tls-value)) (t - (setf (sap-ref-word (%thread-sap thread) offset) - (get-lisp-obj-address value)) + (setf (sap-ref-lispobj (%thread-sap thread) offset) + value) (values value :ok)))) (values nil :thread-dead)))))