+;;; 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 (self owner)
+ ;; Take care not to multiply-evaluate anything.
+ ;;
+ ;; FIXME: Once we get DEFCAS this can use GET-CAS-EXPANSION.
+ (let* ((placex (sb!xc:macroexpand place env))
+ (place-op (if (consp placex)
+ (car placex)
+ (error "~S: ~S is not a valid place for ~S"
+ 'with-cas-lock
+ place 'sb!ext:compare-and-swap)))
+ (place-args (cdr placex))
+ (temps (make-gensym-list (length place-args) t))
+ (place `(,place-op ,@temps)))
+ `(let* (,@(mapcar #'list temps place-args)
+ (,self *current-thread*)
+ (,owner ,place))
+ (unwind-protect
+ (progn
+ (unless (eq ,owner ,self)
+ (loop while (setf ,owner
+ (or ,place
+ (sb!ext:compare-and-swap ,place nil ,self)))
+ do (thread-yield)))
+ ,@body)
+ (unless (eq ,owner ,self)
+ (sb!ext:compare-and-swap ,place ,self nil)))))))
+
+;;; 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) ()
+ (:report (lambda (c s)
+ (format s "Joining thread failed: thread ~A ~
+ did not return normally."
+ (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))
+