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))
((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
;; 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 ()
(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)))
(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)))))))
#!-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+
;; 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:
#!+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))
(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))
(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
(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))
"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 "~@<Semaphore notification object status not cleared on entry to ~S on ~S.~:@>"
+ 'wait-on-semaphore semaphore))
+ (clear-semaphore-notification notification))
;; A more direct implementation based directly on futexes should be
;; possible.
;;
(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 "~@<Semaphore notification object status not cleared on entry to ~S on ~S.~:@>"
+ '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
(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)
(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)))))
projects / sbcl.git / blobdiff