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

Support struct-by-value for x86-64 and ARM64 foreign calls

Browse source 
Add the ability to pass and return C structs by value in alien
function calls and callbacks on x86-64 linux and ARM64 darwin. Note

- x86-64: eightbyte classification with INTEGER/SSE register classes
- ARM64: HFA detection for float aggregates, GPR pairs for small structs

Large structs (>16 bytes) use hidden pointer passing. Small structs
are unpacked from registers into heap on return.

Callbacks preserve the hidden return pointer across the Lisp call and
copy results to the caller-provided destination.
This commit is contained in:
Jesse Bouwman 2026-01-13 14:35:57 -08:00 committed by Stas Boukarev
parent 6b7b3b5524
commit e9baa62bff
10 changed files with 2205 additions and 194 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
doc/manual/ffi.texinfo
View file

@ -738,17 +738,11 @@ The type of @code{alien-function} must be @code{(alien (function
...))} or @code{(alien (* (function ...)))}. The function type is
used to determine how to call the function (as though it was declared
with a prototype.) The type need not be known at compile time, but
only known-type calls are efficiently compiled. Limitations:
only known-type calls are efficiently compiled.
@itemize
@item
Structure type return values are not implemented.
@item
Passing of structures by value is not implemented.
@end itemize
On unix-like x86-64 and ARM64 systems, structures may be passed and
returned by value. The implementation follows the System V AMD64 ABI
and AAPCS64 specifications respectively.
@end defun
@ -1034,6 +1028,8 @@ an interface for calling into Lisp as a shared library directly from C.
The @code{define-alien-callable} macro wraps Lisp code and creates a C
foreign function which can be called with the C calling convention.
On x86-64 and ARM64, callbacks may receive and return structures by
value.
@include macro-sb-alien-define-alien-callable.texinfo

22
src/code/alien-callback.lisp
View file

