Menu
▾
▴
[Sbcl-devel] [PATCH v3] Pass C structs by value in UNIX with x86_64
|
From: Andrea M. <mon...@gm...> - 2025-03-03 13:08:48
|
After some modifications, all structs I tested pass correctly on my system.
The code may look complex, but it's mostly the AMD64 ABI; some edge
cases may still be not covered.
I merged my tests in the sbcl tree, as suggested by Stas. The
existing tests assumed the feature was not available, so I commented
them out, but they are still valid in other platforms, so maybe they
should be conditionalized.
Let me know if you find any issue. Greetings,
Andrea
diff --git a/src/code/alieneval.lisp b/src/code/alieneval.lisp
index 71fa83e06..ea70d9942 100644
--- a/src/code/alieneval.lisp
+++ b/src/code/alieneval.lisp
@@ -51,7 +51,7 @@
(defun alien-type-class-name->id (name)
(or (position name '(root integer boolean enum float single-float
double-float
system-area-pointer alien-value pointer mem-block array
- record fun values c-string))
+ record fun values c-string record-chunk))
(error "alien-type-class ~S does not have an index" name)))
(defstruct (alien-type-class (:copier nil))
@@ -147,7 +147,7 @@
;; ENUM and RECORD have handwritten caching constructors.
(unless (member name '(float mem-block alien-value
single-float double-float system-area-pointer
- record enum))
+ record record-chunk enum))
(symbolicate "*" defstruct-name "-CACHE*"))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -174,7 +174,8 @@
(defun ,constructor (&key ,@constructor-args)
(let ((hash ,(ash (alien-type-class-name->id name)
type-hash-nbits)))
(,allocator hash ,@allocator-args)))))
- ((member name '(single-float double-float
system-area-pointer)) ; singletons
+ ((member name '(single-float double-float system-area-pointer
+ record-chunk)) ; singletons
`((declaim (inline ,constructor))
(defun ,constructor (&key ,@constructor-args)
(let ((hash ,(logior (ash (alien-type-class-name->id
name) type-hash-nbits)
@@ -833,6 +834,14 @@
(declare (ignore type))
`(sap-ref-sap ,sap (/ ,offset sb-vm:n-byte-bits)))
+;; This alien type is only used when passing a struct by value. It basically
+;; means "pass these 64 bits on the stack"
+(define-alien-type-class (record-chunk))
+
+(define-alien-type-method (record-chunk :unparse) (type state)
+ (declare (ignore type))
+ 'record-chunk)
+
(macrolet
((def-singleton-type (type bits (ctor &rest rest))
`(progn
@@ -852,7 +861,9 @@
(def-singleton-type single-float 32 (!make-alien-single-float-type
:type 'single-float))
(def-singleton-type double-float 64 (!make-alien-double-float-type
:type 'double-float))
(def-singleton-type system-area-pointer sb-vm:n-machine-word-bits
- (!make-alien-system-area-pointer-type)))
+ (!make-alien-system-area-pointer-type))
+ (def-singleton-type record-chunk 64 (!make-alien-record-chunk-type)))
+
;;;; the ALIEN-VALUE type
@@ -1491,7 +1502,7 @@
(macrolet ((mix* (&rest items)
(list 'quote (reduce (lambda (a b) `(mix ,a
,b)) items))))
(ecase class-name
- ((alien-value mem-block) 0)
+ ((alien-value mem-block record-chunk) 0)
(pointer '(if to (alien-type-hash to) #xBAD))
(c-string ; Don't need ALIEN-POINTER-TYPE-TO as it's invariant
(mix* (sb-kernel:symbol-hash element-type)
diff --git a/src/code/c-call.lisp b/src/code/c-call.lisp
index ddc9a158d..dd2f90972 100644
--- a/src/code/c-call.lisp
+++ b/src/code/c-call.lisp
@@ -140,9 +140,9 @@
;; All platforms have passing SAP defined, which causes passing record by value
;; to silently corrupt.
;; -- Rongcui
-(define-alien-type-method (record :arg-tn) (type state)
- (declare (ignore type state))
- (error "Passing structs by value is unsupported on this platform."))
+;;(define-alien-type-method (record :arg-tn) (type state)
+;; (declare (ignore type state))
+;; (error "Passing structs by value is unsupported on this platform."))
(define-alien-type-method (record :result-tn) (type state)
(declare (ignore type state))
(error "Returning structs by value is unsupported on this platform."))
diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 7a2e0d8e3..9324ad970 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -67,6 +67,12 @@
(declare (ignore type))
(float-arg state 'single-float single-reg-sc-number single-stack-sc-number))
+(define-alien-type-method (sb-alien::record-chunk :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ frame-size))
+ (make-wired-tn* 'unsigned-byte-64 unsigned-stack-sc-number frame-size)))
+
(defstruct (result-state (:copier nil))
(num-results 0))
(declaim (freeze-type result-state))
@@ -140,8 +146,11 @@
(result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
(if (or (some #'(lambda (type)
- (and (alien-integer-type-p type)
- (> (sb-alien::alien-integer-type-bits type) 64)))
+ (or
+ (and (alien-integer-type-p type)
+ (> (sb-alien::alien-integer-type-bits type) 64))
+ (and (alien-record-type-p type)
+ (eq (sb-alien::alien-record-type-kind
type) :struct))))
arg-types)
(and (alien-integer-type-p result-type)
(> (sb-alien::alien-integer-type-bits result-type) 64)))
@@ -161,6 +170,63 @@
(if (alien-integer-type-signed type)
(new-arg-types (parse-alien-type '(signed 64) env))
(new-arg-types (parse-alien-type '(unsigned
64) env))))
+ ((and (alien-record-type-p type)
+ (eq (sb-alien::alien-record-type-kind type) :struct))
+ ;; This is based on "System V Application Binary Interface
+ ;; AMD64 Architecture Processor Supplement", chapter 3.2.3
+ (labels ((combine-arg-classes (cl1 cl2)
+ (cond
+ ((member :memory (list cl1 cl2))
+ :memory)
+ ((member :integer (list cl1 cl2))
+ :integer)
+ (t
+ :float)))
+ (compute-arg-class (type argcl)
+ (cond
+ ((< 128 (alien-type-bits type))
+ :memory)
+ ((or (alien-integer-type-p type)
+ (alien-pointer-type-p type))
+ (combine-arg-classes :integer argcl))
+ ((alien-float-type-p type)
+ (combine-arg-classes :float argcl))
+ ((alien-array-type-p type)
+ (combine-arg-classes
+ (compute-arg-class
(alien-array-type-element-type type)
+ nil)
+ argcl))
+ ((alien-record-type-p type)
+ (let (cl)
+ (dolist (f
(alien-record-type-fields type))
+ (setq cl (compute-arg-class
+
(alien-record-field-type f) cl)))
+ (combine-arg-classes cl argcl))))))
+ (let* ((fields (alien-record-type-fields type))
+ (bits (alien-type-bits type))
+ (all-in-memory (< 128 bits)))
+ (dotimes (i (ceiling bits 64))
+ (let (arg-class)
+ (if all-in-memory
+ (setq arg-class :memory)
+ (do nil
+ ((or (not fields)
+ (<= (* 64 (1+ i))
+
(alien-record-field-offset (car fields)))))
+ (setq arg-class (compute-arg-class
+
(alien-record-field-type (car fields))
+ arg-class))
+ (setq fields (cdr fields))))
+ (new-args (if (eq arg-class :float)
+ `(sap-ref-double ,arg ,(* i 8))
+ `(sap-ref-64 ,arg ,(* i 8))))
+ (new-arg-types (cond
+ ((eq arg-class :memory)
+ (parse-alien-type
'sb-alien::record-chunk env))
+ ((eq arg-class :integer)
+ (parse-alien-type
'(unsigned 64) env))
+ ((eq arg-class :float)
+ (parse-alien-type
'(double-float) env)))))))))
(t
(new-args arg)
(new-arg-types type)))))
diff --git a/tests/alien-struct-by-value.c b/tests/alien-struct-by-value.c
index 6d63555bc..80bd262d0 100644
--- a/tests/alien-struct-by-value.c
+++ b/tests/alien-struct-by-value.c
@@ -68,3 +68,93 @@ void large_align_8_mutate(volatile struct large_align_8 m) {
m.m14++;
m.m15++;
}
+
+
+/* Various small structs and functions that get them by value */
+
+struct
+point1
+{
+ int x, *y;
+};
+
+int get_point1 (char c, volatile struct point1 p, float f)
+{
+ return p.x;
+}
+
+struct
+point2
+{
+ char ch;
+ int x, y, z;
+};
+
+int get_point2 (char c, volatile struct point2 p, float f)
+{
+ return p.y;
+}
+
+float get_point2_2 (char c, volatile struct point2 p, float f)
+{
+ return f;
+}
+
+struct
+point3
+{
+ char ch;
+ int w, x, y, z;
+};
+
+int get_point3 (char c, volatile struct point3 p, float f)
+{
+ return p.x;
+}
+
+struct
+point4
+{
+ double x, y;
+};
+
+double get_point4 (char c, volatile struct point4 p, float f)
+{
+ return p.y;
+}
+
+struct
+point5
+{
+ char x, y, z;
+};
+
+char get_point5 (char c, volatile struct point5 p, float f)
+{
+ return p.x;
+}
+
+struct
+point6
+{
+ float x;
+ int y;
+};
+
+float get_point6 (char c, volatile struct point6 p, float f)
+{
+ return p.x;
+}
+
+struct
+point7
+{
+ float x;
+ char y[3];
+ double z;
+};
+
+double get_point7 (float f, volatile struct point7 p, char c)
+{
+ return p.z;
+}
diff --git a/tests/alien-struct-by-value.impure.lisp
b/tests/alien-struct-by-value.impure.lisp
index 19570dd89..b4cc1fcd2 100644
--- a/tests/alien-struct-by-value.impure.lisp
+++ b/tests/alien-struct-by-value.impure.lisp
@@ -37,6 +37,7 @@
(assert-error (eval '(progn ,def
,(if argp `(with-alien ((x ,(second arg)))
(,name x)) '(name)))))))
+#|
;;; Tiny struct, alignment 8
(define-alien-type nil (struct tiny-align-8 (m0 (integer 64))))
(with-test (:name :struct-by-value-tiny-align-8-args)
@@ -69,6 +70,73 @@
(defs-large-align-8-get)
(assert-unimplemented
(define-alien-routine large-align-8-mutate void (m (struct
large-align-8))))))
+|#
+
+;;; Various small structs
+
+(define-alien-type point1 (struct point1 (x int) (y (* int))))
+(define-alien-type point2 (struct point2 (ch char) (x int) (y int) (z int)))
+(define-alien-type point3 (struct point3 (ch char) (w int) (x int) (y
int) (z int)))
+(define-alien-type point4 (struct point4 (x double) (y double)))
+(define-alien-type point5 (struct point5 (x char) (y char) (z char)))
+(define-alien-type point6 (struct point6 (x float) (y int)))
+(define-alien-type point7 (struct point7 (x float) (y (array char 3))
(z double)))
+
+(defparameter p1 (make-alien (struct point1)))
+(defparameter p2 (make-alien (struct point2)))
+(defparameter p3 (make-alien (struct point3)))
+(defparameter p4 (make-alien (struct point4)))
+(defparameter p5 (make-alien (struct point5)))
+(defparameter p6 (make-alien (struct point6)))
+(defparameter p7 (make-alien (struct point7)))
+
+(with-test (:name :small-structs-by-value)
+ (setf (slot p1 'x) 10)
+ (assert (= 10
+ (alien-funcall (extern-alien "get_point1" (function int
char point1 float))
+ 45 (deref p1) 1.1)))
+
+ (setf (slot p2 'y) 21)
+ (assert (= 21
+ (alien-funcall (extern-alien "get_point2" (function int
char point2 float))
+ 45 (deref p2) 1.2)))
+ (assert (= 1.2
+ (alien-funcall (extern-alien "get_point2_2" (function
float char point2 float))
+ 45 (deref p2) 1.2)))
+
+ (setf (slot p3 'x) 30)
+ (assert (= 30
+ (alien-funcall (extern-alien "get_point3" (function int
char point3 float))
+ 45 (deref p3) 1.2)))
+
+ (setf (slot p4 'y) 4.2d0)
+ (assert (= 4.2d0
+ (alien-funcall (extern-alien "get_point4" (function
double char point4 float))
+ 45 (deref p4) 1.2)))
+
+ (setf (slot p5 'x) 47)
+ (assert (= 47
+ (alien-funcall (extern-alien "get_point5" (function int
char point5 float))
+ 45 (deref p5) 1.2)))
+
+ (setf (slot p6 'x) 6.1)
+ (assert (= 6.1
+ (alien-funcall (extern-alien "get_point6" (function
float char point6 float))
+ 45 (deref p6) 1.6)))
+
+ (setf (slot p7 'z) 7.2d0)
+ (assert (= 7.2d0
+ (alien-funcall (extern-alien "get_point7" (function
double float point7 char))
+ 4.9 (deref p7) 50))))
+
+(free-alien p1)
+(free-alien p2)
+(free-alien p3)
+(free-alien p4)
+(free-alien p5)
+(free-alien p6)
+(free-alien p7)
+
;;; Clean up
#-win32 (ignore-errors (delete-file *soname*))
|
