master: struct-by-value: don't overwrite when copying values from registers to memory
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via a190d9710a9da21ca525c5153f17b03eaf130e13 (commit)
from c4c736c56826cf94382ad996070c614fc57a18ad (commit)
- Log -----------------------------------------------------------------
commit a190d9710a9da21ca525c5153f17b03eaf130e13
Author: Jesse Bouwman <[email protected]>
Date: Sat Apr 25 17:30:19 2026 -0700
struct-by-value: don't overwrite when copying values from registers to memory
---
src/compiler/aliencomp.lisp | 76 ++++++++++++++++++++++++++---------
tests/alien-struct-access.impure.lisp | 10 ++---
2 files changed, 63 insertions(+), 23 deletions(-)
diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 9884046ea..efae7dfe7 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -558,28 +558,68 @@
;;;; ALIEN-FUNCALL support
-;;; Generate code to store struct register values to memory
+;;; Size-dispatched SETF forms that write exactly SIZE bytes (1..8)
+;;; from TEMP, a (unsigned-byte 64), into [result-sap+offset]. Used
+;;; for the trailing partial eightbyte of a struct-by-value return.
#-sb-xc-host
-(defun generate-struct-store-code (temps register-slots result-sap)
+(defun %gen-int-slot-store (result-sap offset size temp)
+ (ecase size
+ (8 `(setf (sb-sys:sap-ref-64 ,result-sap ,offset) ,temp))
+ (4 `(setf (sb-sys:sap-ref-32 ,result-sap ,offset)
+ (ldb (byte 32 0) ,temp)))
+ (2 `(setf (sb-sys:sap-ref-16 ,result-sap ,offset)
+ (ldb (byte 16 0) ,temp)))
+ (1 `(setf (sb-sys:sap-ref-8 ,result-sap ,offset)
+ (ldb (byte 8 0) ,temp)))
+ ((3 5 6 7)
+ ;; No primitive store matches; fall back to byte-granular.
+ `(progn
+ ,@(loop for i from 0 below size collect
+ `(setf (sb-sys:sap-ref-8 ,result-sap ,(+ offset i))
+ (ldb (byte 8 ,(* i 8)) ,temp)))))))
+
+;;; Generate code to store struct register values to memory.
+#-sb-xc-host
+(defun generate-struct-store-code (temps register-slots bytes result-sap)
"Generate SETF forms to store register values to struct memory."
(let ((offset 0)
(stores nil)
(temp-idx 0))
(dolist (class register-slots)
- (case class
- (:integer
- (push `(setf (sb-sys:sap-ref-64 ,result-sap ,offset) ,(nth temp-idx temps)) stores)
- (incf offset 8)
- (incf temp-idx))
- (:double
- (push `(setf (sb-sys:sap-ref-double ,result-sap ,offset) ,(nth temp-idx temps)) stores)
- (incf offset 8)
- (incf temp-idx))
- ;; :single is ARM64 HFA only - x86-64 classifies all floats as :double
- (:single
- (push `(setf (sb-sys:sap-ref-single ,result-sap ,offset) ,(nth temp-idx temps)) stores)
- (incf offset 4)
- (incf temp-idx))))
+ (let* ((remaining (- bytes offset))
+ (slot-size (case class
+ ((:integer :double) (min 8 remaining))
+ (:single (min 4 remaining)))))
+ (ecase class
+ (:integer
+ (push (%gen-int-slot-store result-sap offset slot-size
+ (nth temp-idx temps))
+ stores)
+ (incf offset 8)
+ (incf temp-idx))
+ (:double
+ (cond
+ ((= slot-size 8)
+ (push `(setf (sb-sys:sap-ref-double ,result-sap ,offset)
+ ,(nth temp-idx temps))
+ stores))
+ ((= slot-size 4)
+ (push `(setf (sb-sys:sap-ref-32 ,result-sap ,offset)
+ (sb-kernel:double-float-low-bits
+ ,(nth temp-idx temps)))
+ stores))
+ (t
+ (error "Unexpected :double slot size ~A at offset ~A ~
+ (struct size ~A)" slot-size offset bytes)))
+ (incf offset 8)
+ (incf temp-idx))
+ ;; :single is ARM64 HFA only - x86-64 classifies all floats as :double
+ (:single
+ (push `(setf (sb-sys:sap-ref-single ,result-sap ,offset)
+ ,(nth temp-idx temps))
+ stores)
+ (incf offset 4)
+ (incf temp-idx)))))
(nreverse stores)))
;;; Build the function expression for %alien-funcall, optimizing to use
@@ -632,7 +672,7 @@
;;; Returns (values) - caller wraps result as alien if needed.
#-sb-xc-host
(defun generate-struct-return-code (func-expr alien-type return-type deports buffer-var)
- (multiple-value-bind (in-registers-p register-slots)
+ (multiple-value-bind (in-registers-p register-slots bytes)
(sb-alien::struct-return-info return-type)
(cond
;; Large struct: pass buffer as hidden first arg
@@ -645,7 +685,7 @@
(let ((temps (loop repeat (length register-slots) collect (gensym))))
`(multiple-value-bind ,temps
(%alien-funcall ,func-expr ',alien-type ,@deports)
- ,@(generate-struct-store-code temps register-slots buffer-var)
+ ,@(generate-struct-store-code temps register-slots bytes buffer-var)
(values)))))))
(deftransform alien-funcall ((function &rest args)
diff --git a/tests/alien-struct-access.impure.lisp b/tests/alien-struct-access.impure.lisp
index e358a2489..3264778e2 100644
--- a/tests/alien-struct-access.impure.lisp
+++ b/tests/alien-struct-access.impure.lisp
@@ -175,35 +175,35 @@
;;; Over-write probes (return-buffer side).
-(with-test (:name :overwrite-i8 :broken-on :sbcl)
+(with-test (:name :overwrite-i8)
(probe-overwrite 1 (struct gp-i8)
"gp_i8_make"
(function (struct gp-i8) (signed 8))
(-42)
(assert (= (slot s 'm0) -42))))
-(with-test (:name :overwrite-i16 :broken-on :sbcl)
+(with-test (:name :overwrite-i16)
(probe-overwrite 2 (struct gp-i16)
"gp_i16_make"
(function (struct gp-i16) (signed 16))
(12345)
(assert (= (slot s 'm0) 12345))))
-(with-test (:name :overwrite-i32 :broken-on :sbcl)
+(with-test (:name :overwrite-i32)
(probe-overwrite 4 (struct gp-i32)
"gp_i32_make"
(function (struct gp-i32) (signed 32))
(#x7abcdef0)
(assert (= (slot s 'm0) #x7abcdef0))))
-(with-test (:name :overwrite-1f :broken-on :sbcl)
+(with-test (:name :overwrite-1f)
(probe-overwrite 4 (struct gp-1f)
"gp_1f_make"
(function (struct gp-1f) single-float)
(42.5f0)
(assert (= (slot s 'm0) 42.5f0))))
-(with-test (:name :overwrite-3f :broken-on :sbcl)
+(with-test (:name :overwrite-3f)
(probe-overwrite 12 (struct gp-3f)
"gp_3f_make"
(function (struct gp-3f)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL