master: x86-64, struct-by-value: fix record-arg-tn for win32
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 8a98e7b59d99d353b84d0ecd0a1fb42a578103ae (commit)
from 627064c1dca8cda8b982873e9bf1b784da245b46 (commit)
- Log -----------------------------------------------------------------
commit 8a98e7b59d99d353b84d0ecd0a1fb42a578103ae
Author: Stas Boukarev <[email protected]>
Date: Fri Apr 24 00:20:22 2026 +0300
x86-64, struct-by-value: fix record-arg-tn for win32
Correctly write to stack tns.
---
src/compiler/aliencomp.lisp | 113 +++++++++++++++++++++-------------------
src/compiler/x86-64/c-call.lisp | 40 +++++---------
2 files changed, 73 insertions(+), 80 deletions(-)
diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 81af63e50..9884046ea 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -860,6 +860,11 @@
(dolist (tn #-arm arg-tns #+arm (reverse arg-tns))
(cond ((arg-tn-loader-p tn)
;; Struct-by-value: call loader, TNs exposed via arg-tn-loader-tns
+ (loop for tn in (arg-tn-loader-tns tn)
+ do
+ (when (eq (sb-kind (sc-sb (tn-sc tn))) :unbounded) ;; stacks are unbounded
+ ;; Avoid allocating this TN on the caller's stack
+ (setf (tn-kind tn) :arg-pass)))
(funcall (arg-tn-loader-fn tn) (pop args) call block nsp))
((functionp tn)
(funcall tn (pop args) call block nsp))
@@ -869,61 +874,61 @@
;;
;; FIXME: We should implement something better than this.
(let* ((first-tn (if (listp tn) (car tn) tn))
- (arg (pop args))
- (sc (tn-sc first-tn))
- (scn (sc-number sc))
- (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
- (aver arg)
- (unless (= (length move-arg-vops) 1)
- (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
+ (arg (pop args))
+ (sc (tn-sc first-tn))
+ (scn (sc-number sc))
+ (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
+ (aver arg)
+ (unless (= (length move-arg-vops) 1)
+ (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
- (cond
- #+(or arm-softfp riscv loongarch64)
- ((and (listp tn)
- (symbolp (car (last tn))))
- (emit-template call block
- (template-or-lose (car (last tn)))
- (reference-tn (lvar-tn call block arg) nil)
- (reference-tn-list (butlast tn) t)))
- (t
- (when (eq (sb-kind (sc-sb sc)) :unbounded) ;; stacks are unbounded
- ;; Avoid allocating this TN on the caller's stack
- (setf (tn-kind first-tn) :arg-pass))
- #+(or x86 x86-64)
- (emit-move-arg-template call
- block
- (first move-arg-vops)
- (lvar-tn call block arg)
- nsp
- first-tn)
- #-(or x86 x86-64)
- (let* ((primitive-type (tn-primitive-type first-tn))
- ;; If the destination is a stack TN make sure
- ;; the temporary TN is a register.
- (scn (if (sc-number-stack-p sc)
- (car (primitive-type-scs primitive-type))
- scn))
- (temp-tn (make-representation-tn primitive-type scn)))
- (emit-move call block (lvar-tn call block arg) temp-tn)
- (emit-move-arg-template call
- block
- (first move-arg-vops)
- temp-tn
- nsp
- first-tn))))
- #+(and ppc darwin)
- (when (listp tn)
- ;; This means that we have a float arg that we need to
- ;; also copy to some int regs. The list contains the TN
- ;; for the float as well as the TNs to use for the int
- ;; arg.
- (destructuring-bind (float-tn i1-tn &optional i2-tn)
- tn
- (if i2-tn
- (vop sb-vm::move-double-to-int-arg call block
- float-tn i1-tn i2-tn)
- (vop sb-vm::move-single-to-int-arg call block
- float-tn i1-tn))))))))
+ (cond
+ #+(or arm-softfp riscv loongarch64)
+ ((and (listp tn)
+ (symbolp (car (last tn))))
+ (emit-template call block
+ (template-or-lose (car (last tn)))
+ (reference-tn (lvar-tn call block arg) nil)
+ (reference-tn-list (butlast tn) t)))
+ (t
+ (when (eq (sb-kind (sc-sb sc)) :unbounded) ;; stacks are unbounded
+ ;; Avoid allocating this TN on the caller's stack
+ (setf (tn-kind first-tn) :arg-pass))
+ #+(or x86 x86-64)
+ (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ (lvar-tn call block arg)
+ nsp
+ first-tn)
+ #-(or x86 x86-64)
+ (let* ((primitive-type (tn-primitive-type first-tn))
+ ;; If the destination is a stack TN make sure
+ ;; the temporary TN is a register.
+ (scn (if (sc-number-stack-p sc)
+ (car (primitive-type-scs primitive-type))
+ scn))
+ (temp-tn (make-representation-tn primitive-type scn)))
+ (emit-move call block (lvar-tn call block arg) temp-tn)
+ (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ temp-tn
+ nsp
+ first-tn))))
+ #+(and ppc darwin)
+ (when (listp tn)
+ ;; This means that we have a float arg that we need to
+ ;; also copy to some int regs. The list contains the TN
+ ;; for the float as well as the TNs to use for the int
+ ;; arg.
+ (destructuring-bind (float-tn i1-tn &optional i2-tn)
+ tn
+ (if i2-tn
+ (vop sb-vm::move-double-to-int-arg call block
+ float-tn i1-tn i2-tn)
+ (vop sb-vm::move-single-to-int-arg call block
+ float-tn i1-tn))))))))
(aver (null args))
(let* ((result-tns (ensure-list result-tns))
(arg-operands
diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 02d959b9e..a728bf225 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -328,13 +328,6 @@ Floats are passed in integer registers."
(inst mov :qword temp (ea src-offset sap))
(inst mov :qword (ea dst-offset nsp) temp)))
-;;; VOP to move SAP value to integer register (for Windows struct-by-pointer)
-(define-vop (load-sap-int-arg)
- (:args (sap :scs (sap-reg)))
- (:results (target :scs (unsigned-reg)))
- (:generator 1
- (move target sap)))
-
;;; Arg TN generation for record types
;;; Called from src/code/c-call.lisp
@@ -343,31 +336,26 @@ Floats are passed in integer registers."
#+win32
(defun record-arg-tn (type state)
"Handle struct arguments."
- (let ((classification (classify-struct type))
- (arg-tn (int-arg state 'unsigned-byte-64
- unsigned-reg-sc-number unsigned-stack-sc-number)))
+ (let* ((classification (classify-struct type))
+ (arg-tn (int-arg state 'unsigned-byte-64
+ unsigned-reg-sc-number unsigned-stack-sc-number))
+ (temp (and (sc-is arg-tn unsigned-stack)
+ (sb-c:make-representation-tn (primitive-type-or-lose 'unsigned-byte-64)
+ unsigned-reg-sc-number)))
+ (move-target (or temp arg-tn)))
(sb-c::make-arg-tn-loader
(list arg-tn)
(if (sb-alien::struct-classification-memory-p classification)
(lambda (arg call block nsp)
- (declare (ignore nsp))
(let ((sap-tn (sb-c::lvar-tn call block arg)))
- (sb-c::emit-and-insert-vop
- call block
- (sb-c::template-or-lose 'load-sap-int-arg)
- (sb-c::reference-tn sap-tn nil)
- (sb-c::reference-tn arg-tn t)
- nil
- nil)))
+ (sb-c::vop sap-int call block sap-tn move-target)
+ (when temp
+ (sb-c::vop move-word-arg call block temp nsp arg-tn))))
(lambda (arg call block nsp)
- (declare (ignore nsp))
- (sb-c::emit-and-insert-vop
- call block
- (sb-c::template-or-lose 'load-struct-int-arg)
- (sb-c::reference-tn (sb-c::lvar-tn call block arg) nil)
- (sb-c::reference-tn arg-tn t)
- nil
- (list 0)))))))
+ (sb-c::vop sap-ref-64 call block (sb-c::lvar-tn call block arg)
+ (emit-constant 0) move-target)
+ (when temp
+ (sb-c::vop move-word-arg call block temp nsp arg-tn)))))))
;;; System V: structs >16 bytes copied to stack, <=16 bytes in up to 2
;;; registers.
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL