master: x86-64: Rearrange CAS vops for SYMBOL-[GLOBAL-]VALUE

The branch "master" has been updated in SBCL:
       via  8e6ef6fb951369fa974d20c779066e83cff7da7e (commit)
      from  002e5c99e4ee0a1ce166fcd8047a61c2d790e3bc (commit)

- Log -----------------------------------------------------------------
commit 8e6ef6fb951369fa974d20c779066e83cff7da7e
Author: Douglas Katzman <[email protected]>
Date:   Thu Apr 9 22:19:27 2026 -0400

    x86-64: Rearrange CAS vops for SYMBOL-[GLOBAL-]VALUE
    
    Don't attempt to share logic between SYMBOL-VALUE and SYMBOL-GLOBAL-VALUE
    for sb-thread but instead make sb-thread (CAS SYMBOL-GLOBAL-VALUE)
    identical to #-sb-thread (CAS SYMBOL-VALUE) and then separately implement
    (CAS SYMBOL-VALUE) for threads. Also correct the deficiency of not
    accepting immediate SC for the symbol on #-sb-thread.
---
 src/compiler/x86-64/cell.lisp   | 48 ++++++++++++++++++---------------
 src/compiler/x86-64/memory.lisp |  4 +++
 src/compiler/x86-64/tls.lisp    | 59 +++++++++++------------------------------
 3 files changed, 46 insertions(+), 65 deletions(-)

diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 982b24f04..100b139c8 100644
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -149,6 +149,33 @@
                         (object-slot-ea symbol symbol-value-slot other-pointer-lowtag))
         value val-temp))))
 
