1.0.7.19: SB-EXT:COMPARE-AND-SWAP

[sbcl.git] / src / compiler / x86 / cell.lisp

diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 83277ce..d8e5a34 100644 (file)
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -29,11 +29,65 @@
   (:results)
   (:generator 1
      (storew (encode-value-if-immediate value) object offset lowtag)))
-\f
-
 
+(define-vop (compare-and-swap-slot)
+  (:args (object :scs (descriptor-reg) :to :eval)
+         (old :scs (descriptor-reg any-reg) :target eax)
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset eax-offset
+                   :from (:argument 1) :to :result :target result)
+              eax)
+  (:info name offset lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:generator 5
+     (move eax old)
+     #!+sb-thread
+     (inst lock)
+     (inst cmpxchg (make-ea :dword :base object
+                            :disp (- (* offset n-word-bytes) lowtag))
+           new)
+     (move result eax)))
+\f
 ;;;; symbol hacking VOPs
 
+(define-vop (%compare-and-swap-symbol-value)
+  (:translate %compare-and-swap-symbol-value)
+  (:args (symbol :scs (descriptor-reg) :to (:result 1))
+         (old :scs (descriptor-reg any-reg) :target eax)
+         (new :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset eax-offset) eax)
+  #!+sb-thread
+  (:temporary (:sc descriptor-reg) tls)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 15
+    ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
+    ;; or UNBOUND-MARKER as NEW: in either case we would end up
+    ;; doing possible damage with CMPXCHG -- so don't do that!
+    (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
+          (check (gen-label)))
+      (move eax old)
+      #!+sb-thread
+      (progn
+        (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
+        ;; Thread-local area, not LOCK needed.
+        (inst fs-segment-prefix)
+        (inst cmpxchg (make-ea :dword :base tls) new)
+        (inst cmp eax no-tls-value-marker-widetag)
+        (inst jmp :ne check)
+        (move eax old)
+        (inst lock))
+      (inst cmpxchg (make-ea :dword :base symbol
+                             :disp (- (* symbol-value-slot n-word-bytes)
+                                      other-pointer-lowtag))
+            new)
+      (emit-label check)
+      (move result eax)
+      (inst cmp result unbound-marker-widetag)
+      (inst jmp :e unbound))))
+
 ;;; these next two cf the sparc version, by jrd.
 ;;; FIXME: Deref this ^ reference.
 
@@ -446,10 +500,10 @@
   (any-reg descriptor-reg) *
   %instance-set)
 
-(define-full-compare-and-swap instance-compare-and-swap instance
+(define-full-compare-and-swap %compare-and-swap-instance-ref instance
   instance-slots-offset instance-pointer-lowtag
   (any-reg descriptor-reg) *
-  %instance-compare-and-swap)
+  %compare-and-swap-instance-ref)
 \f
 ;;;; code object frobbing