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

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 0d0ccb9..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
 
@@ -493,6 +485,7 @@ HOLDING-MUTEX-P."
        ;; Spin.
        (go :retry))))
 
+#!+sb-thread
 (defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep)
   (with-deadlocks (self mutex timeout)
     (with-interrupts (check-deadlock))
@@ -732,10 +725,11 @@ around the call, checking the the associated data:
       (push data *data*)
       (condition-notify *queue*)))
 "
-  #!-sb-thread (declare (ignore queue timeout))
+  #!-sb-thread
+  (declare (ignore queue))
   (assert mutex)
   #!-sb-thread
-  (wait-for nil :timeout timeout) ; Yeah...
+  (sb!ext:wait-for nil :timeout timeout) ; Yeah...
   #!+sb-thread
   (let ((me *current-thread*))
     (barrier (:read))