mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
x86-64: fix passing packed structs by value
Reported by Andrew Wolven.
This commit is contained in:
Stas Boukarev
parent
b746310040
commit
ce99730828
|
|
@ -1158,10 +1158,10 @@
|
|||
(ecase kind
|
||||
(:union
|
||||
(load-time-value
|
||||
(!make-alien-record-type :kind :union)))
|
||||
(!make-alien-record-type :kind :union :bits 0 :alignment 1)))
|
||||
(:struct
|
||||
(load-time-value
|
||||
(!make-alien-record-type :kind :struct))))))))
|
||||
(!make-alien-record-type :kind :struct :bits 0 :alignment 1))))))))
|
||||
(define-alien-type-translator union (name &rest fields &environment env)
|
||||
(parse-alien-record-type :union name fields env))
|
||||
(define-alien-type-translator struct (name &rest fields &environment env)
|
||||
|
|
|
|||
|
|
@ -158,9 +158,9 @@
|
|||
|
||||
Walks fields recursively, descending into nested records and arrays
|
||||
so each leaf scalar contributes to the eightbyte it lands in."
|
||||
(let* ((bits (sb-alien::alien-type-bits record-type))
|
||||
(let* ((bits (alien-type-bits record-type))
|
||||
(byte-size (ceiling bits 8))
|
||||
(alignment (sb-alien::alien-type-alignment record-type)))
|
||||
(alignment (alien-type-alignment record-type)))
|
||||
;; Rule: Structs > 16 bytes always use memory (hidden pointer)
|
||||
(when (> byte-size 16)
|
||||
(return-from classify-struct
|
||||
|
|
@ -170,72 +170,73 @@
|
|||
:alignment alignment
|
||||
:memory-p t)))
|
||||
|
||||
(let* ((num-eightbytes (max 1 (ceiling byte-size 8)))
|
||||
(let* ((num-eightbytes (ceiling byte-size 8))
|
||||
(eightbytes (make-list num-eightbytes :initial-element :no-class)))
|
||||
(labels ((merge-leaf (offset-bytes size-bytes class)
|
||||
(loop for byte-offset from offset-bytes
|
||||
below (+ offset-bytes size-bytes)
|
||||
by 8
|
||||
for eb = (floor byte-offset 8)
|
||||
when (< eb num-eightbytes)
|
||||
do (setf (nth eb eightbytes)
|
||||
(merge-classes (nth eb eightbytes) class))))
|
||||
(labels ((merge-leaf (offset-bytes size-bytes class align-bytes)
|
||||
(if (and (> align-bytes 0)
|
||||
(plusp (mod offset-bytes align-bytes)))
|
||||
;; Unaligned fields go to memory
|
||||
(setf (first eightbytes) :memory)
|
||||
(loop for byte-offset from offset-bytes
|
||||
below (+ offset-bytes size-bytes)
|
||||
by 8
|
||||
for eb = (floor byte-offset 8)
|
||||
when (< eb num-eightbytes)
|
||||
do (setf (nth eb eightbytes)
|
||||
(merge-classes (nth eb eightbytes) class)))))
|
||||
(walk (type offset-bytes)
|
||||
(cond
|
||||
((sb-alien::alien-record-type-p type)
|
||||
(dolist (field (sb-alien::alien-record-type-fields type))
|
||||
(walk (sb-alien::alien-record-field-type field)
|
||||
((alien-record-type-p type)
|
||||
(dolist (field (alien-record-type-fields type))
|
||||
(walk (alien-record-field-type field)
|
||||
(+ offset-bytes
|
||||
(floor (sb-alien::alien-record-field-offset field) 8)))))
|
||||
((sb-alien::alien-array-type-p type)
|
||||
(let* ((elt (sb-alien::alien-array-type-element-type type))
|
||||
(elt-bytes (ceiling (sb-alien::alien-type-bits elt) 8))
|
||||
(n (or (first (sb-alien::alien-array-type-dimensions type)) 0)))
|
||||
(floor (alien-record-field-offset field) 8)))))
|
||||
((alien-array-type-p type)
|
||||
(let* ((elt (alien-array-type-element-type type))
|
||||
(elt-bytes (ceiling (alien-type-bits elt) 8))
|
||||
(n (or (first (alien-array-type-dimensions type)) 0)))
|
||||
(dotimes (i n)
|
||||
(walk elt (+ offset-bytes (* i elt-bytes))))))
|
||||
;; Leaf scalar
|
||||
(t
|
||||
(merge-leaf offset-bytes
|
||||
(ceiling (sb-alien::alien-type-bits type) 8)
|
||||
(classify-field-sysv-amd64 type))))))
|
||||
(ceiling (alien-type-bits type) 8)
|
||||
(classify-field-sysv-amd64 type)
|
||||
(floor (alien-type-alignment type) 8))))))
|
||||
(walk record-type 0))
|
||||
|
||||
;; Post-merge cleanup per ABI: if second eightbyte is MEMORY, first must be too
|
||||
(when (and (> num-eightbytes 1)
|
||||
(eq (second eightbytes) :memory))
|
||||
(setf (first eightbytes) :memory))
|
||||
|
||||
;; Convert remaining :no-class to :integer (padding bytes are treated as integer)
|
||||
(setf eightbytes
|
||||
(mapcar (lambda (c) (if (eq c :no-class) :integer c)) eightbytes))
|
||||
|
||||
(if (member :memory eightbytes)
|
||||
;; If anything goes to memory then everything goes too
|
||||
(setf eightbytes '(:memory))
|
||||
;; Convert remaining :no-class to :integer (padding bytes are treated as integer)
|
||||
(setf eightbytes
|
||||
(mapcar (lambda (c) (if (eq c :no-class) :integer c)) eightbytes)))
|
||||
(sb-alien::make-struct-classification
|
||||
:register-slots eightbytes
|
||||
:size byte-size
|
||||
:alignment alignment
|
||||
:memory-p (member :memory eightbytes)))))
|
||||
:memory-p (and (member :memory eightbytes) t)))))
|
||||
|
||||
#+win32
|
||||
(defun classify-struct (record-type)
|
||||
"Classify struct for Windows AMD64 ABI.
|
||||
Size-based only: <=8 bytes in single integer register, >8 bytes via pointer.
|
||||
Floats are passed in integer registers."
|
||||
(let* ((bits (sb-alien::alien-type-bits record-type))
|
||||
(let* ((bits (alien-type-bits record-type))
|
||||
(byte-size (ceiling bits 8))
|
||||
(alignment (sb-alien::alien-type-alignment record-type)))
|
||||
(if (> byte-size 8)
|
||||
(alignment (alien-type-alignment record-type)))
|
||||
(if (member byte-size '(1 2 4 8))
|
||||
;; Small aligned struct: single integer
|
||||
(sb-alien::make-struct-classification
|
||||
:register-slots '(:integer)
|
||||
:size byte-size
|
||||
:alignment alignment
|
||||
:memory-p nil)
|
||||
;; Large struct: hidden pointer
|
||||
(sb-alien::make-struct-classification
|
||||
:register-slots '(:memory)
|
||||
:size byte-size
|
||||
:alignment alignment
|
||||
:memory-p t)
|
||||
;; Small struct: single integer
|
||||
(sb-alien::make-struct-classification
|
||||
:register-slots '(:integer)
|
||||
:size byte-size
|
||||
:alignment alignment
|
||||
:memory-p nil))))
|
||||
:memory-p t))))
|
||||
|
||||
;;; Result TN generation for record types
|
||||
;;; Called from src/code/c-call.lisp
|
||||
|
|
|
|||
|
|
@ -442,3 +442,51 @@ struct three_u64 three_u64_from_u128(__uint128_t x) {
|
|||
s.c = s.a ^ s.b;
|
||||
return s;
|
||||
}
|
||||
|
||||
#include <stdint.h>
|
||||
|
||||
typedef struct __attribute__((packed)) {
|
||||
uint8_t a;
|
||||
uint16_t b;
|
||||
} Struct3B;
|
||||
|
||||
uint32_t sum_struct_3b(Struct3B s) {
|
||||
return (uint32_t)s.a + (uint32_t)s.b;
|
||||
}
|
||||
|
||||
typedef struct __attribute__((packed)) {
|
||||
uint64_t first;
|
||||
uint8_t tag;
|
||||
uint16_t unaligned;
|
||||
} StructUnalignedSecond;
|
||||
|
||||
uint64_t sum_unaligned_second(StructUnalignedSecond s) {
|
||||
return s.first + s.tag + s.unaligned;
|
||||
}
|
||||
|
||||
typedef struct {} StructEmpty;
|
||||
|
||||
int32_t check_empty_struct(StructEmpty s, int32_t val) {
|
||||
(void)s;
|
||||
return val * 2;
|
||||
}
|
||||
|
||||
typedef struct __attribute__((packed)) {
|
||||
uint8_t pad;
|
||||
uint16_t unaligned;
|
||||
uint64_t b;
|
||||
} StructMemFirst;
|
||||
|
||||
uint64_t sum_mem_first(StructMemFirst s) {
|
||||
return (uint64_t)s.pad + (uint64_t)s.unaligned + s.b;
|
||||
}
|
||||
|
||||
typedef struct {
|
||||
unsigned __int128 val;
|
||||
} StructInt128;
|
||||
|
||||
StructInt128 make_int128(uint64_t low, uint64_t high) {
|
||||
StructInt128 s;
|
||||
s.val = ((unsigned __int128)high << 64) | low;
|
||||
return s;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -806,3 +806,79 @@
|
|||
(assert (= (slot s 'a) low))
|
||||
(assert (= (slot s 'b) high))
|
||||
(assert (= (slot s 'c) (logxor low high)))))
|
||||
|
||||
|
||||
(sb-alien:define-alien-type struct-3b
|
||||
(sb-alien:struct nil
|
||||
(a (sb-alien:unsigned 8))
|
||||
(b (sb-alien:unsigned 16) :offset 8 :alignment 8)))
|
||||
|
||||
(sb-alien:define-alien-routine ("sum_struct_3b" sum-struct-3b) (sb-alien:unsigned 32)
|
||||
(s struct-3b))
|
||||
|
||||
(with-test (:name :unaligned-3byte-struct)
|
||||
(sb-alien:with-alien ((s3 struct-3b))
|
||||
(setf (sb-alien:slot s3 'a) 5
|
||||
(sb-alien:slot s3 'b) 300)
|
||||
(assert (= (sum-struct-3b s3) 305))))
|
||||
|
||||
(sb-alien:define-alien-type struct-unaligned-second
|
||||
(sb-alien:struct nil
|
||||
(first (sb-alien:unsigned 64) :offset 0)
|
||||
(tag (sb-alien:unsigned 8) :offset 64)
|
||||
(unaligned (sb-alien:unsigned 16) :offset 72)))
|
||||
|
||||
(sb-alien:define-alien-routine ("sum_unaligned_second" sum-unaligned-second)
|
||||
(sb-alien:unsigned 64)
|
||||
(s struct-unaligned-second))
|
||||
|
||||
(with-test (:name :unaligned-second-eightbyte-in-memory)
|
||||
(sb-alien:with-alien ((s struct-unaligned-second))
|
||||
(setf (sb-alien:slot s 'first) 1000
|
||||
(sb-alien:slot s 'tag) 5
|
||||
(sb-alien:slot s 'unaligned) 400)
|
||||
(assert (= (sum-unaligned-second s) 1405))))
|
||||
|
||||
(sb-alien:define-alien-type struct-empty
|
||||
(sb-alien:struct nil))
|
||||
|
||||
(sb-alien:define-alien-routine ("check_empty_struct" check-empty-struct)
|
||||
(sb-alien:signed 32)
|
||||
(s struct-empty)
|
||||
(val (sb-alien:signed 32)))
|
||||
|
||||
(with-test (:name :empty-struct-consumes-no-registers)
|
||||
(sb-alien:with-alien ((s struct-empty))
|
||||
(assert (= (check-empty-struct s 21) 42))))
|
||||
|
||||
(sb-alien:define-alien-type struct-mem-first
|
||||
(sb-alien:struct nil
|
||||
(pad (sb-alien:unsigned 8) :offset 0)
|
||||
(unaligned (sb-alien:unsigned 16) :offset 8)
|
||||
(b (sb-alien:unsigned 64) :offset 24)))
|
||||
|
||||
(sb-alien:define-alien-routine ("sum_mem_first" sum-mem-first)
|
||||
(sb-alien:unsigned 64)
|
||||
(s struct-mem-first))
|
||||
|
||||
(with-test (:name :memory-first-eightbyte-propagation)
|
||||
(sb-alien:with-alien ((s struct-mem-first))
|
||||
(setf (sb-alien:slot s 'pad) 7
|
||||
(sb-alien:slot s 'unaligned) 300
|
||||
(sb-alien:slot s 'b) 5000)
|
||||
(assert (= (sum-mem-first s) 5307))))
|
||||
|
||||
;; (sb-alien:define-alien-type struct-int128
|
||||
;; (sb-alien:struct nil
|
||||
;; (val (sb-alien:unsigned 128))))
|
||||
|
||||
;; (sb-alien:define-alien-routine ("make_int128" make-int128)
|
||||
;; struct-int128
|
||||
;; (low (sb-alien:unsigned 64))
|
||||
;; (high (sb-alien:unsigned 64)))
|
||||
|
||||
;; (with-test (:name :leaf-spanning-two-eightbytes)
|
||||
;; (let* ((res (make-int128 #x1122334455667788 #xAABBCCDDEEFF0011))
|
||||
;; (val (sb-alien:slot res 'val))
|
||||
;; (expected (+ (ash #xAABBCCDDEEFF0011 64) #x1122334455667788)))
|
||||
;; (assert (= val expected))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue