common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

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

Browse source
This commit is contained in:
Jesse Bouwman 2026-04-26 10:41:45 -07:00
parent f735fd577c
commit f484412bc4
3 changed files with 54 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
src/compiler/x86-64/c-call.lisp
View file

@ -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))

6
tests/alien-struct-access.c
View file

@ -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;

18
tests/alien-struct-access.impure.lisp
View file

@ -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)))))