[PATCH] Struct-by-value register allocator patch for x86-64 and ARM64
Jesse Bouwman via Sbcl-devel <[email protected]> Thu, 05 Feb 2026 19:34:18 +0000
| Newsgroups | gmane.lisp.steel-bank.devel |
|---|---|
| Message-ID | <[email protected]> |
Hello, Here is a patch that returns allocated TNs from sb-vm::record-arg-tn -- the recent work on struct-by-value overlooked the case where small register-allocated structs were passed without communicating their wired TNs, allowing nearby code to clobber them. Many thanks to Andrew Wolven and Gilbert Baumann for sharing technical details. Jesse _______________________________________________ Sbcl-devel mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/sbcl-devel
0001-Return-allocated-TNs-and-lambda-from-record-arg-tn.patch
(application/octet-stream, 10.7 KB)
From 54ae4a34699d5b408797b829e4351884769f0ea9 Mon Sep 17 00:00:00 2001 From: Jesse Bouwman <[email protected]> Date: Thu, 5 Feb 2026 08:16:58 -0800 Subject: [PATCH] Return allocated TNs and lambda from record-arg-tn --- src/compiler/aliencomp.lisp | 37 +++++++++--- src/compiler/arm64/c-call.lisp | 36 ++++++------ src/compiler/x86-64/c-call.lisp | 76 +++++++++++++------------ tests/alien-struct-by-value.impure.lisp | 12 ++++ 4 files changed, 99 insertions(+), 62 deletions(-) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 18a6b4f40..a43d96836 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -787,6 +787,21 @@ (t (if (eq spec '*) *wild-type* (values-specifier-type spec)))))) +;;; arg-tn-loader bundles struct-by-value argument data: TNs for +;;; register allocator visibility and a function to emit load VOPs. +(defstruct (arg-tn-loader + (:constructor make-arg-tn-loader (tns fn)) + (:copier nil) + (:predicate arg-tn-loader-p)) + (tns nil :type list :read-only t) + (fn nil :type function :read-only t)) + +(defun extract-arg-tns (entry) + "Extract TNs from an arg-tns entry." + (if (arg-tn-loader-p entry) + (arg-tn-loader-tns entry) + (remove-if-not #'tn-p (ensure-list entry)))) + (defoptimizer (%alien-funcall ltn-annotate) ((function type &rest args) node) (setf (basic-combination-info node) :funny) @@ -843,13 +858,17 @@ ;; KLUDGE: This is where the second half of the ARM ;; register-pressure change lives (see above). (dolist (tn #-arm arg-tns #+arm (reverse arg-tns)) - (if (functionp tn) - (funcall tn (pop args) call block nsp) - ;; On PPC, TN might be a list. This is used to indicate - ;; something special needs to happen. See below. - ;; - ;; FIXME: We should implement something better than this. - (let* ((first-tn (if (listp tn) (car tn) tn)) + (cond ((arg-tn-loader-p tn) + ;; Struct-by-value: call loader, TNs exposed via arg-tn-loader-tns + (funcall (arg-tn-loader-fn tn) (pop args) call block nsp)) + ((functionp tn) + (funcall tn (pop args) call block nsp)) + (t + ;; On PPC, TN might be a list. This is used to indicate + ;; something special needs to happen. See below. + ;; + ;; 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)) @@ -904,11 +923,11 @@ (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))))))) + float-tn i1-tn)))))))) (aver (null args)) (let* ((result-tns (ensure-list result-tns)) (arg-operands - (reference-tn-list (remove-if-not #'tn-p (flatten-list arg-tns)) nil)) + (reference-tn-list (mapcan #'extract-arg-tns arg-tns) nil)) (result-operands (reference-tn-list (remove-if-not #'tn-p result-tns) t))) ;; For large struct returns, set the sret pointer register diff --git a/src/compiler/arm64/c-call.lisp b/src/compiler/arm64/c-call.lisp index 425ba00a4..03843f4e4 100644 --- a/src/compiler/arm64/c-call.lisp +++ b/src/compiler/arm64/c-call.lisp @@ -356,23 +356,25 @@ (incf offset 8)))) (setf arg-tns (nreverse arg-tns)) (setf offsets (nreverse offsets)) - ;; Return a function that emits the load VOPs - (lambda (arg call block nsp) - (declare (ignore nsp)) - (let ((sap-tn (sb-c::lvar-tn call block arg))) - (loop for target-tn in arg-tns - for (off . class) in offsets - do (sb-c::emit-and-insert-vop - call block - (sb-c::template-or-lose - (ecase class - (:integer 'sap-ref-64-c) - (:single 'sap-ref-single-c) - (:double 'sap-ref-double-c))) - (sb-c::reference-tn sap-tn nil) - (sb-c::reference-tn target-tn t) - nil - (list off))))))))) + ;; Return arg-tn-loader with TNs exposed for register allocator + (sb-c::make-arg-tn-loader + arg-tns + (lambda (arg call block nsp) + (declare (ignore nsp)) + (let ((sap-tn (sb-c::lvar-tn call block arg))) + (loop for target-tn in arg-tns + for (off . class) in offsets + do (sb-c::emit-and-insert-vop + call block + (sb-c::template-or-lose + (ecase class + (:integer 'sap-ref-64-c) + (:single 'sap-ref-single-c) + (:double 'sap-ref-double-c))) + (sb-c::reference-tn sap-tn nil) + (sb-c::reference-tn target-tn t) + nil + (list off)))))))))) (defun make-call-out-tns (type) (let ((arg-state (make-arg-state)) diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp index 975656a0e..ba8edb7a3 100644 --- a/src/compiler/x86-64/c-call.lisp +++ b/src/compiler/x86-64/c-call.lisp @@ -346,26 +346,28 @@ Floats are passed in integer registers." (let ((classification (classify-struct type)) (arg-tn (int-arg state 'unsigned-byte-64 unsigned-reg-sc-number unsigned-stack-sc-number))) - (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))) - (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::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))) + (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))))))) ;;; System V: structs >16 bytes copied to stack, <=16 bytes in up to 2 ;;; registers. @@ -417,22 +419,24 @@ Floats are passed in integer registers." (incf offset 8)) (setf arg-tns (nreverse arg-tns)) (setf offsets (nreverse offsets)) - ;; Return a function that emits the load VOPs - (lambda (arg call block nsp) - (declare (ignore nsp)) - (let ((sap-tn (sb-c::lvar-tn call block arg))) - (loop for target-tn in arg-tns - for (off . class) in offsets - do (let ((vop (ecase class - (:integer 'load-struct-int-arg) - (:double 'load-struct-sse-arg)))) - (sb-c::emit-and-insert-vop - call block - (sb-c::template-or-lose vop) - (sb-c::reference-tn sap-tn nil) - (sb-c::reference-tn target-tn t) - nil - (list off)))))))))) + ;; Return arg-tn-loader with TNs exposed for register allocator + (sb-c::make-arg-tn-loader + arg-tns + (lambda (arg call block nsp) + (declare (ignore nsp)) + (let ((sap-tn (sb-c::lvar-tn call block arg))) + (loop for target-tn in arg-tns + for (off . class) in offsets + do (let ((vop (ecase class + (:integer 'load-struct-int-arg) + (:double 'load-struct-sse-arg)))) + (sb-c::emit-and-insert-vop + call block + (sb-c::template-or-lose vop) + (sb-c::reference-tn sap-tn nil) + (sb-c::reference-tn target-tn t) + nil + (list off))))))))) ;;; VOP to set up hidden struct return pointer in first arg register. #+win32 diff --git a/tests/alien-struct-by-value.impure.lisp b/tests/alien-struct-by-value.impure.lisp index d34f0bee3..790531f73 100644 --- a/tests/alien-struct-by-value.impure.lisp +++ b/tests/alien-struct-by-value.impure.lisp @@ -119,6 +119,18 @@ (assert (= (slot result 'm0) 11111)) (assert (= (slot result 'm1) 22222))))) +;;; Test that wired TNs for struct-by-value args survive register pressure. +;;; FORMAT before alien-funcall can clobber argument registers if the TNs +;;; aren't exposed to the register allocator via arg-operands. +(defun test-struct-arg-register-lifetime (a b) + (with-alien ((s (struct small-align-8))) + (setf (slot s 'm0) a (slot s 'm1) b) + (format (make-broadcast-stream) "m0=~A m1=~A" (slot s 'm0) (slot s 'm1)) + (small-align-8-get-m0 s))) + +(with-test (:name :struct-by-value-register-lifetime-bug) + (assert (= (test-struct-arg-register-lifetime 42 60) 42))) + ;;; Large struct, alignment 8 (too big for registers, uses hidden pointer) (define-alien-type nil (struct large-align-8 -- 2.50.1 (Apple Git-155)