master: Make EMIT-EA more complicated

The branch "master" has been updated in SBCL:
       via  b5c1bfad94d14e9c9b23afdc8ba9ef338be47fb8 (commit)
      from  18f8a0c8ea195ce436b3d19046ea6c316a4c37a0 (commit)

- Log -----------------------------------------------------------------
commit b5c1bfad94d14e9c9b23afdc8ba9ef338be47fb8
Author: Douglas Katzman <[email protected]>
Date:   Fri Aug 21 22:26:49 2026 +0000

    Make EMIT-EA more complicated
    
    because it wasn't bad^H^H^Hflexible enough
---
 src/compiler/x86-64/insts.lisp   | 39 ++++++++++++++++++++++++++-------------
 tests/x86-64-codegen.impure.lisp | 16 ++++++++++++++++
 xperfecthash63.lisp-expr         |  3 +++
 3 files changed, 45 insertions(+), 13 deletions(-)

diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp
index 40ff45d5f..0c8f79296 100644
--- a/src/compiler/x86-64/insts.lisp
+++ b/src/compiler/x86-64/insts.lisp
@@ -884,12 +884,13 @@
 (declaim (freeze-type label+addend))
 
 ;;;; the effective-address (ea) structure
-(defstruct (ea (:constructor %ea (segment disp base index scale))
+(defstruct (ea (:constructor %ea (segment disp-bits disp base index scale))
                (:copier nil))
   (segment nil :type (member :cs :fs :gs) :read-only t)
   (base nil :type (or tn null) :read-only t)
   (index nil :type (or tn null) :read-only t)
   (scale 1 :type (member 1 2 4 8) :read-only t)
+  (disp-bits nil :type (member 8 32 nil) :read-only t)
   (disp 0 :type (or (unsigned-byte 32) (signed-byte 32) fixup
                     label label+addend)
           :read-only t))
@@ -941,11 +942,17 @@
 ;;;
 (defun ea (&rest args) ; seg displacement base index scale
   (declare (dynamic-extent args))
-  (let ((seg :cs) disp)
-    (let ((first (car args)))
-      (case first
-        ((:fs :gs) (setq seg first) (pop args))
-        (:cs (pop args))))
+  (let ((seg :cs) disp-bits disp)
+    (loop
+      (let ((is-prefix
+             (case (car args)
+               ((:fs :gs) (setq seg (car args)))
+               (:cs t)
+               ;; Syntax motivated by ".disp{8,32}" in GNU asm
+               (:disp8 (setq disp-bits 8))
+               (:disp32 (setq disp-bits 32))
+               (t nil))))
+        (if is-prefix (pop args) (return))))
     (let ((first (car args)))
       ;; Rather than checking explicitly for all the things that are legal to be
       ;; a displacement (i.e. LABEL, FIXUP, INTEGER), look for (NOT (OR TN NULL).)
@@ -957,14 +964,18 @@
     ;; The minimal EA is either an absolute address or an unindexed base register.
     ;; So gotta have at least one of disp or base. Enforce by doing either of two
     ;; destructuring-binds depending on whether DISP was present.
-    (if disp
-        (destructuring-bind (&optional base index (scale 1)) args
-          (%ea seg disp base index scale))
-        (destructuring-bind (base &optional index (scale 1)) args
-          (%ea seg 0 base index scale)))))
+    (multiple-value-bind (disp base index scale)
+        (if disp
+            (destructuring-bind (&optional base index (scale 1)) args
+              (values disp base index scale))
+            (destructuring-bind (base &optional index (scale 1)) args
+              (values 0 base index scale)))
+      (%ea seg disp-bits disp base index scale))))
 
 (defun rip-relative-ea (label &optional addend)
-  (%ea :cs (if addend (make-label+addend label addend) label) rip-tn nil 1))
+  ;; disp-bits is 32 but using NIL for "automatic" will infer it just like
+  ;; it always did before adding the ability to choose.
+  (%ea :cs nil (if addend (make-label+addend label addend) label) rip-tn nil 1))
 
 (defun emit-byte-displacement-backpatch (segment target)
   (emit-back-patch segment 1
@@ -1241,7 +1252,9 @@
                                   (zerop (mod disp disp-n))
                                   (let ((q (/ disp disp-n)))
                                     (and (<= -128 q 127) q))))
-            (mod (cond ((or (null base) (and (eql disp 0) (/= base-encoding #b101)))
+            (mod (cond ((ea-disp-bits thing) ; explicit .disp8 or .disp32
+                        (case (ea-disp-bits thing) (8 #b01) (t #b10)))
+                       ((or (null base) (and (eql disp 0) (/= base-encoding #b101)))
                         #b00)
                        (compressed-disp
                         #b01)
diff --git a/tests/x86-64-codegen.impure.lisp b/tests/x86-64-codegen.impure.lisp
index 27e0f4704..2b24ce40a 100644
--- a/tests/x86-64-codegen.impure.lisp
+++ b/tests/x86-64-codegen.impure.lisp
@@ -1539,3 +1539,19 @@
     ;; Must keep the single fused memory CMP and avoid separate register CMPs
     (assert (= mem-cmps 1))
     (assert (= reg-cmps 0))))
+
+(with-test (:name :specifically-sized-ea-disp)
+  (let* ((lines
+          (disassembly-lines
+           (compile
+            nil
+            '(lambda ()
+              sb-vm::(inline-vop (((x int-sse-reg))) ()
+               (inst movdqa (ea 0 rdx-tn) x)
+               (inst movdqa (ea :disp8 0 rdx-tn) x)
+               (inst movdqa (ea :disp32 0 rdx-tn) x))))))
+         (found (member "MOVDQA [RDX], XMM0" lines :test #'search))
+         (disp8 (cadr found))
+         (disp32 (caddr found)))
+    (assert (search "660F7F4200       MOVDQA [RDX], XMM0" disp8))
+    (assert (search "660F7F8200000000 MOVDQA [RDX], XMM0" disp32))))
diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr
index 7f5342f94..ee0a54eab 100644
--- a/xperfecthash63.lisp-expr
+++ b/xperfecthash63.lisp-expr
@@ -1820,5 +1820,8 @@
 (#(A49305EF D0241AE7 E55E7F8C EE9A5410)
  "(SB-PCL::%CLASS SB-PCL::%PARAMETER SB-PCL::%VARIABLE-REBINDING SPECIAL)"
  "((& (>> val 8) 3))")
+(#(29085F3F 555EA088 8A2CAA21 922EF550 9A26078C)
+ "(:DISP32 :DISP8 :CS :GS :FS)"
+ "((& (+ (>> val 3) (>> val 17)) 7))")
 )
 ;; EOF

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


hooks/post-receive
-- 
SBCL