X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Ftarget-thread.lisp;h=cf6ceb5de790972a8e47c136360bc16ec1e45446;hb=e034d6a8d034a3f8ca755bf89fae850f6387c505;hp=53d2671265098f8babb7fc957543c6d5cda662f9;hpb=a54d8af9a66ca26ff53f5bcde774a415448d28ab;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 53d2671..cf6ceb5 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -35,32 +35,24 @@ WITH-CAS-LOCK can be entered recursively."
      (%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)
+  (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 ,read-form)
               (,self *current-thread*)
-              (,owner ,place))
+              (,old nil)
+              (,new ,self))
          (unwind-protect
               (progn
                 (unless (eq ,owner ,self)
-                  (loop while (setf ,owner
-                                    (or ,place
-                                        (sb!ext:compare-and-swap ,place nil ,self)))
+                  (loop while (setf ,owner (or ,read-form ,cas-form))
                         do (thread-yield)))
                 ,@body)
            (unless (eq ,owner ,self)
-             (sb!ext:compare-and-swap ,place ,self nil)))))))
+             (let ((,old ,self)
+                   (,new nil))
+               ,cas-form)))))))
 
 ;;; Conditions