master: x86-64, struct-by-value: prevent overwrites when copying during callbacks

The branch "master" has been updated in SBCL:
       via  f484412bc4e3ebbbd2eedf83608a29aed6dc4e9c (commit)
      from  f735fd577c01137f2e6705b5146fa50b9ec8122f (commit)

- Log -----------------------------------------------------------------
commit f484412bc4e3ebbbd2eedf83608a29aed6dc4e9c
Author: Jesse Bouwman <[email protected]>
Date:   Sun Apr 26 10:41:45 2026 -0700

    x86-64, struct-by-value: prevent overwrites when copying during callbacks
---
 src/compiler/x86-64/c-call.lisp       | 36 +++++++++++++++++++++++++++++------
 tests/alien-struct-access.c           |  6 ++++++
 tests/alien-struct-access.impure.lisp | 18 ++++++++++++++++++
 3 files changed, 54 insertions(+), 6 deletions(-)

diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 362df5a9d..bd4053c11 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -841,6 +841,34 @@ Floats are passed in integer registers."
 (defun alien-callback-accessor-form (type sp offset)
   `(deref (sap-alien (sap+ ,sp ,offset) (* ,type))))
 
+;;; Copy SIZE bytes from [SRC-REG] to [DST-REG] using SCRATCH as a temp.
+#-sb-xc-host
+(defun emit-sret-copy (size src-reg dst-reg scratch)
+  (multiple-value-bind (full-words tail) (floor size 8)
+    (loop for i below full-words
+          for off = (* i 8)
+          do (inst mov scratch (ea off src-reg))
+             (inst mov (ea off dst-reg) scratch))
+    (when (plusp tail)
+      (let ((off (* full-words 8)))
+        (flet ((copy-byte-at (k)
+                 (inst mov :byte scratch (ea (+ off k) src-reg))
+                 (inst mov :byte (ea (+ off k) dst-reg) scratch))
+               (copy-word-at (k)
+                 (inst mov :word scratch (ea (+ off k) src-reg))
+                 (inst mov :word (ea (+ off k) dst-reg) scratch))
+               (copy-dword-at (k)
+                 (inst mov :dword scratch (ea (+ off k) src-reg))
+                 (inst mov :dword (ea (+ off k) dst-reg) scratch)))
+          (ecase tail
+            (1 (copy-byte-at 0))
+            (2 (copy-word-at 0))
+            (3 (copy-word-at 0) (copy-byte-at 2))
+            (4 (copy-dword-at 0))
+            (5 (copy-dword-at 0) (copy-byte-at 4))
+            (6 (copy-dword-at 0) (copy-word-at 4))
+            (7 (copy-dword-at 0) (copy-word-at 4) (copy-byte-at 6))))))))
+
 #-sb-xc-host
 (defun alien-callback-assembler-wrapper (index result-type argument-types)
   ;; Windows x64 struct-by-value callback rules:
@@ -1127,9 +1155,7 @@ Floats are passed in integer registers."
                   ;; Retrieve saved hidden pointer (was pushed at start from RCX)
                   (inst mov rax (ea (* (+ arg-slot-count return-slot-count-aligned) n-word-bytes) rsp))
                   ;; Copy struct data from stack to hidden pointer destination
-                  (loop for off from 0 below struct-size by 8
-                        do (inst mov rdx (ea off rsp))
-                           (inst mov (ea off rax) rdx))))
+                  (emit-sret-copy struct-size rsp rax rdx)))
                ;; Small struct (<=8 bytes): just load into RAX
                (t
                 (inst mov rax [rsp])))
@@ -1139,9 +1165,7 @@ Floats are passed in integer registers."
                (large-struct-return-p
                 (let ((struct-size (sb-alien::struct-classification-size result-classification)))
                   (inst mov rax (ea (* (+ arg-slot-count return-slot-count-aligned) n-word-bytes) rsp))
-                  (loop for off from 0 below struct-size by 8
-                        do (inst mov rdx (ea off rsp))
-                           (inst mov (ea off rax) rdx))))
+                  (emit-sret-copy struct-size rsp rax rdx)))
                ;; Small struct: copy to registers based on classification
                (t
                 (let ((slots (sb-alien::struct-classification-register-slots result-classification))
diff --git a/tests/alien-struct-access.c b/tests/alien-struct-access.c
index 5a6cac7d7..8e63f285d 100644
--- a/tests/alien-struct-access.c
+++ b/tests/alien-struct-access.c
@@ -84,3 +84,9 @@ struct gp_3f  gp_3f_make  (float a, float b, float c) {
   s.a = a; s.b = b; s.c = c;
   return s;
 }
+
+/*
+ * 20-byte struct (>16B, MEMORY-class on SysV and AAPCS64), for
+ * callback trampoline test.
+ */
+typedef struct { signed char m[20]; } gp_i8x20;
diff --git a/tests/alien-struct-access.impure.lisp b/tests/alien-struct-access.impure.lisp
index 3264778e2..03596980d 100644
--- a/tests/alien-struct-access.impure.lisp
+++ b/tests/alien-struct-access.impure.lisp
@@ -213,3 +213,21 @@
                      (assert (= (slot s 'a) 1.0f0))
                      (assert (= (slot s 'b) 2.0f0))
                      (assert (= (slot s 'c) 3.0f0)))))
+
+;;; When a Lisp callback returns a struct >16 bytes to C, the ABI
+;;; passes a hidden pointer to the callback.  The callback assembler
+;;; wrapper copies Lisp's struct buffer to that pointer. Check for
+;;; overwrites.
+
+(define-alien-type nil (struct gp-i8x20 (m (array (signed 8) 20))))
+
+(with-test (:name :overwrite-cb-return-i8x20)
+  (with-guarded-struct (s 20 (struct gp-i8x20) sap)
+    (declare (ignore s))
+    (sb-alien:with-alien-callable
+        ((cb (struct gp-i8x20) ()
+           (sb-alien:with-alien ((view (struct gp-i8x20))) view)))
+      (with-fault-handler "OVER-WRITE (callback trampoline)"
+        (alien-funcall-into
+         (sb-alien:sap-alien (alien-sap cb) (function (struct gp-i8x20)))
+         sap)))))

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


hooks/post-receive
-- 
SBCL