diff --git a/mats/foreign.ms b/mats/foreign.ms index 1ec0bcbbb..48a8fc005 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -3716,6 +3716,28 @@ (let ([v (cb_send cb)]) (and (= v 112.25) (loop (sub1 i))))])))) + + (let () + (define-ftype intfloat (struct + [i int] + [f float])) + (define-ftype callback (function (int float) (& intfloat))) + (define intfloat_sum_built + (foreign-procedure "intfloat_sum_built" + ((* callback)) double)) + (let ([cb (make-ftype-pointer + callback + (lambda (r i f) + (ftype-set! intfloat (i) r i) + (ftype-set! intfloat (f) r f)))]) + (and (equal? (intfloat_sum_built cb) + 110.0) + (begin + (unlock-object + (foreign-callable-code-object + (ftype-pointer-address cb))) + #t)))) + ) (mat collect-safe diff --git a/mats/foreign4.c b/mats/foreign4.c index 6eb2f8592..476de01d8 100644 --- a/mats/foreign4.c +++ b/mats/foreign4.c @@ -447,3 +447,16 @@ static double _f4_sum_struct_uniondoubledouble_double (struct_uniondoubledouble_ } static struct_uniondoubledouble_double init_struct_uniondoubledouble_double = { { 99.0 }, -12.5}; GEN(struct_uniondoubledouble_double, init_struct_uniondoubledouble_double, _f4_sum_struct_uniondoubledouble_double) + +typedef struct { + int i; + float f; +} intfloat; +typedef intfloat (*intfloat_build_t)(int i, float f); + +static double intfloat_sum(intfloat n) { + return n.f + n.i; +} +EXPORT double intfloat_sum_built(intfloat_build_t proc) { + return intfloat_sum(proc(10, 100.0)); +} diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 19ce7110b..c91c3eeb2 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -3021,6 +3021,14 @@ A bug that affects compilation on 32-bit ARM systems has been fixed. The bug was when an offset to a floating-point field or array element was unaligned or too large to fit into the 12-bit encoding used for immediate offsets. +\subsection{Fix x86\_64 foreign callables with in-register struct results (10.4.0)} + +A bug that affects compilation for foreign callables on x86\_64 +systems has been fixed. The bug was triggered when a callable returns +a \scheme{struct} that is small enough to fit into return registers, +and when arguments to the callable include floating-point values. In +that case, arguments were not delivered correctly to the callable. + \subsection{Generic \protect\scheme{+} misoptimized with \protect\scheme{+nan.0} and non-real arguments (10.4.0)} A bug in the source optimizer (cp0) treated flonum NaN as a bottom value diff --git a/s/x86_64.ss b/s/x86_64.ss index c4d6ec2a1..93225b85b 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -3088,8 +3088,8 @@ incoming | incoming return address | one quad | | | incoming stack args | sp+192: | | - +---------------------------+ <- 16-byte boundary - | incoming return address | one quad +incoming +---------------------------+ <- 16-byte boundary + sp-> sp+184: | incoming return address | one quad +---------------------------+ sp+176: | pad word / active state | one quad +---------------------------+ @@ -3406,7 +3406,8 @@ incoming | incoming return address | one quad [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)] [synthesize-first? (and result-classes (result-fits-in-registers? result-classes))] - [locs (do-stack (if synthesize-first? (cdr arg-type*) arg-type*) adjust-active?)]) + [save-arg-type* (if synthesize-first? (cdr arg-type*) arg-type*)] + [locs (do-stack save-arg-type* adjust-active?)]) (let-values ([(get-result result-regs result-fp-regs) (do-result result-type result-classes adjust-active?)]) (values (lambda () @@ -3431,7 +3432,7 @@ incoming | incoming return address | one quad (set! ,(%mref ,%sp ,%zero 32 fp) ,%fp7) (set! ,(%mref ,%sp ,%zero 40 fp) ,%fp8) (set! ,%sp ,(%inline - ,%sp (immediate 8))) - ,(save-arg-regs arg-type*)) + ,(save-arg-regs save-arg-type*)) (%seq (set! ,%sp ,(%inline - ,%sp (immediate 136))) ,(%inline push ,%rbx) @@ -3440,7 +3441,7 @@ incoming | incoming return address | one quad ,(%inline push ,%r13) ,(%inline push ,%r14) ,(%inline push ,%r15) - ,(save-arg-regs arg-type*))) + ,(save-arg-regs save-arg-type*))) ,(if-feature pthreads ((lambda (e) (if adjust-active?