@ -100,12 +100,16 @@
(defun alien-callback-argument-bytes (spec env)
(let ((type (parse-alien-type spec env)))
(if (or (alien-integer-type-p type)
(alien-float-type-p type)
(alien-pointer-type-p type)
(alien-system-area-pointer-type-p type))
(ceiling (alien-type-word-aligned-bits type) sb-vm:n-byte-bits)
(error "Unsupported callback argument type: ~A" type))))
(cond ((or (alien-integer-type-p type)
(alien-float-type-p type)
(alien-pointer-type-p type)
(alien-system-area-pointer-type-p type))
(ceiling (alien-type-word-aligned-bits type) sb-vm:n-byte-bits))
;; Struct types: return the struct size rounded up to word alignment
((alien-record-type-p type)
(ceiling (alien-type-word-aligned-bits type) sb-vm:n-byte-bits))
(t
(error "Unsupported callback argument type: ~A" type)))))
(defun enter-alien-callback (index arguments return)
(declare (optimize speed (safety 0)))
@ -201,6 +205,12 @@
`(unsigned
,(alien-type-word-aligned-bits result-type))
`(unsigned-byte ,(alien-type-bits result-type)))))
;; For struct return types, wrap in WITH-OUTER-ALIEN-STACK-CLEANUP
;; so inner WITH-ALIEN forms defer cleanup to this outer binding.
;; This ensures allocations survive until the struct is copied.
((alien-record-type-p result-type)
`(with-outer-alien-stack-cleanup
,(store (unparse-alien-type result-type) nil)))
(t
(store (unparse-alien-type result-type) nil))))))
0))))

91
src/code/c-call.lisp
View file

@ -135,14 +135,83 @@
(simple-string
(string-to-c-string ,value
(c-string-external-format ,type)))))))
;;;; Struct Support (or the lack thereof)
;; NOTE: RECORD follows the hierarchy of RECORD -> MEM-BLOCK -> ALIEN-VALUE -> SAP.
;; 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 :result-tn) (type state)
(declare (ignore type state))
(error "Returning structs by value is unsupported on this platform."))
;;;; Struct Return-by-Value Support
;;; Classification categories for struct fields/eightbytes per ABI.
;;; These values have architecture-specific semantics:
;;;
;;; :integer - Pass/return in general-purpose registers (RAX/RDX on x86-64,
;;; x0/x1 on ARM64). Used for integer, pointer, and mixed types.
;;;
;;; :single - ARM64 HFA (Homogeneous Floating-point Aggregate) only.
;;; Pass/return in single-precision FP registers (s0-s3).
;;; x86-64 never uses this; single-floats become :double (SSE class).
;;;
;;; :double - Pass/return in floating-point/SSE registers.
;;; On x86-64: SSE class (XMM0/XMM1) for both single and double floats.
;;; On ARM64: HFA double-precision (d0-d3).
;;;
;;; :memory - Struct too large for registers; pass/return via hidden pointer.
;;; x86-64: hidden pointer in RDI, returned in RAX.
;;; ARM64: hidden pointer in x8.
(deftype struct-class () '(member :integer :single :double :memory))
(defstruct (struct-classification (:copier nil))
;; List of register slot classifications
;; Each element represents one register's worth of data
(register-slots nil :type list)
;; Total size in bytes
(size 0 :type (unsigned-byte 32))
;; Required alignment
(alignment 1 :type (unsigned-byte 16))
;; Whether this struct must be returned via hidden pointer
(memory-p nil :type boolean))
;;; Main entry point: classify a struct type for ABI compliance
;;; Returns: (values in-registers-p register-slots size)
;;; in-registers-p - T if struct can be returned in registers
;;; register-slots - list of slot classes for each register
;;; size - total size in bytes (NIL if not a struct)
(defun struct-return-info (alien-type)
"Classify how a struct should be returned according to platform ABI.
Returns (values in-registers-p register-slots size) or (values nil nil nil) for non-structs."
(declare (ignorable alien-type))
#+(and arm64 (not sb-xc-host))
(progn
(unless (alien-record-type-p alien-type)
(return-from struct-return-info (values nil nil nil)))
(let ((classification (sb-vm::classify-struct-aapcs64 alien-type)))
(when classification
(values (not (struct-classification-memory-p classification))
(struct-classification-register-slots classification)
(struct-classification-size classification)))))
#+(and x86-64 (not sb-xc-host))
(progn
(unless (alien-record-type-p alien-type)
(return-from struct-return-info (values nil nil nil)))
(let ((classification (sb-vm::classify-struct-sysv-amd64 alien-type)))
(when classification
(values (not (struct-classification-memory-p classification))
(struct-classification-register-slots classification)
(struct-classification-size classification))))))
;;; Methods for struct by value - platform-specific implementations in
;;; compiler/{arch}/c-call.lisp define record-arg-tn and record-result-tn.
#+(and (or x86-64 arm64) (not sb-xc-host))
(progn
(declaim (ftype (function (t t) t) sb-vm::record-arg-tn sb-vm::record-result-tn))
(define-alien-type-method (record :arg-tn) (type state)
(sb-vm::record-arg-tn type state))
(define-alien-type-method (record :result-tn) (type state)
(sb-vm::record-result-tn type state)))
#-(and (or x86-64 arm64) (not sb-xc-host))
(progn
(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.")))

26
src/code/target-alieneval.lisp
View file

@ -103,6 +103,23 @@ This is SETFable."
(datap (not (alien-fun-type-p alien-type))))
`(%alien-value (foreign-symbol-sap ,alien-name ,datap) 0 ',alien-type)))
;;; Allow callback struct returns to signal that inner WITH-ALIEN
;;; forms should defer *alien-stack-pointer* cleanup. When a callback
;;; returns a struct by value, the struct is typically constructed
;;; using WITH-ALIEN. Without this mechanism, the WITH-ALIEN cleanup
;;; would run before the struct data is copied to the return area,
;;; causing corruption.
;;;
;;; WITH-OUTER-ALIEN-STACK-CLEANUP establishes a lexical marker (via
;;; symbol-macrolet) that WITH-ALIEN detects during its macroexpansion
;;; using macroexpand-1.
(defmacro with-outer-alien-stack-cleanup (&body body)
"Establish an outer *alien-stack-pointer* binding and signal to inner WITH-ALIEN
forms that they should skip their own cleanup. Used by callback struct returns."
`(symbol-macrolet ((%in-outer-alien-stack-cleanup-context% t))
(let ((sb-c:*alien-stack-pointer* sb-c:*alien-stack-pointer*))
,@body)))
(defmacro with-alien (bindings &body body &environment env)
"Establish some local alien variables. Each BINDING is of the form:
VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
@ -178,6 +195,15 @@ This is SETFable."
,(append *new-auxiliary-types*
(auxiliary-type-definitions env))))
,@(cond
;; When in callback struct return context, skip the binding.
;; The outer WITH-OUTER-ALIEN-STACK-CLEANUP already established
;; a single *alien-stack-pointer* binding that will clean up all
;; allocations after the struct is copied to the result area.
;; Detect this by checking for the %in-outer-alien-stack-cleanup-context%
;; symbol-macrolet marker in the lexical environment.
((and bind-alien-stack-pointer
(nth-value 1 (macroexpand-1 '%in-outer-alien-stack-cleanup-context% env)))
body)
(bind-alien-stack-pointer
;; The LET IR1-translator will actually turn this into
;; RESTORING-NSP on #-c-stack-is-control-stack to avoid

178
src/compiler/aliencomp.lisp
View file

@ -548,6 +548,30 @@
;;;; ALIEN-FUNCALL support
;;; Generate code to store struct register values to memory
#-sb-xc-host
(defun generate-struct-store-code (temps register-slots result-sap)
"Generate SETF forms to store register values to struct memory."
(let ((offset 0)
(stores nil)
(temp-idx 0))
(dolist (class register-slots)
(case class
(:integer
(push `(setf (sb-sys:sap-ref-64 ,result-sap ,offset) ,(nth temp-idx temps)) stores)
(incf offset 8)
(incf temp-idx))
(:double
(push `(setf (sb-sys:sap-ref-double ,result-sap ,offset) ,(nth temp-idx temps)) stores)
(incf offset 8)
(incf temp-idx))
;; :single is ARM64 HFA only - x86-64 classifies all floats as :double
(:single
(push `(setf (sb-sys:sap-ref-single ,result-sap ,offset) ,(nth temp-idx temps)) stores)
(incf offset 4)
(incf temp-idx))))
(nreverse stores)))
(deftransform alien-funcall ((function &rest args)
((alien (* t)) &rest t) *)
(let ((names (make-gensym-list (length args))))
@ -576,29 +600,45 @@
(params param)
(deports `(deport ,param ',arg-type))))
;; Build BODY from the inside out.
(let ((return-type (alien-fun-type-result-type alien-type))
;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
;; to them) and do the call.
(body
;; If FUNCTION's source looks like
;; (%SAP-ALIEN (FOREIGN-SYMBOL-SAP "sym") #<anything>)
;; then snarf out the string and use it as the funarg
;; unless the backend lacks the CALL-OUT-NAMED vop.
`(%alien-funcall
,(or (when-vop-existsp (:named call-out-named)
(when (lvar-matches function :fun-names '(%sap-alien)
:arg-count 2)
(let ((sap (first (combination-args (lvar-use function)))))
(when (lvar-matches sap :fun-names '(foreign-symbol-sap)
:arg-count 1)
(let ((sym (first (combination-args (lvar-use sap)))))
(when (and (constant-lvar-p sym)
(stringp (lvar-value sym)))
(setq ignore-fun t)
(lvar-value sym)))))))
`(deport function ',alien-type))
',alien-type
,@(deports))))
;; First, detect if this is a large struct return (hidden pointer)
(let* ((return-type (alien-fun-type-result-type alien-type))
;; Check for large struct return (needs hidden pointer)
#-sb-xc-host
(large-struct-size
(multiple-value-bind (in-registers-p register-slots size)
(sb-alien::struct-return-info return-type)
(declare (ignore register-slots))
(when (and size (not in-registers-p))
size)))
#+sb-xc-host
(large-struct-size nil)
;; For large struct returns, we need a gensym for the sret pointer
(sret-sap (when large-struct-size (gensym "SRET-SAP")))
;; Innermost, we DEPORT the parameters (e.g. by taking SAPs
;; to them) and do the call.
(body
;; If FUNCTION's source looks like
;; (%SAP-ALIEN (FOREIGN-SYMBOL-SAP "sym") #<anything>)
;; then snarf out the string and use it as the funarg
;; unless the backend lacks the CALL-OUT-NAMED vop.
`(%alien-funcall
,(or (when-vop-existsp (:named call-out-named)
(when (lvar-matches function :fun-names '(%sap-alien)
:arg-count 2)
(let ((sap (first (combination-args (lvar-use function)))))
(when (lvar-matches sap :fun-names '(foreign-symbol-sap)
:arg-count 1)
(let ((sym (first (combination-args (lvar-use sap)))))
(when (and (constant-lvar-p sym)
(stringp (lvar-value sym)))
(setq ignore-fun t)
(lvar-value sym)))))))
`(deport function ',alien-type))
',alien-type
;; For large struct returns, prepend sret-sap as first arg
;; IR2 will put it in the hidden pointer register (x8 on ARM64, RDI on x86-64)
,@(when sret-sap (list sret-sap))
,@(deports))))
;; Wrap that in a WITH-PINNED-OBJECTS to ensure the values
;; the SAPs are taken for won't be moved by the GC. (If
;; needed: some alien types won't need it).
@ -617,16 +657,45 @@
do (setf body
`(let ((,param (deport-alloc ,param ',arg-type)))
,body)))
(if (alien-values-type-p return-type)
(collect ((temps) (results))
(dolist (type (alien-values-type-values return-type))
(let ((temp (gensym)))
(temps temp)
(results `(naturalize ,temp ',type))))
(setf body
`(multiple-value-bind ,(temps) ,body
(values ,@(results)))))
(setf body `(naturalize ,body ',return-type)))
(cond
((alien-values-type-p return-type)
(collect ((temps) (results))
(dolist (type (alien-values-type-values return-type))
(let ((temp (gensym)))
(temps temp)
(results `(naturalize ,temp ',type))))
(setf body
`(multiple-value-bind ,(temps) ,body
(values ,@(results))))))
;; Struct-by-value return handling
#-sb-xc-host
((multiple-value-bind (in-registers-p register-slots size)
(sb-alien::struct-return-info return-type)
(cond
;; Small struct: returned in registers, store to heap memory
(in-registers-p
(let* ((num-values (length register-slots))
(temps (loop repeat num-values collect (gensym)))
(result-sap (gensym "RESULT-SAP")))
(setf body
`(multiple-value-bind ,temps ,body
(let ((,result-sap (sb-alien::%make-alien ,size)))
,@(generate-struct-store-code temps register-slots result-sap)
(sb-alien::%sap-alien ,result-sap ',return-type))))
t))
;; Large struct: C expects hidden pointer (x8/RDI), returns it (x0/RAX)
;; sret-sap was already added to %alien-funcall args at the top
;; Here we wrap with allocation and return the sap-alien
((and size (not in-registers-p))
;; sret-sap was defined at the top of this let*
(setf body
`(let ((,sret-sap (sb-alien::%make-alien ,size)))
,body ; %alien-funcall with sret-sap as first arg
;; The callee wrote to sret-sap, return it as alien
(sb-alien::%sap-alien ,sret-sap ',return-type)))
t)))) ; close inner cond clause, inner cond, m-v-b, outer cond clause
(t
(setf body `(naturalize ,body ',return-type))))
;; Remember this frame to make sure that we can get back
;; to it later regardless of how the foreign stack looks
;; like.
@ -643,10 +712,26 @@
(unless (and (constant-lvar-p type)
(alien-fun-type-p (lvar-value type)))
(error "Something is broken."))
(let ((spec (compute-alien-rep-type
(alien-fun-type-result-type (lvar-value type))
:result)))
(if (eq spec '*) *wild-type* (values-specifier-type spec))))
(let* ((result-type (alien-fun-type-result-type (lvar-value type)))
(spec (compute-alien-rep-type result-type :result)))
(cond
;; For struct-by-value returns, derive the multiple-values type
;; based on the register slot classification
#-sb-xc-host
((multiple-value-bind (in-registers-p register-slots)
(sb-alien::struct-return-info result-type)
(when in-registers-p
;; Return VALUES type for the register values
(make-values-type
(mapcar (lambda (class)
(case class
(:integer (specifier-type '(unsigned-byte 64)))
(:double (specifier-type 'double-float))
(:single! (specifier-type 'single-float))
(t *universal-type*)))
register-slots)))))
(t
(if (eq spec '*) *wild-type* (values-specifier-type spec))))))
(defoptimizer (%alien-funcall ltn-annotate)
((function type &rest args) node)
@ -679,8 +764,18 @@
(args #-arm args #+arm (reverse args))
#+c-stack-is-control-stack
(stack-pointer (make-stack-pointer-tn)))
(multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
(multiple-value-bind (nsp stack-frame-size arg-tns result-tns
#+(or arm64 x86-64) large-struct-return-p)
(make-call-out-tns type)
;; For large struct returns, the first arg is the sret pointer
;; Extract it from args so it's not processed as a regular arg
;; Emit the VOP to set x8 (ARM64) or RDI (x86-64) just before
;; the call. Watch out for the kludge above, if anyone comes
;; along and writes sret for arm32.
(let ((sret-tn #+(or arm64 x86-64) (when large-struct-return-p
(lvar-tn call block (pop args)))
#-(or arm64 x86-64) nil))
(declare (ignorable sret-tn))
#+x86
(vop set-fpu-word-for-c call block)
;; Save the stack pointer, it will get aligned and subtracting
@ -762,6 +857,11 @@
(reference-tn-list (remove-if-not #'tn-p (flatten-list 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
;; (x8 on ARM64, RDI on x86-64) right before making the call
(when sret-tn
(when-vop-existsp (:named sb-vm::set-struct-return-pointer)
(vop sb-vm::set-struct-return-pointer call block sret-tn)))
(cond #+#.(cl:if (sb-c::vop-existsp :named sb-vm::call-out-named) '(and) '(or))
((and (constant-lvar-p function) (stringp (lvar-value function)))
(vop* call-out-named call block (arg-operands) (result-operands)
@ -787,7 +887,7 @@
(reference-tn (car (last result-tns 2)) t))
(move-lvar-result call block (list (car (last result-tns 2))) lvar))
(t
(move-lvar-result call block result-tns lvar)))))))
(move-lvar-result call block result-tns lvar))))))))
(deftransform sb-alien::c-string-external-format ((type)
((constant-arg sb-alien::alien-c-string-type)))

465
src/compiler/arm64/c-call.lisp
View file

@ -183,8 +183,262 @@
(invoke-alien-type-method :result-tn type state))
values)))
;;;; Struct Return-by-Value Support for ARM64 (AAPCS64)
;;; Check if a record type is a Homogeneous Floating-point Aggregate (HFA)
;;; An HFA is a struct with 1-4 floating-point members of the same type.
;;; Members can be scalar floats, arrays of floats, or nested HFA structs.
(defun hfa-member-info (alien-type)
"Return (values base-type count) for a potential HFA member, or NIL if not HFA-compatible.
BASE-TYPE is 'single-float or 'double-float, COUNT is the number of elements."
(cond
;; Single-float scalar
((sb-alien::alien-single-float-type-p alien-type)
(values 'single-float 1))
;; Double-float scalar
((sb-alien::alien-double-float-type-p alien-type)
(values 'double-float 1))
;; Array type - check if element type is float
((sb-alien::alien-array-type-p alien-type)
(let ((element-type (sb-alien::alien-array-type-element-type alien-type))
(dims (sb-alien::alien-array-type-dimensions alien-type)))
;; Only 1-D arrays for HFA
(when (and (= (length dims) 1)
(integerp (first dims)))
(let ((len (first dims)))
(cond
((sb-alien::alien-single-float-type-p element-type)
(values 'single-float len))
((sb-alien::alien-double-float-type-p element-type)
(values 'double-float len))
;; Could also be an array of HFA structs
((sb-alien::alien-record-type-p element-type)
(multiple-value-bind (nested-base nested-count)
(hfa-base-type element-type)
(when nested-base
(values nested-base (* len nested-count)))))
(t nil))))))
;; Nested record - recursively check HFA
((sb-alien::alien-record-type-p alien-type)
(hfa-base-type alien-type))
;; Non-float field
(t nil)))
(defun hfa-base-type (record-type)
"Check if record is an HFA. Returns (values base-type member-count) where
base-type is 'single-float or 'double-float, or NIL if not an HFA."
(let ((fields (sb-alien::alien-record-type-fields record-type))
(base-type nil)
(count 0))
(dolist (field fields)
(let ((field-type (sb-alien::alien-record-field-type field)))
(multiple-value-bind (member-base member-count)
(hfa-member-info field-type)
(cond
;; Not HFA-compatible member
((null member-base)
(return-from hfa-base-type nil))
;; Compatible with existing base type (or first member)
((or (null base-type) (eq base-type member-base))
(setf base-type member-base)
(incf count member-count))
;; Mixed float types - not an HFA
(t (return-from hfa-base-type nil))))))
;; HFA must have 1-4 members
(when (and base-type (<= 1 count 4))
(values base-type count))))
;;; Main classification function for ARM64 AAPCS64.
(defun classify-struct-aapcs64 (record-type)
"Classify struct for ARM64 AAPCS64 return."
(let* ((bits (sb-alien::alien-type-bits record-type))
(byte-size (ceiling bits 8))
(alignment (sb-alien::alien-type-alignment record-type)))
(multiple-value-bind (hfa-type hfa-count) (hfa-base-type record-type)
(cond
;; HFA: return in floating-point registers
(hfa-type
(sb-alien::make-struct-classification
:register-slots (make-list hfa-count :initial-element
(if (eq hfa-type 'single-float) :single :double))
:size byte-size
:alignment alignment
:memory-p nil))
;; Small non-HFA: return in x0 (and x1 if 9-16 bytes)
((<= byte-size 16)
(sb-alien::make-struct-classification
:register-slots (make-list (max 1 (ceiling byte-size 8)) :initial-element :integer)
:size byte-size
:alignment alignment
:memory-p nil))
;; Large struct: use x8 indirect result
(t
(sb-alien::make-struct-classification
:register-slots '(:memory)
:size byte-size
:alignment alignment
:memory-p t))))))
;;; Result TN generation for record types
;;; Called from src/code/c-call.lisp
(defun record-result-tn (type state)
"Handle struct return values."
(let ((classification (classify-struct-aapcs64 type)))
(if (sb-alien::struct-classification-memory-p classification)
;; Large struct: return via hidden pointer in x8
;; The caller allocates space and passes pointer in x8
(progn
(setf (result-state-num-results state) 1)
(make-wired-tn* 'system-area-pointer sap-reg-sc-number (result-reg-offset 0)))
;; Small struct: return in registers
(let ((result-tns nil)
(int-results 0)
(fp-results 0))
(dolist (class (sb-alien::struct-classification-register-slots classification))
(ecase class
(:integer
(push (make-wired-tn* 'unsigned-byte-64
unsigned-reg-sc-number
(result-reg-offset int-results))
result-tns)
(incf int-results))
(:single
(push (make-wired-tn* 'single-float
single-reg-sc-number
fp-results)
result-tns)
(incf fp-results))
(:double
(push (make-wired-tn* 'double-float
double-reg-sc-number
fp-results)
result-tns)
(incf fp-results))))
(setf (result-state-num-results state) (+ int-results fp-results))
(nreverse result-tns)))))
;;; VOPs for struct argument passing
;;; These VOPs load register slots from a struct SAP into target registers
(define-vop (load-struct-int-arg)
(:args (sap :scs (sap-reg)))
(:info offset)
(:results (target :scs (unsigned-reg signed-reg)))
(:generator 5
(inst ldr target (@ sap offset))))
(define-vop (load-struct-single-arg)
(:args (sap :scs (sap-reg)))
(:info offset)
(:results (target :scs (single-reg)))
(:generator 5
(inst ldr target (@ sap offset))))
(define-vop (load-struct-double-arg)
(:args (sap :scs (sap-reg)))
(:info offset)
(:results (target :scs (double-reg)))
(:generator 5
(inst ldr target (@ sap offset))))
;;; VOPs for storing struct result registers to memory
;;; These VOPs store result register values back to memory for struct-by-value returns
(define-vop (store-struct-int-result)
(:args (value :scs (unsigned-reg signed-reg))
(sap :scs (sap-reg)))
(:info offset)
(:generator 5
(inst str value (@ sap offset))))
(define-vop (store-struct-single-result)
(:args (value :scs (single-reg))
(sap :scs (sap-reg)))
(:info offset)
(:generator 5
(inst str value (@ sap offset))))
(define-vop (store-struct-double-result)
(:args (value :scs (double-reg))
(sap :scs (sap-reg)))
(:info offset)
(:generator 5
(inst str value (@ sap offset))))
;;; Arg TN generation for record types
;;; Called from src/code/c-call.lisp
(defun record-arg-tn (type state)
"Handle struct arguments.
For large structs (>16 bytes), returns a SAP TN for pointer passing.
For small structs, returns a function that emits load VOPs."
(let ((classification (classify-struct-aapcs64 type)))
(if (sb-alien::struct-classification-memory-p classification)
;; Large struct: pass by pointer
(int-arg state 'system-area-pointer sap-reg-sc-number sap-stack-sc-number)
;; Small struct: allocate target TNs and return a function to load into them
(let ((arg-tns nil)
(offsets nil)
(offset 0))
(dolist (class (sb-alien::struct-classification-register-slots classification))
(ecase class
(:integer
(push (int-arg state 'unsigned-byte-64
unsigned-reg-sc-number
unsigned-stack-sc-number)
arg-tns)
(push (cons offset :integer) offsets)
(incf offset 8))
(:single
(push (float-arg state 'single-float
single-reg-sc-number
single-stack-sc-number #+darwin 4)
arg-tns)
(push (cons offset :single) offsets)
(incf offset 4))
(:double
(push (float-arg state 'double-float
double-reg-sc-number
double-stack-sc-number)
arg-tns)
(push (cons offset :double) offsets)
(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 (ecase class
(:integer
(sb-c::emit-and-insert-vop
call block
(sb-c::template-or-lose 'load-struct-int-arg)
(sb-c::reference-tn sap-tn nil)
(sb-c::reference-tn target-tn t)
nil
(list off)))
(:single
(sb-c::emit-and-insert-vop
call block
(sb-c::template-or-lose 'load-struct-single-arg)
(sb-c::reference-tn sap-tn nil)
(sb-c::reference-tn target-tn t)
nil
(list off)))
(:double
(sb-c::emit-and-insert-vop
call block
(sb-c::template-or-lose 'load-struct-double-arg)
(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)))
(let ((arg-state (make-arg-state))
(result-type (alien-fun-type-result-type type)))
(collect ((arg-tns))
(let (#+darwin (variadic (sb-alien::alien-fun-type-varargs type)))
(loop for i from 0
@ -195,13 +449,31 @@
(setf (arg-state-num-register-args arg-state) +max-register-args+
(arg-state-fp-registers arg-state) +max-register-args+))
(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))))
(values (make-normal-tn *fixnum-primitive-type*)
(arg-state-stack-frame-size arg-state)
(arg-tns)
(invoke-alien-type-method :result-tn
(alien-fun-type-result-type type)
(make-result-state))))))
;; Check if result is a large struct that needs hidden pointer
(let* ((stack-frame-size (arg-state-stack-frame-size arg-state))
;; For large struct returns, we don't allocate stack space here
;; The IR1 transform allocates heap memory and passes it as first arg
;; We just return a flag indicating this is a large struct return
(large-struct-return-p
(when (sb-alien::alien-record-type-p result-type)
(let ((classification (classify-struct-aapcs64 result-type)))
(sb-alien::struct-classification-memory-p classification)))))
(values (make-normal-tn *fixnum-primitive-type*)
stack-frame-size
(arg-tns)
(invoke-alien-type-method :result-tn result-type (make-result-state))
;; 5th value: T if large struct return (sret pointer passed as first arg)
large-struct-return-p)))))
;;; VOP to set up for return of large structs (>16 bytes) via a
;;; hidden pointer: caller allocates memory and passes the address in
;;; x8.
(define-vop (set-struct-return-pointer)
(:args (sap :scs (sap-reg) :target x8))
(:temporary (:sc sap-reg :offset 8) x8) ; x8 is the indirect result register
(:generator 1
(move x8 sap)))
(define-vop (foreign-symbol-sap)
(:translate foreign-symbol-sap)
(:policy :fast-safe)
@ -348,35 +620,66 @@
#-sb-xc-host
(defun alien-callback-assembler-wrapper (index result-type argument-types)
(flet ((make-tn (offset &optional (sc-name 'any-reg))
(make-random-tn (sc-or-lose sc-name) offset)))
(let* ((segment (make-segment))
;; How many arguments have been copied
(arg-count 0)
;; How many arguments have been copied from the stack
(stack-argument-bytes 0)
(r0-tn (make-tn 0))
(r1-tn (make-tn 1))
(r2-tn (make-tn 2))
(r3-tn (make-tn 3))
(temp-tn (make-tn 9))
(nsp-save-tn (make-tn 10))
(gprs (loop for i below 8
collect (make-tn i)))
(fp-registers 0)
(frame-size (* (length argument-types) n-word-bytes)))
(labels ((make-tn (offset &optional (sc-name 'any-reg))
(make-random-tn (sc-or-lose sc-name) offset))
(argument-byte-size (type)
"Return the number of bytes this argument occupies in the callback vector."
(ceiling (sb-alien::alien-type-bits type) n-byte-bits))
(round-up-to-word (bytes)
(* n-word-bytes (ceiling bytes n-word-bytes))))
;; Check for struct return type and classify it
(let* ((result-classification
(when (alien-record-type-p result-type)
(classify-struct-aapcs64 result-type)))
(large-struct-return-p
(and result-classification
(sb-alien::struct-classification-memory-p result-classification))))
;; Calculate frame size: sum of all argument sizes
(let* ((segment (make-segment))
;; Current byte offset in the argument frame
(frame-offset 0)
;; How many bytes have been read from the stack argument area
(stack-argument-bytes 0)
(r0-tn (make-tn 0))
(r1-tn (make-tn 1))
(r2-tn (make-tn 2))
(r3-tn (make-tn 3))
(temp-tn (make-tn 9))
(nsp-save-tn (make-tn 10))
;; x8 is used for large struct return pointer
(x8-tn (make-tn 8))
;; x12 used to save x8 across the call (x11 is used for ptr-tn in struct arg processing)
(x8-save-tn (make-tn 12))
(gprs (loop for i below 8
collect (make-tn i)))
(fp-registers 0)
;; Calculate frame size from argument types (word-aligned)
(frame-size (loop for type in argument-types
sum (round-up-to-word (argument-byte-size type))))
;; Return value slot count - enough for large struct if needed
(return-slot-count
(if large-struct-return-p
(ceiling (sb-alien::struct-classification-size result-classification) n-word-bytes)
2)))
(setf frame-size (logandc2 (+ frame-size +number-stack-alignment-mask+)
+number-stack-alignment-mask+))
;; Return value allocation size - must be 16-byte aligned for stack alignment
(let ((return-bytes (logandc2 (+ (* n-word-bytes return-slot-count) 15) 15)))
(assemble (segment 'nil)
(inst mov-sp nsp-save-tn nsp-tn)
(inst str lr-tn (@ nsp-tn -16 :pre-index))
;; Save x8 (hidden struct return pointer) to stack if returning large struct
;; We save to stack because x8-15 are caller-saved and would be clobbered by the call
;; After the str above, nsp points to saved LR, and [nsp+8] is free space
(when large-struct-return-p
(inst str x8-tn (@ nsp-tn 8)))
;; Make room on the stack for arguments.
(when (plusp frame-size)
(inst sub nsp-tn nsp-tn frame-size))
;; Copy arguments
(dolist (type argument-types)
(let ((target-tn (@ nsp-tn (* arg-count n-word-bytes)))
(size #+darwin (truncate (alien-type-bits type) n-byte-bits)
(let ((target-tn (@ nsp-tn frame-offset))
(size #+darwin (truncate (sb-alien::alien-type-bits type) n-byte-bits)
#-darwin n-word-bytes))
(cond ((or (alien-integer-type-p type)
(alien-pointer-type-p type)
@ -410,7 +713,7 @@
(inst ldr temp-tn addr)))
(inst str temp-tn target-tn))
(incf stack-argument-bytes size))))
(incf arg-count))
(incf frame-offset n-word-bytes))
((alien-float-type-p type)
(cond ((< fp-registers 8)
(inst str (make-tn fp-registers
@ -432,7 +735,64 @@
(inst str temp-tn target-tn)))
(incf stack-argument-bytes size)))
(incf fp-registers)
(incf arg-count))
(incf frame-offset n-word-bytes))
;; Handle struct-by-value arguments
((sb-alien::alien-record-type-p type)
(let* ((struct-bytes (argument-byte-size type))
(struct-bytes-aligned (round-up-to-word struct-bytes))
(classification (classify-struct-aapcs64 type))
;; Use r11 as additional temp for struct pointer
(ptr-tn (make-tn 11)))
(cond
;; Large struct (>16 bytes): passed by pointer in register
((sb-alien::struct-classification-memory-p classification)
;; The struct pointer is in a GPR; copy struct data to frame
(let ((gpr (pop gprs)))
(cond (gpr
;; Move pointer from argument register to ptr-tn
(inst mov ptr-tn gpr))
(t
;; Pointer is on stack
(setf stack-argument-bytes (align-up stack-argument-bytes 8))
(inst ldr ptr-tn (@ nsp-save-tn stack-argument-bytes))
(incf stack-argument-bytes 8)))
;; Copy struct data from pointer to frame
;; Use temp-tn (r9) for copying, ptr-tn (r11) has source address
(loop for off from 0 below struct-bytes by 8
for remaining = (- struct-bytes off)
do (cond ((>= remaining 8)
(inst ldr temp-tn (@ ptr-tn off))
(inst str temp-tn (@ nsp-tn (+ frame-offset off))))
((>= remaining 4)
(inst ldr (32-bit-reg temp-tn) (@ ptr-tn off))
(inst str (32-bit-reg temp-tn) (@ nsp-tn (+ frame-offset off))))
(t
;; Copy remaining bytes one by one
(loop for b from 0 below remaining
do (inst ldrb (32-bit-reg temp-tn) (@ ptr-tn (+ off b)))
(inst strb (32-bit-reg temp-tn) (@ nsp-tn (+ frame-offset off b)))))))))
;; HFA: passed in floating-point registers
((multiple-value-bind (hfa-type hfa-count) (hfa-base-type type)
(when hfa-type
(let ((fp-size (if (eq hfa-type 'single-float) 4 8)))
(dotimes (i hfa-count)
(when (< fp-registers 8)
(inst str (make-tn fp-registers
(if (eq hfa-type 'single-float)
'single-reg
'double-reg))
(@ nsp-tn (+ frame-offset (* i fp-size))))
(incf fp-registers))))
t)))
;; Small non-HFA struct (<=16 bytes): passed in GPRs
(t
(let ((num-regs (ceiling struct-bytes 8)))
(dotimes (i num-regs)
(let ((gpr (pop gprs)))
(when gpr
(inst str gpr (@ nsp-tn (+ frame-offset (* i 8))))))))))
;; Use word-aligned size for frame offset to match Lisp side
(incf frame-offset struct-bytes-aligned)))
(t
(bug "Unknown alien type: ~S" type)))))
;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
@ -440,7 +800,7 @@
;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
(inst mov-sp r1-tn nsp-tn)
;; add room on stack for return value
(inst sub nsp-tn nsp-tn (* n-word-bytes 2))
(inst sub nsp-tn nsp-tn return-bytes)
;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
(inst mov-sp r2-tn nsp-tn)
@ -462,9 +822,52 @@
'double-reg))
nsp-tn))
((alien-void-type-p result-type))
;; Struct return types
((alien-record-type-p result-type)
(cond
;; Large struct: copy result to x8 pointer location, return pointer in x0
(large-struct-return-p
(let ((struct-size (sb-alien::struct-classification-size result-classification))
;; x8 was saved at [original - 8]
;; After call: nsp = original - 16 - frame-size - return-bytes
;; So x8 is at [nsp + 8 + frame-size + return-bytes]
(x8-offset (+ 8 frame-size return-bytes)))
;; Load saved x8 from stack into x8-save-tn (x12)
;; We can't use nsp-save-tn as it may have been clobbered by the call
(inst ldr x8-save-tn (@ nsp-tn x8-offset))
(loop for off from 0 below struct-size by 8
for remaining = (- struct-size off)
do (cond ((>= remaining 8)
(inst ldr temp-tn (@ nsp-tn off))
(inst str temp-tn (@ x8-save-tn off)))
((>= remaining 4)
(inst ldr (32-bit-reg temp-tn) (@ nsp-tn off))
(inst str (32-bit-reg temp-tn) (@ x8-save-tn off)))
(t
(loop for b from 0 below remaining
do (inst ldrb (32-bit-reg temp-tn) (@ nsp-tn (+ off b)))
(inst strb (32-bit-reg temp-tn) (@ x8-save-tn (+ off b)))))))
;; Return the pointer in x0
(inst mov r0-tn x8-save-tn)))
;; HFA: load into floating-point registers
((multiple-value-bind (hfa-type hfa-count) (hfa-base-type result-type)
(when hfa-type
(let ((fp-size (if (eq hfa-type 'single-float) 4 8))
(sc-name (if (eq hfa-type 'single-float) 'single-reg 'double-reg)))
(dotimes (i hfa-count)
(inst ldr (make-tn i sc-name) (@ nsp-tn (* i fp-size)))))
t)))
;; Small non-HFA struct (<=16 bytes): load into x0/x1
(t
(let* ((struct-size (sb-alien::struct-classification-size result-classification))
(num-regs (ceiling struct-size 8)))
(when (>= num-regs 1)
(inst ldr r0-tn (@ nsp-tn 0)))
(when (>= num-regs 2)
(inst ldr r1-tn (@ nsp-tn 8)))))))
(t
(error "Unrecognized alien type: ~A" result-type)))
(inst add nsp-tn nsp-tn (+ frame-size (* n-word-bytes 2)))
(inst add nsp-tn nsp-tn (+ frame-size return-bytes))
(inst ldr lr-tn (@ nsp-tn 16 :post-index))
(inst ret))
(finalize-segment segment)
@ -485,4 +888,4 @@
system-area-pointer
unsigned-long))
sap (length buffer))
vector))))
vector))))))

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

@ -23,6 +23,10 @@
(stack-frame-size 0))
(declaim (freeze-type arg-state))
;;; Cache for struct classification to avoid redundant computation.
;;; Bound in make-call-out-tns when processing struct return types.
(defvar *cached-struct-classification* nil)
(defconstant max-int-args #.(length *c-call-register-arg-offsets*))
(defconstant max-xmm-args #+win32 4 #-win32 8)
@ -119,17 +123,298 @@
(invoke-alien-type-method :result-tn type state))
values)))
;;;; Struct Return-by-Value Support (System V AMD64 ABI)
;;; Classify a single field
(defun classify-field-x86-64 (type)
"Classify a single field type for x86-64 ABI.
Returns :INTEGER, :DOUBLE, or :MEMORY."
(cond
;; Check specific types first, before general type checks
((sb-alien::alien-integer-type-p type) :integer)
((sb-alien::alien-pointer-type-p type) :integer)
((sb-alien::alien-single-float-type-p type) :double)
((sb-alien::alien-double-float-type-p type) :double)
;; Arrays are classified by their element type
((sb-alien::alien-array-type-p type)
(let ((element-type (sb-alien::alien-array-type-element-type type)))
(classify-field-x86-64 element-type)))
;; Nested struct - recursively classify and inherit eightbyte classes
((sb-alien::alien-record-type-p type)
(let ((nested (classify-struct-sysv-amd64 type)))
(if (sb-alien::struct-classification-memory-p nested)
:memory
;; Merge all slots from nested struct to get dominant class
;; e.g., struct { double d; } should contribute :double, not :integer
(reduce #'merge-classes
(sb-alien::struct-classification-register-slots nested)
:initial-value :no-class))))
;; System-area-pointer (must come after array/record checks)
((typep type 'sb-alien::alien-system-area-pointer-type) :integer)
(t :memory)))
;;; Merge two classes within an eightbyte per ABI rules
(defun merge-classes (class1 class2)
"Merge two classes within an eightbyte per ABI rules.
INTEGER dominates SSE; MEMORY dominates everything."
(cond
((eq class1 class2) class1)
((eq class1 :no-class) class2)
((eq class2 :no-class) class1)
((or (eq class1 :memory) (eq class2 :memory)) :memory)
((or (eq class1 :integer) (eq class2 :integer)) :integer)
(t :double)))
;;; Main classification function for x86-64 System V AMD64 ABI
(defun classify-struct-sysv-amd64 (record-type)
"Classify struct for x86-64 System V ABI return.
Returns STRUCT-CLASSIFICATION."
(let* ((bits (sb-alien::alien-type-bits record-type))
(byte-size (ceiling bits 8))
(alignment (sb-alien::alien-type-alignment record-type)))
;; Rule: Structs > 16 bytes always use memory (hidden pointer)
(when (> byte-size 16)
(return-from classify-struct-sysv-amd64
(sb-alien::make-struct-classification
:register-slots '(:memory)
:size byte-size
:alignment alignment
:memory-p t)))
;; Classify each eightbyte
(let* ((num-eightbytes (max 1 (ceiling byte-size 8)))
(eightbytes (make-list num-eightbytes :initial-element :no-class)))
;; Iterate through fields and classify
(dolist (field (sb-alien::alien-record-type-fields record-type))
(let* ((field-offset-bits (sb-alien::alien-record-field-offset field))
(field-type (sb-alien::alien-record-field-type field))
(field-bits (sb-alien::alien-type-bits field-type))
(field-offset-bytes (floor field-offset-bits 8))
(field-size-bytes (ceiling field-bits 8))
(field-class (classify-field-x86-64 field-type)))
;; Apply class to all eightbytes this field spans
(loop for byte-offset from field-offset-bytes below (+ field-offset-bytes field-size-bytes) by 8
for eightbyte-index = (floor byte-offset 8)
when (< eightbyte-index num-eightbytes)
do (setf (nth eightbyte-index eightbytes)
(merge-classes (nth eightbyte-index eightbytes)
field-class)))))
;; 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))
(sb-alien::make-struct-classification
:register-slots eightbytes
:size byte-size
:alignment alignment
:memory-p (member :memory eightbytes)))))
;;; Result TN generation for record types
;;; Called from src/code/c-call.lisp
(defun record-result-tn (type state)
"Handle struct return values."
;; Windows x64 uses Microsoft calling convention, not System V AMD64.
;; To add Windows support:
;; 1. Implement classify-struct-win64: structs of 1/2/4/8 bytes return in RAX,
;; larger structs use hidden pointer in RCX (not RDI)
;; 2. Adapt this function to use the Windows classification
;; 3. Update make-call-out-tns to reserve RCX instead of RDI for sret pointer
#+win32 (error "Struct-by-value return not implemented for Windows x64 ABI")
(let ((classification (or *cached-struct-classification*
(classify-struct-sysv-amd64 type))))
(if (sb-alien::struct-classification-memory-p classification)
;; Large struct: return via hidden pointer
;; Caller passes pointer in RDI, callee returns it in RAX
(progn
(setf (result-state-num-results state) 1)
(make-wired-tn* 'system-area-pointer sap-reg-sc-number rax-offset))
;; Small struct: return in registers
(let ((result-tns nil)
(int-results 0)
(sse-results 0))
(dolist (class (sb-alien::struct-classification-register-slots classification))
(case class
(:integer
(push (make-wired-tn* 'unsigned-byte-64
unsigned-reg-sc-number
(result-reg-offset int-results))
result-tns)
(incf int-results))
(:double
(push (make-wired-tn* 'double-float
double-reg-sc-number
sse-results)
result-tns)
(incf sse-results))))
(setf (result-state-num-results state) (+ int-results sse-results))
(nreverse result-tns)))))
;;; VOPs for struct argument passing
;;; These VOPs load eightbytes from a struct SAP into target registers
(define-vop (load-struct-int-arg)
(:args (sap :scs (sap-reg)))
(:info offset)
(:results (target :scs (unsigned-reg signed-reg)))
(:generator 5
(inst mov :qword target (ea offset sap))))
(define-vop (load-struct-sse-arg)
(:args (sap :scs (sap-reg)))
(:info offset)
(:results (target :scs (double-reg single-reg)))
(:generator 5
(inst movsd target (ea offset sap))))
;;; VOPs for storing struct result registers to memory
;;; These VOPs store result register values back to memory for struct-by-value returns
(define-vop (store-struct-int-result)
(:args (value :scs (unsigned-reg signed-reg))
(sap :scs (sap-reg)))
(:info offset)
(:generator 5
(inst mov :qword (ea offset sap) value)))
(define-vop (store-struct-sse-result)
(:args (value :scs (double-reg single-reg))
(sap :scs (sap-reg)))
(:info offset)
(:generator 5
(inst movsd (ea offset sap) value)))
;;; VOP to copy a qword from struct SAP to the C argument stack
;;; Used for passing large structs (>16 bytes) by value
(define-vop (copy-struct-arg-to-stack)
(:args (sap :scs (sap-reg))
(nsp :scs (any-reg)))
(:info src-offset dst-offset)
(:temporary (:sc unsigned-reg) temp)
(:generator 5
(inst mov :qword temp (ea src-offset sap))
(inst mov :qword (ea dst-offset nsp) temp)))
;;; Arg TN generation for record types
;;; Called from src/code/c-call.lisp
(defun record-arg-tn (type state)
"Handle struct arguments.
For large structs (>16 bytes), copies to stack per System V AMD64 ABI.
For small structs, returns a function that emits load VOPs into registers."
;; Windows x64 uses Microsoft calling convention, not System V AMD64.
;; To add Windows support:
;; 1. Implement classify-struct-win64: structs >8 bytes are passed by pointer
;; (caller allocates, passes address in integer register)
;; 2. Structs of 1/2/4/8 bytes are passed in a single integer register
;; 3. Adapt this function to handle both cases
#+win32 (error "Struct-by-value arguments not implemented for Windows x64 ABI")
(let ((classification (classify-struct-sysv-amd64 type)))
(if (sb-alien::struct-classification-memory-p classification)
;; Large struct: copy to stack (System V AMD64 ABI)
;; The struct is passed by value on the stack, not by pointer
(let* ((size (sb-alien::struct-classification-size classification))
(words (ceiling size 8))
(stack-base (arg-state-stack-frame-size state)))
;; Reserve stack slots for the struct
(incf (arg-state-stack-frame-size state) words)
;; Return a function that copies the struct to the stack
(lambda (arg call block nsp)
(let ((sap-tn (sb-c::lvar-tn call block arg)))
(loop for i from 0 below words
for src-offset = (* i 8)
for dst-offset = (* (+ stack-base i) n-word-bytes)
do (sb-c::emit-and-insert-vop
call block
(sb-c::template-or-lose 'copy-struct-arg-to-stack)
(sb-c::reference-tn-list (list sap-tn nsp) nil)
nil ; no results
nil ; insert at end
(list src-offset dst-offset))))))
;; Small struct: allocate target TNs and return a function to load into them
(let ((arg-tns nil)
(offsets nil)
(offset 0))
(dolist (class (sb-alien::struct-classification-register-slots classification))
(case class
(:integer
(push (int-arg state 'unsigned-byte-64
unsigned-reg-sc-number
unsigned-stack-sc-number)
arg-tns)
(push (cons offset :integer) offsets))
(:double
(push (float-arg state 'double-float
double-reg-sc-number
double-stack-sc-number)
arg-tns)
(push (cons offset :double) offsets)))
(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 (ecase class
(:integer
(sb-c::emit-and-insert-vop
call block
(sb-c::template-or-lose 'load-struct-int-arg)
(sb-c::reference-tn sap-tn nil)
(sb-c::reference-tn target-tn t)
nil ; insert at end
(list off)))
(:double
(sb-c::emit-and-insert-vop
call block
(sb-c::template-or-lose 'load-struct-sse-arg)
(sb-c::reference-tn sap-tn nil)
(sb-c::reference-tn target-tn t)
nil
(list off)))))))))))
;;; VOP to set up RDI: large structs (>16 bytes) are returned via a hidden pointer.
;;; The caller allocates memory and passes the address in RDI (first arg register)
(define-vop (set-struct-return-pointer)
(:args (sap :scs (sap-reg) :target rdi))
(:temporary (:sc sap-reg :offset rdi-offset) rdi) ; RDI is the first arg register
(:generator 1
(move rdi sap)))
(defun make-call-out-tns (type)
(let ((arg-state (make-arg-state)))
(collect ((arg-tns))
(dolist (arg-type (alien-fun-type-arg-types type))
(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (make-wired-tn* 'positive-fixnum any-reg-sc-number rsp-offset)
(* (arg-state-stack-frame-size arg-state) n-word-bytes)
(arg-tns)
(invoke-alien-type-method :result-tn
(alien-fun-type-result-type type)
(make-result-state))))))
(let ((arg-state (make-arg-state))
(result-type (alien-fun-type-result-type type)))
;; Check for large struct return FIRST - we need to reserve RDI for sret pointer
;; Cache the classification to avoid recomputing it in record-result-tn
(let* ((result-classification
(when (alien-record-type-p result-type)
(classify-struct-sysv-amd64 result-type)))
(large-struct-return-p
(and result-classification
(sb-alien::struct-classification-memory-p result-classification))))
;; For large struct returns, consume RDI (first int arg register)
;; so regular arguments start from RSI
(when large-struct-return-p
(setf (arg-state-register-args arg-state) 1))
(collect ((arg-tns))
(dolist (arg-type (alien-fun-type-arg-types type))
(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(let ((stack-frame-size (* (arg-state-stack-frame-size arg-state) n-word-bytes))
;; Bind cached classification so record-result-tn doesn't recompute
(*cached-struct-classification* result-classification))
(values (make-wired-tn* 'positive-fixnum any-reg-sc-number rsp-offset)
stack-frame-size
(arg-tns)
(invoke-alien-type-method :result-tn result-type (make-result-state))
;; 5th value: T if large struct return (sret pointer passed as first arg)
large-struct-return-p))))))
(deftransform %alien-funcall ((function type &rest args) * * :node node)
@ -137,8 +422,18 @@
(let* ((type (sb-c:lvar-value type))
(env (sb-c::node-lexenv node))
(arg-types (alien-fun-type-arg-types type))
(result-type (alien-fun-type-result-type type)))
(aver (= (length arg-types) (length args)))
(result-type (alien-fun-type-result-type type))
;; Large struct returns have a hidden first arg (sret pointer) added by IR1
#-sb-xc-host
(large-struct-return-p
(multiple-value-bind (in-registers-p register-slots size)
(sb-alien::struct-return-info result-type)
(declare (ignore register-slots))
(and size (not in-registers-p))))
#+sb-xc-host
(large-struct-return-p nil))
(aver (= (length arg-types)
(- (length args) (if large-struct-return-p 1 0))))
(if (or (some #'(lambda (type)
(and (alien-integer-type-p type)
(> (sb-alien::alien-integer-type-bits type) 64)))
@ -470,10 +765,32 @@
#-sb-xc-host
(defun alien-callback-assembler-wrapper (index result-type argument-types)
;; Windows x64 uses Microsoft calling convention, not System V AMD64.
;; To add Windows struct-by-value callback support:
;; 1. Struct arguments >8 bytes: caller passes pointer, not value
;; 2. Struct arguments 1/2/4/8 bytes: passed in integer register as if integer
;; 3. Struct returns >8 bytes: hidden pointer in RCX (first arg register)
;; 4. Struct returns 1/2/4/8 bytes: returned in RAX
#+win32
(when (or (alien-record-type-p result-type)
(some #'sb-alien::alien-record-type-p argument-types))
(error "Struct-by-value callbacks not implemented for Windows x64 ABI"))
(labels ((make-tn-maker (sc-name)
(lambda (offset)
(make-random-tn (sc-or-lose sc-name) offset))))
(let* ((segment (make-segment))
(make-random-tn (sc-or-lose sc-name) offset)))
(argument-byte-size (type)
"Return the number of bytes this argument occupies in the callback vector."
(ceiling (sb-alien::alien-type-bits type) n-byte-bits))
(round-up-to-word (bytes)
(* n-word-bytes (ceiling bytes n-word-bytes))))
;; Check for struct return type and classify it
(let* ((result-classification
(when (alien-record-type-p result-type)
(classify-struct-sysv-amd64 result-type)))
(large-struct-return-p
(and result-classification
(sb-alien::struct-classification-memory-p result-classification)))
(segment (make-segment))
(rax rax-tn)
#+win32 (rcx rcx-tn)
#-(and win32 sb-thread) (rdi rdi-tn)
@ -483,60 +800,143 @@
(rsp rsp-tn)
#+(and win32 sb-thread) (r8 r8-tn)
(xmm0 float0-tn)
#-win32
(xmm1 float1-tn)
([rsp] (ea rsp))
;; How many arguments have been copied
(arg-count 0)
;; How many arguments have been copied from the stack
;; Calculate total argument vector size in bytes
(total-arg-bytes
(loop for type in argument-types
sum (round-up-to-word (argument-byte-size type))))
;; How many arguments have been copied from the C stack
(stack-argument-count #-win32 0 #+win32 4)
(gprs (mapcar (make-tn-maker 'any-reg) *c-call-register-arg-offsets*))
;; Byte offset into argument vector
(arg-offset 0)
;; Count of 8-byte slots consumed (for stack offset calculation)
(arg-slot-count (ceiling total-arg-bytes n-word-bytes))
;; For large struct returns, RDI contains the hidden pointer, not an argument
;; Skip it in the GPR list so arguments start at RSI
(gprs (let ((all-gprs (mapcar (make-tn-maker 'any-reg) *c-call-register-arg-offsets*)))
(if large-struct-return-p
(rest all-gprs) ; Skip RDI
all-gprs)))
(fprs (mapcar (make-tn-maker 'double-reg)
;; Only 8 first XMM registers are used for
;; passing arguments
(subseq *float-regs* 0 #-win32 8 #+win32 4))))
(subseq *float-regs* 0 #-win32 8 #+win32 4)))
;; R11 is caller-saved and not used for arguments - use it to save hidden ptr
#-win32
(r11 (make-random-tn (sc-or-lose 'any-reg) r11-offset))
;; Calculate return value slot count (in 8-byte words)
;; For large struct returns, we need enough space for the entire struct
;; For small structs and primitives, 2 slots (16 bytes) is enough
(return-slot-count
(if large-struct-return-p
(ceiling (sb-alien::struct-classification-size result-classification) n-word-bytes)
2))
;; Adjust for alignment (must be even for 16-byte stack alignment)
(return-slot-count-aligned
(if (evenp (+ arg-slot-count return-slot-count))
return-slot-count
(1+ return-slot-count))))
(assemble (segment 'nil)
;; Make room on the stack for arguments.
(when argument-types
(inst sub rsp (* n-word-bytes (length argument-types))))
;; Copy arguments from registers to stack
;; For large struct returns, save the hidden pointer (in RDI) to R11
;; before we use RDI for anything else
#-win32
(when large-struct-return-p
(inst mov r11 rdi))
;; Make room on the stack for argument vector.
(when (plusp total-arg-bytes)
(inst sub rsp total-arg-bytes))
;; Copy arguments from registers/stack to argument vector
(dolist (type argument-types)
(let ((integerp (not (alien-float-type-p type)))
;; A TN pointing to the stack location where the
;; current argument should be stored for the purposes
;; of ENTER-ALIEN-CALLBACK.
(target-tn (ea (* arg-count n-word-bytes) rsp))
;; A TN pointing to the stack location that contains
;; the next argument passed on the stack.
(stack-arg-tn (ea (* (+ 1 (length argument-types) stack-argument-count)
n-word-bytes) rsp)))
(incf arg-count)
(cond (integerp
(let ((gpr (pop gprs)))
#+win32 (pop fprs)
;; Argument not in register, copy it from the old
;; stack location to a temporary register.
(unless gpr
(incf stack-argument-count)
(setf gpr rax)
(inst mov gpr stack-arg-tn))
;; Copy from either argument register or temporary
;; register to target.
(inst mov target-tn gpr)))
((or (alien-single-float-type-p type)
(alien-double-float-type-p type))
(let ((fpr (pop fprs)))
#+win32 (pop gprs)
(cond (fpr
;; Copy from float register to target location.
(inst movq target-tn fpr))
(t
;; Not in float register. Copy from stack to
;; temporary (general purpose) register, and
;; from there to the target location.
(incf stack-argument-count)
(inst mov rax stack-arg-tn)
(inst mov target-tn rax)))))
(t
(bug "Unknown alien floating point type: ~S" type)))))
(let* ((arg-size (round-up-to-word (argument-byte-size type)))
;; A TN pointing to the stack location where the
;; current argument should be stored for the purposes
;; of ENTER-ALIEN-CALLBACK.
(target-tn (ea arg-offset rsp))
;; Offset to C stack args (past return address and our arg vector)
(stack-arg-tn (ea (* (+ 1 arg-slot-count stack-argument-count)
n-word-bytes) rsp)))
(cond
;; Struct types
((sb-alien::alien-record-type-p type)
(let* ((classification (classify-struct-sysv-amd64 type))
(memory-p (sb-alien::struct-classification-memory-p classification))
(slots (sb-alien::struct-classification-register-slots classification))
(struct-size (sb-alien::struct-classification-size classification)))
(cond
;; Large struct (MEMORY class): passed directly on the C stack
;; The caller copies the struct to its stack frame
(memory-p
(let ((num-words (ceiling struct-size n-word-bytes)))
;; Copy struct data from C stack to our argument vector
(loop for i from 0 below num-words
for src-off = (* (+ 1 arg-slot-count stack-argument-count i)
n-word-bytes)
for dst-off from arg-offset by n-word-bytes
do (inst mov rax (ea src-off rsp))
(inst mov (ea dst-off rsp) rax))
;; Account for the stack slots consumed
(incf stack-argument-count num-words)))
;; Small struct: passed in up to 2 registers per eightbyte
(t
(loop for class in slots
for slot-offset from arg-offset by n-word-bytes
do (ecase class
(:integer
(let ((gpr (pop gprs)))
#+win32 (pop fprs)
(unless gpr
(incf stack-argument-count)
(setf gpr rax)
(inst mov gpr (ea (* (+ 1 arg-slot-count stack-argument-count -1)
n-word-bytes) rsp)))
(inst mov (ea slot-offset rsp) gpr)))
(:double
(let ((fpr (pop fprs)))
#+win32 (pop gprs)
(cond (fpr
(inst movq (ea slot-offset rsp) fpr))
(t
(incf stack-argument-count)
(inst mov rax (ea (* (+ 1 arg-slot-count stack-argument-count -1)
n-word-bytes) rsp))
(inst mov (ea slot-offset rsp) rax)))))))))))
;; Integer/pointer types
((not (alien-float-type-p type))
(let ((gpr (pop gprs)))
#+win32 (pop fprs)
;; Argument not in register, copy it from the old
;; stack location to a temporary register.
(unless gpr
(incf stack-argument-count)
(setf gpr rax)
(inst mov gpr stack-arg-tn))
;; Copy from either argument register or temporary
;; register to target.
(inst mov target-tn gpr)))
;; Float types
((or (alien-single-float-type-p type)
(alien-double-float-type-p type))
(let ((fpr (pop fprs)))
#+win32 (pop gprs)
(cond (fpr
;; Copy from float register to target location.
(inst movq target-tn fpr))
(t
;; Not in float register. Copy from stack to
;; temporary (general purpose) register, and
;; from there to the target location.
(incf stack-argument-count)
(inst mov rax stack-arg-tn)
(inst mov target-tn rax)))))
(t
(bug "Unknown alien callback argument type: ~S" type)))
;; Advance to next argument slot
(incf arg-offset arg-size)))
(macrolet
((call-wrapper ()
@ -553,9 +953,7 @@
;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
(inst mov rdi rsp)
;; add room on stack for return value
(inst sub rsp (if (evenp arg-count)
(* n-word-bytes 2)
n-word-bytes))
(inst sub rsp (* return-slot-count-aligned n-word-bytes))
;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
(inst mov rsi rsp)
@ -576,9 +974,7 @@
;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
(inst mov #-win32 rsi #+win32 rdx rsp)
;; add room on stack for return value
(inst sub rsp (if (evenp arg-count)
(* n-word-bytes 2)
n-word-bytes))
(inst sub rsp (* return-slot-count-aligned n-word-bytes))
;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
(inst mov #-win32 rdx #+win32 r8 rsp)
;; Make new frame
@ -603,18 +999,46 @@
(alien-double-float-type-p result-type))
(inst movq xmm0 [rsp]))
((alien-void-type-p result-type))
;; Struct return types
((alien-record-type-p result-type)
#-win32
(cond
;; Large struct: copy result to hidden pointer location, return pointer
(large-struct-return-p
(let ((struct-size (sb-alien::struct-classification-size result-classification)))
;; Copy struct data from stack to hidden pointer destination
(loop for off from 0 below struct-size by 8
do (inst mov rax (ea off rsp))
(inst mov (ea off r11) rax))
;; Return the hidden pointer in RAX
(inst mov rax r11)))
;; Small struct: copy to registers based on classification
(t
(let ((slots (sb-alien::struct-classification-register-slots result-classification))
(int-reg-idx 0)
(sse-reg-idx 0))
(loop for slot in slots
for offset from 0 by 8
do (ecase slot
(:integer
(let ((target (case int-reg-idx
(0 rax)
(1 rdx))))
(inst mov target (ea offset rsp)))
(incf int-reg-idx))
(:double
(let ((target (case sse-reg-idx
(0 xmm0)
(1 xmm1))))
(inst movq target (ea offset rsp)))
(incf sse-reg-idx))))))))
(t
(error "Unrecognized alien type: ~A" result-type)))
;; Pop the arguments and the return value from the stack to get
;; the return address at top of stack.
(inst add rsp (* (+ arg-count
;; Plus the return value and make sure it's aligned
(if (evenp arg-count)
2
1))
n-word-bytes))
(inst add rsp (* (+ arg-slot-count return-slot-count-aligned) n-word-bytes))
;; Return
(inst ret))
(finalize-segment segment)

352
tests/alien-struct-by-value.c
View file

@ -5,8 +5,16 @@ long long tiny_align_8_get_m0(struct tiny_align_8 m) { return m.m0; }
void tiny_align_8_mutate(volatile struct tiny_align_8 m) {
m.m0++;
}
struct tiny_align_8 tiny_align_8_return(long long val) {
struct tiny_align_8 result;
result.m0 = val;
return result;
}
struct tiny_align_8 tiny_align_8_identity(struct tiny_align_8 m) {
return m;
}
/** A small structure with 8-byte alignment.
/* A small structure with 8-byte alignment.
SysV x86-64 and AAPCS64 will pass this by register.
*/
struct small_align_8 {
@ -18,8 +26,17 @@ void small_align_8_mutate(volatile struct small_align_8 m) {
m.m0++;
m.m1++;
}
struct small_align_8 small_align_8_return(long long v0, long long v1) {
struct small_align_8 result;
result.m0 = v0;
result.m1 = v1;
return result;
}
struct small_align_8 small_align_8_identity(struct small_align_8 m) {
return m;
}
/** A large structure with 8-byte alignment.
/* A large structure with 8-byte alignment.
This should be too big for any architecture to pass by registers.
*/
struct large_align_8 {
@ -49,7 +66,7 @@ large_align_8_get(m13);
large_align_8_get(m14);
large_align_8_get(m15);
/** Mutates the input struct. Volatile to avoid compiler optimizing away the mutation.*/
/* Mutates the input struct. Volatile to avoid compiler optimizing away the mutation.*/
void large_align_8_mutate(volatile struct large_align_8 m) {
m.m0++;
m.m1++;
@ -68,3 +85,332 @@ void large_align_8_mutate(volatile struct large_align_8 m) {
m.m14++;
m.m15++;
}
struct large_align_8 large_align_8_return(long long v0, long long v1) {
struct large_align_8 result = {0};
result.m0 = v0;
result.m1 = v1;
return result;
}
struct large_align_8 large_align_8_identity(struct large_align_8 m) {
return m;
}
/** Structs with floating point members for SSE register testing */
struct two_doubles {
double d0, d1;
};
struct two_doubles two_doubles_return(double d0, double d1) {
struct two_doubles result;
result.d0 = d0;
result.d1 = d1;
return result;
}
double two_doubles_sum(struct two_doubles m) {
return m.d0 + m.d1;
}
struct two_doubles two_doubles_identity(struct two_doubles m) {
return m;
}
struct two_floats {
float f0, f1;
};
struct two_floats two_floats_return(float f0, float f1) {
struct two_floats result;
result.f0 = f0;
result.f1 = f1;
return result;
}
float two_floats_sum(struct two_floats m) {
return m.f0 + m.f1;
}
struct two_floats two_floats_identity(struct two_floats m) {
return m;
}
/** Mixed int and float struct - tests split register handling on x86-64 */
struct int_double {
long long i;
double d;
};
struct int_double int_double_return(long long i, double d) {
struct int_double result;
result.i = i;
result.d = d;
return result;
}
long long int_double_get_int(struct int_double m) { return m.i; }
double int_double_get_double(struct int_double m) { return m.d; }
struct int_double int_double_identity(struct int_double m) {
return m;
}
/** Medium struct (24 bytes) - too large for ARM64 registers, tests boundary */
struct medium_align_8 {
long long m0, m1, m2;
};
struct medium_align_8 medium_align_8_return(long long v0, long long v1, long long v2) {
struct medium_align_8 result;
result.m0 = v0;
result.m1 = v1;
result.m2 = v2;
return result;
}
long long medium_align_8_get_m0(struct medium_align_8 m) { return m.m0; }
long long medium_align_8_get_m1(struct medium_align_8 m) { return m.m1; }
long long medium_align_8_get_m2(struct medium_align_8 m) { return m.m2; }
struct medium_align_8 medium_align_8_identity(struct medium_align_8 m) {
return m;
}
/** Four floats struct - tests HFA (Homogeneous Floating-point Aggregate) on ARM64 */
struct four_floats {
float f0, f1, f2, f3;
};
struct four_floats four_floats_return(float f0, float f1, float f2, float f3) {
struct four_floats result;
result.f0 = f0;
result.f1 = f1;
result.f2 = f2;
result.f3 = f3;
return result;
}
float four_floats_sum(struct four_floats m) {
return m.f0 + m.f1 + m.f2 + m.f3;
}
struct four_floats four_floats_identity(struct four_floats m) {
return m;
}
/** Three doubles struct - tests HFA boundary (3 doubles = 24 bytes) */
struct three_doubles {
double d0, d1, d2;
};
struct three_doubles three_doubles_return(double d0, double d1, double d2) {
struct three_doubles result;
result.d0 = d0;
result.d1 = d1;
result.d2 = d2;
return result;
}
double three_doubles_sum(struct three_doubles m) {
return m.d0 + m.d1 + m.d2;
}
struct three_doubles three_doubles_identity(struct three_doubles m) {
return m;
}
/** HFA with array of 4 floats - tests array-based HFA detection on ARM64 */
struct float_array_4 {
float arr[4];
};
struct float_array_4 float_array_4_return(float f0, float f1, float f2, float f3) {
struct float_array_4 result;
result.arr[0] = f0;
result.arr[1] = f1;
result.arr[2] = f2;
result.arr[3] = f3;
return result;
}
float float_array_4_sum(struct float_array_4 m) {
return m.arr[0] + m.arr[1] + m.arr[2] + m.arr[3];
}
float float_array_4_get(struct float_array_4 m, int index) {
return m.arr[index];
}
struct float_array_4 float_array_4_identity(struct float_array_4 m) {
return m;
}
/** HFA with array of 2 doubles - tests array-based HFA with doubles */
struct double_array_2 {
double arr[2];
};
struct double_array_2 double_array_2_return(double d0, double d1) {
struct double_array_2 result;
result.arr[0] = d0;
result.arr[1] = d1;
return result;
}
double double_array_2_sum(struct double_array_2 m) {
return m.arr[0] + m.arr[1];
}
double double_array_2_get(struct double_array_2 m, int index) {
return m.arr[index];
}
struct double_array_2 double_array_2_identity(struct double_array_2 m) {
return m;
}
/** HFA with array of 3 floats - tests odd-sized array HFA */
struct float_array_3 {
float arr[3];
};
struct float_array_3 float_array_3_return(float f0, float f1, float f2) {
struct float_array_3 result;
result.arr[0] = f0;
result.arr[1] = f1;
result.arr[2] = f2;
return result;
}
float float_array_3_sum(struct float_array_3 m) {
return m.arr[0] + m.arr[1] + m.arr[2];
}
struct float_array_3 float_array_3_identity(struct float_array_3 m) {
return m;
}
/** Callback tests for struct-by-value parameters */
/* Callback type taking a small struct (16 bytes, passed in registers) */
typedef long long (*small_struct_callback)(struct small_align_8 s);
/* Callback type taking a large struct (32+ bytes, passed on stack) */
typedef long long (*large_struct_callback)(struct large_align_8 s);
/* Callback type taking two small structs (like CXCursor pattern) */
typedef long long (*two_structs_callback)(struct small_align_8 s1, struct small_align_8 s2);
/* Callback type taking a struct with floats */
typedef double (*float_struct_callback)(struct two_doubles s);
/* Function that calls a callback with a small struct */
long long call_with_small_struct(small_struct_callback cb, long long v0, long long v1) {
struct small_align_8 s;
s.m0 = v0;
s.m1 = v1;
return cb(s);
}
/* Function that calls a callback with a large struct */
long long call_with_large_struct(large_struct_callback cb,
long long v0, long long v1, long long v2, long long v3) {
struct large_align_8 s = {0};
s.m0 = v0;
s.m1 = v1;
s.m2 = v2;
s.m3 = v3;
return cb(s);
}
/* Function that calls a callback with two small structs */
long long call_with_two_structs(two_structs_callback cb,
long long a0, long long a1,
long long b0, long long b1) {
struct small_align_8 s1, s2;
s1.m0 = a0;
s1.m1 = a1;
s2.m0 = b0;
s2.m1 = b1;
return cb(s1, s2);
}
/* Function that calls a callback with a float struct */
double call_with_float_struct(float_struct_callback cb, double d0, double d1) {
struct two_doubles s;
s.d0 = d0;
s.d1 = d1;
return cb(s);
}
/* Callback type returning a small struct (16 bytes, in registers) */
typedef struct small_align_8 (*small_struct_return_callback)(long long v0, long long v1);
/* Callback type returning a struct with doubles (SSE registers) */
typedef struct two_doubles (*double_struct_return_callback)(double d0, double d1);
/* Callback type returning a large struct (>16 bytes, via hidden pointer) */
typedef struct medium_align_8 (*medium_struct_return_callback)(long long v0, long long v1, long long v2);
/* Function that calls a callback returning a small struct */
struct small_align_8 call_returning_small_struct(small_struct_return_callback cb,
long long v0, long long v1) {
return cb(v0, v1);
}
/* Function that calls a callback returning a struct with doubles */
struct two_doubles call_returning_double_struct(double_struct_return_callback cb,
double d0, double d1) {
return cb(d0, d1);
}
/* Function that calls a callback returning a large struct (hidden pointer) */
struct medium_align_8 call_returning_medium_struct(medium_struct_return_callback cb,
long long v0, long long v1, long long v2) {
return cb(v0, v1, v2);
}
/** Union tests - unions are a special case of records where all members share memory */
/* Small union (8 bytes) - fits in one register */
union small_union {
long long as_int;
double as_double;
};
union small_union small_union_from_int(long long val) {
union small_union u;
u.as_int = val;
return u;
}
union small_union small_union_from_double(double val) {
union small_union u;
u.as_double = val;
return u;
}
long long small_union_get_int(union small_union u) { return u.as_int; }
double small_union_get_double(union small_union u) { return u.as_double; }
union small_union small_union_identity(union small_union u) { return u; }
/* Medium union (16 bytes) - fits in two registers */
union medium_union {
struct { long long lo, hi; } as_pair;
struct { double d0, d1; } as_doubles;
};
union medium_union medium_union_from_pair(long long lo, long long hi) {
union medium_union u;
u.as_pair.lo = lo;
u.as_pair.hi = hi;
return u;
}
union medium_union medium_union_from_doubles(double d0, double d1) {
union medium_union u;
u.as_doubles.d0 = d0;
u.as_doubles.d1 = d1;
return u;
}
long long medium_union_get_lo(union medium_union u) { return u.as_pair.lo; }
long long medium_union_get_hi(union medium_union u) { return u.as_pair.hi; }
double medium_union_get_d0(union medium_union u) { return u.as_doubles.d0; }
double medium_union_get_d1(union medium_union u) { return u.as_doubles.d1; }
union medium_union medium_union_identity(union medium_union u) { return u; }
/* Large union (>16 bytes) - uses hidden pointer for return */
union large_union {
long long arr_int[4];
double arr_double[4];
};
union large_union large_union_from_ints(long long v0, long long v1, long long v2, long long v3) {
union large_union u;
u.arr_int[0] = v0;
u.arr_int[1] = v1;
u.arr_int[2] = v2;
u.arr_int[3] = v3;
return u;
}
long long large_union_get_int(union large_union u, int index) { return u.arr_int[index]; }
double large_union_get_double(union large_union u, int index) { return u.arr_double[index]; }
union large_union large_union_identity(union large_union u) { return u; }
/* Callback tests for unions */
typedef long long (*small_union_callback)(union small_union u);
typedef union small_union (*small_union_return_callback)(long long val);
long long call_with_small_union(small_union_callback cb, long long val) {
union small_union u;
u.as_int = val;
return cb(u);
}
union small_union call_returning_small_union(small_union_return_callback cb, long long val) {
return cb(val);
}

676
tests/alien-struct-by-value.impure.lisp
View file

@ -11,8 +11,9 @@
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
;(in-package :cl-user)
;;;; Bug 313202: C struct pass/return by value
#-(or (and x86-64 (not win32)) arm64) (invoke-restart 'run-tests::skip-file)
;;; Compile and load shared library
(defvar *soname*)
@ -30,45 +31,678 @@
(setq *soname* (truename "alien-struct-by-value.so"))
(load-shared-object *soname*))
(defmacro assert-unimplemented ((&whole def dar name ret &optional (arg nil argp)))
(declare (ignore dar ret))
;; all the "caught 1 fatal ERROR" notices are scary to those not expecting to see them
`(let ((*error-output* (make-broadcast-stream)))
(assert-error (eval '(progn ,def
,(if argp `(with-alien ((x ,(second arg))) (,name x)) '(name)))))))
;;; Tiny struct, alignment 8
;;; Tiny struct, alignment 8 (fits in one register)
(define-alien-type nil (struct tiny-align-8 (m0 (integer 64))))
(with-test (:name :struct-by-value-tiny-align-8-args)
(assert-unimplemented (define-alien-routine tiny-align-8-get-m0 (integer 64) (m (struct tiny-align-8))))
(assert-unimplemented (define-alien-routine tiny-align-8-mutate void (m (struct tiny-align-8))))
(assert-unimplemented (define-alien-routine tiny-align-8-return (struct tiny-align-8))))
;;; Small struct, alignment 8
(define-alien-routine tiny-align-8-get-m0 (integer 64) (m (struct tiny-align-8)))
(define-alien-routine tiny-align-8-mutate void (m (struct tiny-align-8)))
(define-alien-routine tiny-align-8-return (struct tiny-align-8) (val (integer 64)))
(define-alien-routine tiny-align-8-identity (struct tiny-align-8) (m (struct tiny-align-8)))
;;; Runtime tests for tiny struct
(with-test (:name :struct-by-value-tiny-align-8-runtime)
;; Test passing struct as argument
(with-alien ((s (struct tiny-align-8)))
(setf (slot s 'm0) 42)
(assert (= (tiny-align-8-get-m0 s) 42)))
;; Test passing different values
(with-alien ((s (struct tiny-align-8)))
(setf (slot s 'm0) -123456789)
(assert (= (tiny-align-8-get-m0 s) -123456789))))
;;; Runtime tests for tiny struct return
(with-test (:name :struct-by-value-tiny-align-8-return-runtime)
;; Test return from C function
(let ((result (tiny-align-8-return 42)))
(assert (= (slot result 'm0) 42)))
;; Test with negative value
(let ((result (tiny-align-8-return -987654321)))
(assert (= (slot result 'm0) -987654321)))
;; Test with zero
(let ((result (tiny-align-8-return 0)))
(assert (= (slot result 'm0) 0)))
;; Test with max positive value
(let ((result (tiny-align-8-return (1- (ash 1 63)))))
(assert (= (slot result 'm0) (1- (ash 1 63)))))
;; Test identity (pass struct, get same struct back)
(with-alien ((s (struct tiny-align-8)))
(setf (slot s 'm0) 12345)
(let ((result (tiny-align-8-identity s)))
(assert (= (slot result 'm0) 12345)))))
;;; Small struct, alignment 8 (fits in two registers)
(define-alien-type nil (struct small-align-8 (m0 (integer 64)) (m1 (integer 64))))
(with-test (:name :struct-by-value-small-align-8-args)
(assert-unimplemented (define-alien-routine small-align-8-get-m0 (integer 64) (m (struct small-align-8))))
(assert-unimplemented (define-alien-routine small-align-8-get-m1 (integer 64) (m (struct small-align-8))))
(assert-unimplemented (define-alien-routine small-align-8-mutate void (m (struct small-align-8)))))
;;; Large struct, alignment 8
(define-alien-routine small-align-8-get-m0 (integer 64) (m (struct small-align-8)))
(define-alien-routine small-align-8-get-m1 (integer 64) (m (struct small-align-8)))
(define-alien-routine small-align-8-mutate void (m (struct small-align-8)))
(define-alien-routine small-align-8-return (struct small-align-8)
(v0 (integer 64)) (v1 (integer 64)))
(define-alien-routine small-align-8-identity (struct small-align-8) (m (struct small-align-8)))
;;; Runtime tests for small struct (2 registers)
(with-test (:name :struct-by-value-small-align-8-runtime)
;; Test passing struct as argument
(with-alien ((s (struct small-align-8)))
(setf (slot s 'm0) 100)
(setf (slot s 'm1) 200)
(assert (= (small-align-8-get-m0 s) 100))
(assert (= (small-align-8-get-m1 s) 200)))
;; Test with negative values
(with-alien ((s (struct small-align-8)))
(setf (slot s 'm0) -999)
(setf (slot s 'm1) 888)
(assert (= (small-align-8-get-m0 s) -999))
(assert (= (small-align-8-get-m1 s) 888))))
;;; Runtime tests for small struct return
(with-test (:name :struct-by-value-small-align-8-return-runtime)
;; Test return from C function
(let ((result (small-align-8-return 100 200)))
(assert (= (slot result 'm0) 100))
(assert (= (slot result 'm1) 200)))
;; Test with negative values
(let ((result (small-align-8-return -111 222)))
(assert (= (slot result 'm0) -111))
(assert (= (slot result 'm1) 222)))
;; Test with zeros
(let ((result (small-align-8-return 0 0)))
(assert (= (slot result 'm0) 0))
(assert (= (slot result 'm1) 0)))
;; Test identity (pass struct, get same struct back)
(with-alien ((s (struct small-align-8)))
(setf (slot s 'm0) 11111)
(setf (slot s 'm1) 22222)
(let ((result (small-align-8-identity s)))
(assert (= (slot result 'm0) 11111))
(assert (= (slot result 'm1) 22222)))))
;;; Large struct, alignment 8 (too big for registers, uses hidden pointer)
(define-alien-type nil
(struct large-align-8
(m0 (integer 64)) (m4 (integer 64)) (m8 (integer 64)) (m12 (integer 64))
(m1 (integer 64)) (m5 (integer 64)) (m9 (integer 64)) (m13 (integer 64))
(m2 (integer 64)) (m6 (integer 64)) (m10 (integer 64)) (m14 (integer 64))
(m3 (integer 64)) (m7 (integer 64)) (m11 (integer 64)) (m15 (integer 64))))
(with-test (:name :struct-by-value-large-align-8-args)
(macrolet
((def-large-align-8-get (i)
(let ((lisp-name (sb-int:symbolicate "LARGE-ALIGN-8-GET-M" i)))
`(define-alien-routine ,lisp-name (integer 64) (m (struct large-align-8)))))
(defs-large-align-8-get ()
"Test functions for each member"
(let ((defs (loop for i upto 15 collect `(def-large-align-8-get ,i))))
`(progn ,@defs))))
(defs-large-align-8-get)
(define-alien-routine large-align-8-mutate void (m (struct large-align-8))))
#-(or x86-64 arm64)
(macrolet
((def-large-align-8-get (i)
(let ((lisp-name (sb-int:symbolicate "LARGE-ALIGN-8-GET-M" i)))
`(assert-unimplemented
(define-alien-routine ,lisp-name (integer 64) (m (struct large-align-8))))))
(defs-large-align-8-get ()
"Test functions for each member"
(let ((defs (loop for i upto 15 collect `(def-large-align-8-get ,i))))
`(progn ,@defs))))
(defs-large-align-8-get)
(assert-unimplemented
(define-alien-routine large-align-8-mutate void (m (struct large-align-8))))))
(define-alien-routine large-align-8-return (struct large-align-8)
(v0 (integer 64)) (v1 (integer 64)))
(define-alien-routine large-align-8-identity (struct large-align-8) (m (struct large-align-8)))
;;; Runtime tests for large struct (uses hidden pointer for return)
;;; Large structs (>16 bytes) are returned via hidden pointer in x8 (ARM64) or
;;; implicit first arg (x86-64).
(with-test (:name :struct-by-value-large-align-8-return-runtime)
;; Test return from C function
(let ((result (large-align-8-return 1000 2000)))
(assert (= (slot result 'm0) 1000))
(assert (= (slot result 'm1) 2000)))
;; Test identity (pass struct, get same struct back)
(with-alien ((s (struct large-align-8)))
(setf (slot s 'm0) 111)
(setf (slot s 'm1) 222)
(setf (slot s 'm2) 333)
(setf (slot s 'm3) 444)
(let ((result (large-align-8-identity s)))
(assert (= (slot result 'm0) 111))
(assert (= (slot result 'm1) 222))
(assert (= (slot result 'm2) 333))
(assert (= (slot result 'm3) 444)))))
;;; Floating-point struct tests (for SSE register handling on x86-64 and HFA on ARM64)
(define-alien-type nil (struct two-doubles (d0 double) (d1 double)))
(define-alien-type nil (struct two-floats (f0 single-float) (f1 single-float)))
(define-alien-type nil (struct int-double (i (integer 64)) (d double)))
(define-alien-routine two-doubles-return (struct two-doubles)
(d0 double) (d1 double))
(define-alien-routine two-doubles-sum double (m (struct two-doubles)))
(define-alien-routine two-doubles-identity (struct two-doubles) (m (struct two-doubles)))
;;; Runtime tests for floating-point struct (passing as argument)
(with-test (:name :struct-by-value-two-doubles-runtime)
(with-alien ((s (struct two-doubles)))
(setf (slot s 'd0) 1.5d0)
(setf (slot s 'd1) 2.5d0)
(assert (= (two-doubles-sum s) 4.0d0))))
;;; Runtime tests for floating-point struct return
(with-test (:name :struct-by-value-two-doubles-return-runtime)
;; Test return from C function
(let ((result (two-doubles-return 1.5d0 2.5d0)))
(assert (= (slot result 'd0) 1.5d0))
(assert (= (slot result 'd1) 2.5d0)))
;; Test with negative values
(let ((result (two-doubles-return -3.14159d0 2.71828d0)))
(assert (< (abs (- (slot result 'd0) -3.14159d0)) 1d-10))
(assert (< (abs (- (slot result 'd1) 2.71828d0)) 1d-10)))
;; Test with zeros
(let ((result (two-doubles-return 0.0d0 0.0d0)))
(assert (= (slot result 'd0) 0.0d0))
(assert (= (slot result 'd1) 0.0d0)))
;; Test identity (pass struct, get same struct back)
(with-alien ((s (struct two-doubles)))
(setf (slot s 'd0) 123.456d0)
(setf (slot s 'd1) 789.012d0)
(let ((result (two-doubles-identity s)))
(assert (= (slot result 'd0) 123.456d0))
(assert (= (slot result 'd1) 789.012d0)))))
(define-alien-routine two-floats-return (struct two-floats)
(f0 single-float) (f1 single-float))
(define-alien-routine two-floats-sum single-float (m (struct two-floats)))
(define-alien-routine two-floats-identity (struct two-floats) (m (struct two-floats)))
;;; Runtime tests for single-float struct return
(with-test (:name :struct-by-value-two-floats-return-runtime)
;; Test return from C function
(let ((result (two-floats-return 1.5 2.5)))
(assert (= (slot result 'f0) 1.5))
(assert (= (slot result 'f1) 2.5)))
;; Test with negative values
(let ((result (two-floats-return -3.5 4.5)))
(assert (= (slot result 'f0) -3.5))
(assert (= (slot result 'f1) 4.5)))
;; Test identity (pass struct, get same struct back)
(with-alien ((s (struct two-floats)))
(setf (slot s 'f0) 11.11)
(setf (slot s 'f1) 22.22)
(let ((result (two-floats-identity s)))
(assert (< (abs (- (slot result 'f0) 11.11)) 0.001))
(assert (< (abs (- (slot result 'f1) 22.22)) 0.001)))))
(define-alien-routine int-double-return (struct int-double)
(i (integer 64)) (d double))
(define-alien-routine int-double-get-int (integer 64) (m (struct int-double)))
(define-alien-routine int-double-get-double double (m (struct int-double)))
(define-alien-routine int-double-identity (struct int-double) (m (struct int-double)))
;;; Runtime tests for mixed int-double struct return
(with-test (:name :struct-by-value-int-double-return-runtime)
;; Test return from C function
(let ((result (int-double-return 42 3.14159d0)))
(assert (= (slot result 'i) 42))
(assert (< (abs (- (slot result 'd) 3.14159d0)) 1d-10)))
;; Test with negative values
(let ((result (int-double-return -999 -2.71828d0)))
(assert (= (slot result 'i) -999))
(assert (< (abs (- (slot result 'd) -2.71828d0)) 1d-10)))
;; Test identity (pass struct, get same struct back)
(with-alien ((s (struct int-double)))
(setf (slot s 'i) 12345)
(setf (slot s 'd) 67.89d0)
(let ((result (int-double-identity s)))
(assert (= (slot result 'i) 12345))
(assert (= (slot result 'd) 67.89d0)))))
;;; Medium struct (24 bytes) - tests boundary case (>16 bytes, uses hidden pointer)
(define-alien-type nil (struct medium-align-8 (m0 (integer 64)) (m1 (integer 64)) (m2 (integer 64))))
(define-alien-routine medium-align-8-return (struct medium-align-8)
(v0 (integer 64)) (v1 (integer 64)) (v2 (integer 64)))
(define-alien-routine medium-align-8-get-m0 (integer 64) (m (struct medium-align-8)))
(define-alien-routine medium-align-8-get-m1 (integer 64) (m (struct medium-align-8)))
(define-alien-routine medium-align-8-get-m2 (integer 64) (m (struct medium-align-8)))
(define-alien-routine medium-align-8-identity (struct medium-align-8) (m (struct medium-align-8)))
;;; Runtime tests for medium struct (24 bytes - uses hidden pointer)
(with-test (:name :struct-by-value-medium-align-8-return-runtime)
;; Test return from C function
(let ((result (medium-align-8-return 100 200 300)))
(assert (= (slot result 'm0) 100))
(assert (= (slot result 'm1) 200))
(assert (= (slot result 'm2) 300)))
;; Test identity
(with-alien ((s (struct medium-align-8)))
(setf (slot s 'm0) 111)
(setf (slot s 'm1) 222)
(setf (slot s 'm2) 333)
(let ((result (medium-align-8-identity s)))
(assert (= (slot result 'm0) 111))
(assert (= (slot result 'm1) 222))
(assert (= (slot result 'm2) 333)))))
;;; Four floats struct - tests HFA (Homogeneous Floating-point Aggregate) on ARM64
;;; 16 bytes total, fits in 4 single-precision FP registers on ARM64
(define-alien-type nil (struct four-floats (f0 single-float) (f1 single-float)
(f2 single-float) (f3 single-float)))
(define-alien-routine four-floats-return (struct four-floats)
(f0 single-float) (f1 single-float) (f2 single-float) (f3 single-float))
(define-alien-routine four-floats-sum single-float (m (struct four-floats)))
(define-alien-routine four-floats-identity (struct four-floats) (m (struct four-floats)))
(with-test (:name :struct-by-value-four-floats-return-runtime)
;; Test return from C function
(let ((result (four-floats-return 1.0 2.0 3.0 4.0)))
(assert (= (slot result 'f0) 1.0))
(assert (= (slot result 'f1) 2.0))
(assert (= (slot result 'f2) 3.0))
(assert (= (slot result 'f3) 4.0)))
;; Test sum (passing as argument)
(with-alien ((s (struct four-floats)))
(setf (slot s 'f0) 1.0)
(setf (slot s 'f1) 2.0)
(setf (slot s 'f2) 3.0)
(setf (slot s 'f3) 4.0)
(assert (= (four-floats-sum s) 10.0)))
;; Test identity
(with-alien ((s (struct four-floats)))
(setf (slot s 'f0) 1.5)
(setf (slot s 'f1) 2.5)
(setf (slot s 'f2) 3.5)
(setf (slot s 'f3) 4.5)
(let ((result (four-floats-identity s)))
(assert (= (slot result 'f0) 1.5))
(assert (= (slot result 'f1) 2.5))
(assert (= (slot result 'f2) 3.5))
(assert (= (slot result 'f3) 4.5)))))
;;; Three doubles struct - 24 bytes, HFA on ARM64 (fits in 3 double FP registers)
;;; But exceeds 16 bytes so may use memory return depending on ABI interpretation
(define-alien-type nil (struct three-doubles (d0 double) (d1 double) (d2 double)))
(define-alien-routine three-doubles-return (struct three-doubles)
(d0 double) (d1 double) (d2 double))
(define-alien-routine three-doubles-sum double (m (struct three-doubles)))
(define-alien-routine three-doubles-identity (struct three-doubles) (m (struct three-doubles)))
;;; Runtime tests for three doubles (24 bytes - uses hidden pointer)
(with-test (:name :struct-by-value-three-doubles-return-runtime)
;; Test return from C function
(let ((result (three-doubles-return 1.1d0 2.2d0 3.3d0)))
(assert (< (abs (- (slot result 'd0) 1.1d0)) 1d-10))
(assert (< (abs (- (slot result 'd1) 2.2d0)) 1d-10))
(assert (< (abs (- (slot result 'd2) 3.3d0)) 1d-10)))
;; Test sum (passing as argument)
(with-alien ((s (struct three-doubles)))
(setf (slot s 'd0) 1.0d0)
(setf (slot s 'd1) 2.0d0)
(setf (slot s 'd2) 3.0d0)
(assert (= (three-doubles-sum s) 6.0d0)))
;; Test identity
(with-alien ((s (struct three-doubles)))
(setf (slot s 'd0) 10.0d0)
(setf (slot s 'd1) 20.0d0)
(setf (slot s 'd2) 30.0d0)
(let ((result (three-doubles-identity s)))
(assert (= (slot result 'd0) 10.0d0))
(assert (= (slot result 'd1) 20.0d0))
(assert (= (slot result 'd2) 30.0d0)))))
;;; HFA with array of 4 floats - tests array-based HFA detection on ARM64
;;; This struct has a single field which is an array of 4 floats (16 bytes total)
;;; On ARM64, this should be detected as an HFA with 4 single-float members
(define-alien-type nil (struct float-array-4 (arr (array single-float 4))))
(define-alien-routine float-array-4-return (struct float-array-4)
(f0 single-float) (f1 single-float) (f2 single-float) (f3 single-float))
(define-alien-routine float-array-4-sum single-float (m (struct float-array-4)))
(define-alien-routine float-array-4-identity (struct float-array-4) (m (struct float-array-4)))
(with-test (:name :struct-by-value-float-array-4-return-runtime)
;; Test return from C function
(let ((result (float-array-4-return 1.0 2.0 3.0 4.0)))
(assert (= (deref (slot result 'arr) 0) 1.0))
(assert (= (deref (slot result 'arr) 1) 2.0))
(assert (= (deref (slot result 'arr) 2) 3.0))
(assert (= (deref (slot result 'arr) 3) 4.0)))
;; Test sum (passing as argument)
(with-alien ((s (struct float-array-4)))
(setf (deref (slot s 'arr) 0) 1.0)
(setf (deref (slot s 'arr) 1) 2.0)
(setf (deref (slot s 'arr) 2) 3.0)
(setf (deref (slot s 'arr) 3) 4.0)
(assert (= (float-array-4-sum s) 10.0)))
;; Test identity
(with-alien ((s (struct float-array-4)))
(setf (deref (slot s 'arr) 0) 1.5)
(setf (deref (slot s 'arr) 1) 2.5)
(setf (deref (slot s 'arr) 2) 3.5)
(setf (deref (slot s 'arr) 3) 4.5)
(let ((result (float-array-4-identity s)))
(assert (= (deref (slot result 'arr) 0) 1.5))
(assert (= (deref (slot result 'arr) 1) 2.5))
(assert (= (deref (slot result 'arr) 2) 3.5))
(assert (= (deref (slot result 'arr) 3) 4.5)))))
;;; HFA with array of 2 doubles - tests array-based HFA with doubles
;;; This struct has a single field which is an array of 2 doubles (16 bytes total)
(define-alien-type nil (struct double-array-2 (arr (array double 2))))
(define-alien-routine double-array-2-return (struct double-array-2)
(d0 double) (d1 double))
(define-alien-routine double-array-2-sum double (m (struct double-array-2)))
(define-alien-routine double-array-2-identity (struct double-array-2) (m (struct double-array-2)))
(with-test (:name :struct-by-value-double-array-2-return-runtime)
;; Test return from C function
(let ((result (double-array-2-return 1.5d0 2.5d0)))
(assert (= (deref (slot result 'arr) 0) 1.5d0))
(assert (= (deref (slot result 'arr) 1) 2.5d0)))
;; Test sum (passing as argument)
(with-alien ((s (struct double-array-2)))
(setf (deref (slot s 'arr) 0) 10.0d0)
(setf (deref (slot s 'arr) 1) 20.0d0)
(assert (= (double-array-2-sum s) 30.0d0)))
;; Test identity
(with-alien ((s (struct double-array-2)))
(setf (deref (slot s 'arr) 0) 100.0d0)
(setf (deref (slot s 'arr) 1) 200.0d0)
(let ((result (double-array-2-identity s)))
(assert (= (deref (slot result 'arr) 0) 100.0d0))
(assert (= (deref (slot result 'arr) 1) 200.0d0)))))
;;; HFA with array of 3 floats - tests odd-sized array HFA (12 bytes)
(define-alien-type nil (struct float-array-3 (arr (array single-float 3))))
(define-alien-routine float-array-3-return (struct float-array-3)
(f0 single-float) (f1 single-float) (f2 single-float))
(define-alien-routine float-array-3-sum single-float (m (struct float-array-3)))
(define-alien-routine float-array-3-identity (struct float-array-3) (m (struct float-array-3)))
(with-test (:name :struct-by-value-float-array-3-return-runtime)
;; Test return from C function
(let ((result (float-array-3-return 1.0 2.0 3.0)))
(assert (= (deref (slot result 'arr) 0) 1.0))
(assert (= (deref (slot result 'arr) 1) 2.0))
(assert (= (deref (slot result 'arr) 2) 3.0)))
;; Test sum (passing as argument)
(with-alien ((s (struct float-array-3)))
(setf (deref (slot s 'arr) 0) 1.0)
(setf (deref (slot s 'arr) 1) 2.0)
(setf (deref (slot s 'arr) 2) 3.0)
(assert (= (float-array-3-sum s) 6.0)))
;; Test identity
(with-alien ((s (struct float-array-3)))
(setf (deref (slot s 'arr) 0) 10.0)
(setf (deref (slot s 'arr) 1) 20.0)
(setf (deref (slot s 'arr) 2) 30.0)
(let ((result (float-array-3-identity s)))
(assert (= (deref (slot result 'arr) 0) 10.0))
(assert (= (deref (slot result 'arr) 1) 20.0))
(assert (= (deref (slot result 'arr) 2) 30.0)))))
;;;; Callback tests for struct-by-value parameters
;;;; These test receiving structs by value in Lisp callbacks called from C
;;; Define alien routines that call callbacks with struct parameters
(define-alien-routine call-with-small-struct (integer 64)
(cb system-area-pointer) (v0 (integer 64)) (v1 (integer 64)))
(define-alien-routine call-with-large-struct (integer 64)
(cb system-area-pointer)
(v0 (integer 64)) (v1 (integer 64)) (v2 (integer 64)) (v3 (integer 64)))
(define-alien-routine call-with-two-structs (integer 64)
(cb system-area-pointer)
(a0 (integer 64)) (a1 (integer 64)) (b0 (integer 64)) (b1 (integer 64)))
(define-alien-routine call-with-float-struct double
(cb system-area-pointer) (d0 double) (d1 double))
;;; Test callback with small struct parameter (16 bytes, passed in registers)
(with-test (:name :callback-struct-small)
(with-alien-callable
((cb (integer 64) ((s (struct small-align-8)))
(+ (slot s 'm0) (slot s 'm1))))
(assert (= (call-with-small-struct (alien-sap cb) 10 20) 30))
(assert (= (call-with-small-struct (alien-sap cb) -100 200) 100))
(assert (= (call-with-small-struct (alien-sap cb) 0 0) 0))))
;;; Test callback with large struct parameter (128 bytes, passed on stack)
(with-test (:name :callback-struct-large)
(with-alien-callable
((cb (integer 64) ((s (struct large-align-8)))
(+ (slot s 'm0) (slot s 'm1) (slot s 'm2) (slot s 'm3))))
(assert (= (call-with-large-struct (alien-sap cb) 1 2 3 4) 10))
(assert (= (call-with-large-struct (alien-sap cb) 100 200 300 400) 1000))
(assert (= (call-with-large-struct (alien-sap cb) -1 -2 -3 -4) -10))))
;;; Test callback with two struct parameters (like clang_visitChildren pattern)
(with-test (:name :callback-struct-two-structs)
(with-alien-callable
((cb (integer 64) ((s1 (struct small-align-8))
(s2 (struct small-align-8)))
(+ (slot s1 'm0) (slot s1 'm1)
(slot s2 'm0) (slot s2 'm1))))
(assert (= (call-with-two-structs (alien-sap cb) 1 2 3 4) 10))
(assert (= (call-with-two-structs (alien-sap cb) 10 20 30 40) 100))))
;;; Test callback with float struct parameter (SSE registers)
(with-test (:name :callback-struct-floats)
(with-alien-callable
((cb double ((s (struct two-doubles)))
(+ (slot s 'd0) (slot s 'd1))))
(assert (= (call-with-float-struct (alien-sap cb) 1.5d0 2.5d0) 4.0d0))
(assert (= (call-with-float-struct (alien-sap cb) 100.0d0 200.0d0) 300.0d0))))
;;; Define alien routines that call callbacks returning structs
(define-alien-routine call-returning-small-struct (struct small-align-8)
(cb system-area-pointer) (v0 (integer 64)) (v1 (integer 64)))
(define-alien-routine call-returning-double-struct (struct two-doubles)
(cb system-area-pointer) (d0 double) (d1 double))
(define-alien-routine call-returning-medium-struct (struct medium-align-8)
(cb system-area-pointer) (v0 (integer 64)) (v1 (integer 64)) (v2 (integer 64)))
;;; Test callback returning small struct (16 bytes, in registers)
(with-test (:name :callback-struct-return-small)
(with-alien-callable
((cb (struct small-align-8) ((v0 (integer 64)) (v1 (integer 64)))
(with-alien ((s (struct small-align-8)))
(setf (slot s 'm0) v0)
(setf (slot s 'm1) v1)
s)))
(let ((result (call-returning-small-struct (alien-sap cb) 100 200)))
(assert (= (slot result 'm0) 100))
(assert (= (slot result 'm1) 200)))
(let ((result (call-returning-small-struct (alien-sap cb) -42 42)))
(assert (= (slot result 'm0) -42))
(assert (= (slot result 'm1) 42)))))
;;; Test callback returning struct with doubles (SSE registers)
(with-test (:name :callback-struct-return-doubles)
(with-alien-callable
((cb (struct two-doubles) ((d0 double) (d1 double))
(with-alien ((s (struct two-doubles)))
(setf (slot s 'd0) d0)
(setf (slot s 'd1) d1)
s)))
(let ((result (call-returning-double-struct (alien-sap cb) 1.5d0 2.5d0)))
(assert (= (slot result 'd0) 1.5d0))
(assert (= (slot result 'd1) 2.5d0)))
(let ((result (call-returning-double-struct (alien-sap cb) -3.14d0 2.71d0)))
(assert (< (abs (- (slot result 'd0) -3.14d0)) 1d-10))
(assert (< (abs (- (slot result 'd1) 2.71d0)) 1d-10)))))
;;; Test callback returning large struct (24 bytes, via hidden pointer)
(with-test (:name :callback-struct-return-large
:broken-on :x86-64)
(with-alien-callable
((cb (struct medium-align-8) ((v0 (integer 64)) (v1 (integer 64)) (v2 (integer 64)))
(with-alien ((s (struct medium-align-8)))
(setf (slot s 'm0) v0)
(setf (slot s 'm1) v1)
(setf (slot s 'm2) v2)
s)))
(let ((result (call-returning-medium-struct (alien-sap cb) 111 222 333)))
(assert (= (slot result 'm0) 111))
(assert (= (slot result 'm1) 222))
(assert (= (slot result 'm2) 333)))
(let ((result (call-returning-medium-struct (alien-sap cb) -1 0 1)))
(assert (= (slot result 'm0) -1))
(assert (= (slot result 'm1) 0))
(assert (= (slot result 'm2) 1)))))
;;;; Union-by-value tests
;;; Small union (8 bytes) - fits in one register
(define-alien-type nil (union small-union
(as-int (integer 64))
(as-double double)))
(define-alien-routine small-union-from-int (union small-union) (val (integer 64)))
(define-alien-routine small-union-from-double (union small-union) (val double))
(define-alien-routine small-union-get-int (integer 64) (u (union small-union)))
(define-alien-routine small-union-get-double double (u (union small-union)))
(define-alien-routine small-union-identity (union small-union) (u (union small-union)))
;;; Runtime tests for small union
(with-test (:name :union-by-value-small-runtime)
;; Test creating union from int and reading back
(let ((result (small-union-from-int 42)))
(assert (= (slot result 'as-int) 42)))
;; Test creating union from double and reading back
(let ((result (small-union-from-double 3.14159d0)))
(assert (< (abs (- (slot result 'as-double) 3.14159d0)) 1d-10)))
;; Test passing union as argument (as int)
(with-alien ((u (union small-union)))
(setf (slot u 'as-int) 12345)
(assert (= (small-union-get-int u) 12345)))
;; Test passing union as argument (as double)
(with-alien ((u (union small-union)))
(setf (slot u 'as-double) 2.71828d0)
(assert (< (abs (- (small-union-get-double u) 2.71828d0)) 1d-10)))
;; Test identity
(with-alien ((u (union small-union)))
(setf (slot u 'as-int) 999)
(let ((result (small-union-identity u)))
(assert (= (slot result 'as-int) 999)))))
;;; Medium union (16 bytes) - fits in two registers
(define-alien-type nil (union medium-union
(as-pair (struct medium-union-pair
(lo (integer 64))
(hi (integer 64))))
(as-doubles (struct medium-union-doubles
(d0 double)
(d1 double)))))
(define-alien-routine medium-union-from-pair (union medium-union)
(lo (integer 64)) (hi (integer 64)))
(define-alien-routine medium-union-from-doubles (union medium-union)
(d0 double) (d1 double))
(define-alien-routine medium-union-get-lo (integer 64) (u (union medium-union)))
(define-alien-routine medium-union-get-hi (integer 64) (u (union medium-union)))
(define-alien-routine medium-union-get-d0 double (u (union medium-union)))
(define-alien-routine medium-union-get-d1 double (u (union medium-union)))
(define-alien-routine medium-union-identity (union medium-union) (u (union medium-union)))
;;; Runtime tests for medium union
(with-test (:name :union-by-value-medium-runtime)
;; Test creating union from pair of ints
(let ((result (medium-union-from-pair 100 200)))
(assert (= (slot (slot result 'as-pair) 'lo) 100))
(assert (= (slot (slot result 'as-pair) 'hi) 200)))
;; Test creating union from pair of doubles
(let ((result (medium-union-from-doubles 1.5d0 2.5d0)))
(assert (= (slot (slot result 'as-doubles) 'd0) 1.5d0))
(assert (= (slot (slot result 'as-doubles) 'd1) 2.5d0)))
;; Test passing union as argument
(with-alien ((u (union medium-union)))
(setf (slot (slot u 'as-pair) 'lo) 111)
(setf (slot (slot u 'as-pair) 'hi) 222)
(assert (= (medium-union-get-lo u) 111))
(assert (= (medium-union-get-hi u) 222))
(let ((result (medium-union-identity u)))
(assert (= (slot (slot result 'as-pair) 'lo) 111))
(assert (= (slot (slot result 'as-pair) 'hi) 222)))))
;;; Large union (32 bytes) - uses hidden pointer for return
(define-alien-type nil (union large-union
(arr-int (array (integer 64) 4))
(arr-double (array double 4))))
(define-alien-routine large-union-from-ints (union large-union)
(v0 (integer 64)) (v1 (integer 64)) (v2 (integer 64)) (v3 (integer 64)))
(define-alien-routine large-union-get-int (integer 64)
(u (union large-union)) (index int))
(define-alien-routine large-union-get-double double
(u (union large-union)) (index int))
(define-alien-routine large-union-identity (union large-union) (u (union large-union)))
;;; Runtime tests for large union
(with-test (:name :union-by-value-large-runtime)
;; Test creating union from ints
(let ((result (large-union-from-ints 10 20 30 40)))
(assert (= (deref (slot result 'arr-int) 0) 10))
(assert (= (deref (slot result 'arr-int) 1) 20))
(assert (= (deref (slot result 'arr-int) 2) 30))
(assert (= (deref (slot result 'arr-int) 3) 40)))
;; Test passing union as argument
(with-alien ((u (union large-union)))
(setf (deref (slot u 'arr-int) 0) 100)
(setf (deref (slot u 'arr-int) 1) 200)
(setf (deref (slot u 'arr-int) 2) 300)
(setf (deref (slot u 'arr-int) 3) 400)
(assert (= (large-union-get-int u 0) 100))
(assert (= (large-union-get-int u 1) 200))
(assert (= (large-union-get-int u 2) 300))
(assert (= (large-union-get-int u 3) 400)))
;; Test identity
(with-alien ((u (union large-union)))
(setf (deref (slot u 'arr-int) 0) 1)
(setf (deref (slot u 'arr-int) 1) 2)
(setf (deref (slot u 'arr-int) 2) 3)
(setf (deref (slot u 'arr-int) 3) 4)
(let ((result (large-union-identity u)))
(assert (= (deref (slot result 'arr-int) 0) 1))
(assert (= (deref (slot result 'arr-int) 1) 2))
(assert (= (deref (slot result 'arr-int) 2) 3))
(assert (= (deref (slot result 'arr-int) 3) 4)))))
;;; Callback tests for unions
(define-alien-routine call-with-small-union (integer 64)
(cb system-area-pointer) (val (integer 64)))
(define-alien-routine call-returning-small-union (union small-union)
(cb system-area-pointer) (val (integer 64)))
;;; Test callback with union parameter
(with-test (:name :callback-union-parameter)
(with-alien-callable
((cb (integer 64) ((u (union small-union)))
(slot u 'as-int)))
(assert (= (call-with-small-union (alien-sap cb) 42) 42))
(assert (= (call-with-small-union (alien-sap cb) -999) -999))))
;;; Test callback returning union
(with-test (:name :callback-union-return)
(with-alien-callable
((cb (union small-union) ((val (integer 64)))
(with-alien ((u (union small-union)))
(setf (slot u 'as-int) val)
u)))
(let ((result (call-returning-small-union (alien-sap cb) 12345)))
(assert (= (slot result 'as-int) 12345)))
(let ((result (call-returning-small-union (alien-sap cb) -54321)))
(assert (= (slot result 'as-int) -54321)))))
;;; Clean up
#-win32 (ignore-errors (delete-file *soname*))

3
xperfecthash63.lisp-expr
View file

@ -1693,5 +1693,8 @@
(#(63C481C2 73D42188 937BB764 A4528420 B0E6341F D0F360C2 D5F368A1)
"(CEILING FLOOR TRUNCATE ABS ASH * /)"
"((& (+ (>> val 1) (>> val 22) (>> val 28)) 7))")
(#(42D83FFB 71FB8EC1 9E6D8DE3 B8BBE117 FB0112B4)
"(:ALLOW-OTHER-KEYS :MEMORY-P :ALIGNMENT :SIZE :REGISTER-SLOTS)"
"((& (- (>> val 3) (>> val 22)) 7))")
)
;; EOF