+;;; CAS Lock
+;;;
+;;; Locks don't come any simpler -- or more lightweight than this. While
+;;; this is probably a premature optimization for most users, we still
+;;; need it internally for implementing condition variables outside Futex
+;;; builds.
+
+(defmacro with-cas-lock ((place) &body body)
+ #!+sb-doc
+ "Runs BODY with interrupts disabled and *CURRENT-THREAD* compare-and-swapped
+into PLACE instead of NIL. PLACE must be a place acceptable to
+COMPARE-AND-SWAP, and must initially hold NIL.
+
+WITH-CAS-LOCK is suitable mostly when the critical section needing protection
+is very small, and cost of allocating a separate lock object would be
+prohibitive. While it is the most lightweight locking constructed offered by
+SBCL, it is also the least scalable if the section is heavily contested or
+long.
+
+WITH-CAS-LOCK can be entered recursively."
+ `(without-interrupts
+ (%with-cas-lock (,place) ,@body)))
+
+(defmacro %with-cas-lock ((place) &body body &environment env)
+ (with-unique-names (owner self)
+ (multiple-value-bind (vars vals old new cas-form read-form)
+ (sb!ext:get-cas-expansion place env)
+ `(let* (,@(mapcar #'list vars vals)
+ (,owner (progn
+ (barrier (:read))
+ ,read-form))
+ (,self *current-thread*)
+ (,old nil)
+ (,new ,self))
+ (unwind-protect
+ (progn
+ (unless (eq ,owner ,self)
+ (loop until (loop repeat 100
+ when (and (progn
+ (barrier (:read))
+ (not ,read-form))
+ (not (setf ,owner ,cas-form)))
+ return t
+ else
+ do (sb!ext:spin-loop-hint))
+ do (thread-yield)))
+ ,@body)
+ (unless (eq ,owner ,self)
+ (let ((,old ,self)
+ (,new nil))
+ (unless (eq ,old ,cas-form)
+ (bug "Failed to release CAS lock!")))))))))
+
+;;; Conditions
+
+(define-condition thread-error (error)
+ ((thread :reader thread-error-thread :initarg :thread))
+ #!+sb-doc
+ (:documentation
+ "Conditions of type THREAD-ERROR are signalled when thread operations fail.
+The offending thread is initialized by the :THREAD initialization argument and
+read by the function THREAD-ERROR-THREAD."))
+
+(define-condition thread-deadlock (thread-error)
+ ((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)))))))
+
+#!+sb-doc
+(setf
+ (fdocumentation 'thread-error-thread 'function)
+ "Return the offending thread that the THREAD-ERROR pertains to.")
+
+(define-condition symbol-value-in-thread-error (cell-error thread-error)
+ ((info :reader symbol-value-in-thread-error-info :initarg :info))
+ (:report
+ (lambda (condition stream)
+ (destructuring-bind (op problem)
+ (symbol-value-in-thread-error-info condition)
+ (format stream "Cannot ~(~A~) value of ~S in ~S: ~S"
+ op
+ (cell-error-name condition)
+ (thread-error-thread condition)
+ (ecase problem
+ (:unbound-in-thread "the symbol is unbound in thread.")
+ (:no-tls-value "the symbol has no thread-local value.")
+ (:thread-dead "the thread has exited.")
+ (:invalid-tls-value "the thread-local value is not valid."))))))
+ #!+sb-doc
+ (:documentation
+ "Signalled when SYMBOL-VALUE-IN-THREAD or its SETF version fails due to eg.
+the symbol not having a thread-local value, or the target thread having
+exited. The offending symbol can be accessed using CELL-ERROR-NAME, and the
+offending thread using THREAD-ERROR-THREAD."))
+
+(define-condition join-thread-error (thread-error)
+ ((problem :initarg :problem :reader join-thread-problem))
+ (:report (lambda (c s)
+ (ecase (join-thread-problem c)
+ (:abort
+ (format s "Joining thread failed: thread ~A ~
+ did not return normally."
+ (thread-error-thread c)))
+ (:timeout
+ (format s "Joining thread timed out: thread ~A ~
+ did not exit in time."
+ (thread-error-thread c))))))
+ #!+sb-doc
+ (:documentation
+ "Signalled when joining a thread fails due to abnormal exit of the thread
+to be joined. The offending thread can be accessed using
+THREAD-ERROR-THREAD."))
+
+(define-deprecated-function :late "1.0.29.17" join-thread-error-thread thread-error-thread
+ (condition)
+ (thread-error-thread condition))
+
+(define-condition interrupt-thread-error (thread-error) ()
+ (:report (lambda (c s)
+ (format s "Interrupt thread failed: thread ~A has exited."
+ (thread-error-thread c))))
+ #!+sb-doc
+ (:documentation
+ "Signalled when interrupting a thread fails because the thread has already
+exited. The offending thread can be accessed using THREAD-ERROR-THREAD."))
+
+(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread thread-error-thread
+ (condition)
+ (thread-error-thread condition))
+