+(define-vop (%cas-symbol-global-value)
+  (:translate %cas-symbol-global-value #-sb-thread %compare-and-swap-symbol-value)
+  (:args (symbol :scs (descriptor-reg immediate) :to (:result 0))
+         (old :scs (descriptor-reg any-reg constant immediate))
+         (new :scs (descriptor-reg any-reg)))
+  ;; RAX purposely conflicts with OLD instead of being born exactly when OLD dies
+  ;; because RAX serves as the temporary for computing the card mark address.
+  (:temporary (:sc descriptor-reg :offset rax-offset :to (:result 0)) rax)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:node-var node)
+  (:generator 15
+    (pseudo-atomic (:elide-if (and #+immobile-space
+                                   (not (symbol-set-barrier-p symbol (vop-nth-arg 2 vop)))))
+      (emit-symbol-write-barrier vop symbol rax (vop-nth-arg 2 vop))
+      (if (sc-is old immediate) (move-immediate rax (immediate-tn-repr old)) (move rax old))
+      (let ((ea (if (sc-is symbol immediate)
+                    (symbol-slot-ea (tn-value symbol) symbol-value-slot)
+                    (symbol-value-slot-ea symbol))))
+        (inst cmpxchg :lock ea new)))
+    (unless (or (and (sc-is symbol immediate) (sb-c::always-boundp (tn-value symbol) node))
+                (policy node (= safety 0)))
+      (inst cmp :byte rax unbound-marker-widetag)
+      (inst jmp :e (generate-error-code vop 'unbound-symbol-error symbol)))
+    (move result rax)))
+
 #-sb-thread
 (progn
   (define-vop (symbol-value symbol-global-value)
@@ -166,27 +193,6 @@
                  symbol symbol-value-slot other-pointer-lowtag)
             unbound-marker-widetag)))
 
-  (define-vop (%compare-and-swap-symbol-value)
-    (:translate %compare-and-swap-symbol-value %cas-symbol-global-value)
-    (:args (symbol :scs (descriptor-reg) :to (:result 0))
-           (old :scs (descriptor-reg any-reg constant immediate))
-           (new :scs (descriptor-reg any-reg)))
-    (:temporary (:sc descriptor-reg :offset rax-offset :to (:result 0)) rax)
-    (:results (result :scs (descriptor-reg any-reg)))
-    (:policy :fast-safe)
-    (:vop-var vop)
-    (:node-var node)
-    (:generator 15
-      (emit-symbol-write-barrier vop symbol rax (vop-nth-arg 2 vop))
-      (if (sc-is old immediate)
-          (move-immediate rax (immediate-tn-repr old))
-          (move rax old))
-      (inst cmpxchg :lock (object-slot-ea symbol symbol-value-slot other-pointer-lowtag) new)
-      (unless (policy node (= safety 0))
-        (inst cmp :byte rax unbound-marker-widetag)
-        (inst jmp :e (generate-error-code vop 'unbound-symbol-error symbol)))
-      (move result rax)))
-
   (define-vop (dynbind)
     (:args (val :scs (any-reg descriptor-reg))
            (symbol :scs (descriptor-reg)))
diff --git a/src/compiler/x86-64/memory.lisp b/src/compiler/x86-64/memory.lisp
index 8ffc2be3b..08cefb65d 100644
--- a/src/compiler/x86-64/memory.lisp
+++ b/src/compiler/x86-64/memory.lisp
@@ -18,6 +18,10 @@
         (ea (+ (static-symbol-offset symbol) offset) null-tn)
         (ea (make-fixup symbol :immobile-symbol offset)))))
 
+(defmacro symbol-value-slot-ea (sym)    ; SYM is a TN
+  `(ea (- (* symbol-value-slot n-word-bytes) other-pointer-lowtag)
+       ,sym))
+
 ;;; The GC card table base is either an imm8 displacement from NULL-TN, or that
 ;;; plus one backend page if #+sb-safepoint. The reason for sliding the table up
 ;;; with #+sb-safepoint is that the safepoint trap address wants to be an imm8 away
diff --git a/src/compiler/x86-64/tls.lisp b/src/compiler/x86-64/tls.lisp
index 3d310e38b..836f151f2 100644
--- a/src/compiler/x86-64/tls.lisp
+++ b/src/compiler/x86-64/tls.lisp
@@ -11,10 +11,6 @@
 
 (in-package "SB-VM")
 
-(defmacro symbol-value-slot-ea (sym)    ; SYM is a TN
-  `(ea (- (* symbol-value-slot n-word-bytes) other-pointer-lowtag)
-       ,sym))
-
 (defun emit-lea-symbol-value-slot (ea-tn symbol) ; dest, src
   (if (sc-is symbol immediate)
       (inst mov ea-tn (make-fixup (tn-value symbol) :immobile-symbol
@@ -39,36 +35,6 @@
       `(%cas-symbol-global-value symbol old new)
       (sb-c::give-up-ir1-transform)))
 
-(flet ((emit-cas (ea symbol old new rax result pa vop &aux (node (sb-c::vop-node vop)))
-         (if (sc-is old immediate) (move-immediate rax (immediate-tn-repr old)) (move rax old))
-         (inst cmpxchg :lock ea new)
-         (when pa (emit-end-pseudo-atomic))
-         (unless (or (and (sc-is symbol immediate) (sb-c::always-boundp (tn-value symbol) node))
-                     (policy node (= safety 0)))
-           (inst cmp :byte rax unbound-marker-widetag)
-           (inst jmp :e (generate-error-code vop 'unbound-symbol-error symbol)))
-         (move result rax)))
-(define-vop (%cas-symbol-global-value)
-  (:translate %cas-symbol-global-value)
-  (:args (symbol :scs (descriptor-reg immediate) :to (:result 0))
-         (old :scs (descriptor-reg any-reg constant immediate))
-         (new :scs (descriptor-reg any-reg)))
-  ;; RAX is the temp for computing the card mark, so it has to conflict
-  ;; with OLD and therefore the default lifetime spec is fine
-  (:temporary (:sc descriptor-reg :offset rax-offset :to (:result 0)) rax)
-  (:results (result :scs (descriptor-reg any-reg)))
-  (:policy :fast-safe)
-  (:vop-var vop)
-  (:generator 10
-    ;; There's an error trap in EMIT-CAS which mustn't be inside PSEUDO-ATOMIC
-    (let ((pa #+immobile-space (symbol-set-barrier-p symbol (vop-nth-arg 2 vop))))
-      (when pa (emit-begin-pseudo-atomic))
-      (emit-symbol-write-barrier vop symbol rax (vop-nth-arg 2 vop))
-      (emit-cas (if (sc-is symbol immediate)
-                    (symbol-slot-ea (tn-value symbol) symbol-value-slot)
-                    (symbol-value-slot-ea symbol))
-                symbol old new rax result pa vop))))
-
 (define-vop (%compare-and-swap-symbol-value)
   (:translate %compare-and-swap-symbol-value)
   (:args (symbol :scs (descriptor-reg immediate) :to (:result 0))
@@ -81,6 +47,7 @@
   (:results (result :scs (descriptor-reg any-reg)))
   (:policy :fast-safe)
   (:vop-var vop)
+  (:node-var node)
   (:generator 15
   ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
   ;; or UNBOUND-MARKER as NEW: in either case we would end up
@@ -95,16 +62,20 @@
     ;; IF this is CAS of a thread-local value, then pseudo-atomic is not needed,
     ;; but trying to skip the p-a (to "optimize") is just silly because we have
     ;; to assume that this is NOT thread-local for CAS to have any merit.
-    (let ((pa #+immobile-space (symbol-set-barrier-p symbol (vop-nth-arg 2 vop)))
-          (cas (gen-label)))
-      (when pa (emit-begin-pseudo-atomic))
-      (inst cmp :qword (ea cell) no-tls-value-marker)
-      (inst jmp :ne CAS)
-      ;; GLOBAL
-      (emit-symbol-write-barrier vop symbol cell (vop-nth-arg 2 vop))
-      (emit-lea-symbol-value-slot cell symbol)
-      (emit-label CAS)
-      (emit-cas (ea cell) symbol old new rax result pa vop)))))
+    (let ((pa #+immobile-space (symbol-set-barrier-p symbol (vop-nth-arg 2 vop))))
+      (pseudo-atomic (:elide-if (not pa))
+        (inst cmp :qword (ea cell) no-tls-value-marker)
+        (inst jmp :ne CAS)
+        (emit-symbol-write-barrier vop symbol cell (vop-nth-arg 2 vop))
+        (emit-lea-symbol-value-slot cell symbol)
+        CAS
+        (if (sc-is old immediate) (move-immediate rax (immediate-tn-repr old)) (move rax old))
+        (inst cmpxchg :lock (ea cell) new))
+      (unless (or (and (sc-is symbol immediate) (sb-c::always-boundp (tn-value symbol) node))
+                  (policy node (= safety 0)))
+        (inst cmp :byte rax unbound-marker-widetag)
+        (inst jmp :e (generate-error-code vop 'unbound-symbol-error symbol)))
+      (move result rax))))
 
 ;;; The :tls-load-indirect feature is, in most situations, an improvement over "direct"
 ;;; access (contrary to what indirection implies, but I couldn't settle on a better name).

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL