add a __varargs FFI convention modifier
The varargs convention differs from the fixed-argument convention on arm32le. original commit: b2029432e66f188911194cdb8eea2cb3725f5cd3
This commit is contained in:
Matthew Flatt
parent
36aa0aad01
commit
237f0e4fa4
|
|
@ -220,7 +220,10 @@ Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only).
|
|||
Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is
|
||||
equivalent to specifying \scheme{#f} or no convention.
|
||||
Finally, \var{conv} can be \scheme{__collect_safe} to indicate that garbage
|
||||
collection is allowed concurrent to a call of the foreign procedure.
|
||||
collection is allowed concurrent to a call of the foreign procedure, or it
|
||||
can be \var{conv} can be \scheme{__varargs} to indicate that the procedure
|
||||
uses a convention that works with a variable number of arguments (which
|
||||
differs from the fixed-argument variant for some platforms and conventions).
|
||||
|
||||
Use \scheme{__stdcall} to access most Windows API procedures.
|
||||
Use \scheme{__cdecl} for Windows API varargs procedures,
|
||||
|
|
|
|||
|
|
@ -1038,6 +1038,12 @@
|
|||
(define call-u64 (foreign-procedure "call_u64" (ptr unsigned-64 int int) unsigned-64))
|
||||
(define call-sf (foreign-procedure "call_sf" (ptr single-float int int) single-float))
|
||||
(define call-df (foreign-procedure "call_df" (ptr double-float int int) double-float))
|
||||
(define call-varargs-df (foreign-procedure "call_varargs_df" (ptr double-float int int) double-float))
|
||||
(define call-varargs-i7df (foreign-procedure "call_varargs_i7df" (ptr int
|
||||
double-float double-float double-float
|
||||
double-float double-float double-float
|
||||
double-float)
|
||||
double-float))
|
||||
(define ($test-call-int signed? size call-int make-fc)
|
||||
(define n10000 (expt 256 size))
|
||||
(define nffff (- n10000 1))
|
||||
|
|
@ -1151,6 +1157,22 @@
|
|||
(double-float) double-float)
|
||||
73.25 7 23)
|
||||
108.25)
|
||||
(equal?
|
||||
(call-varargs-df
|
||||
(foreign-callable
|
||||
__varargs
|
||||
(lambda (x y) (+ x y 5))
|
||||
(double-float double-float) double-float)
|
||||
10.25 20 300)
|
||||
325.5)
|
||||
(equal?
|
||||
(call-varargs-i7df
|
||||
(foreign-callable
|
||||
__varargs
|
||||
(lambda (i a b c d e f g) (+ i a b c d e f g 7))
|
||||
(int double-float double-float double-float double-float double-float double-float double-float) double-float)
|
||||
1 2.2 3.2 4.5 6.7 8.9 10.1 11.5)
|
||||
55.1)
|
||||
|
||||
(error?
|
||||
(call-i8
|
||||
|
|
@ -1212,6 +1234,13 @@
|
|||
(lambda (x) '(- x 7))
|
||||
(double-float) double-float)
|
||||
73.25 0 0))
|
||||
(error?
|
||||
(call-varargs-df
|
||||
(foreign-callable
|
||||
__varargs
|
||||
(lambda (x y) '(- x 7))
|
||||
(double-float double-float) double-float)
|
||||
73.25 0 0))
|
||||
|
||||
(begin
|
||||
(define u32xu32->u64
|
||||
|
|
@ -2687,7 +2716,7 @@
|
|||
(separate-eval
|
||||
`(begin
|
||||
,load-libc
|
||||
(define f (foreign-procedure "printf" (string double) int))
|
||||
(define f (foreign-procedure __varargs "printf" (string double) int))
|
||||
(f "(%g)" 3.5)
|
||||
(void)))
|
||||
read)
|
||||
|
|
@ -2697,7 +2726,7 @@
|
|||
(separate-eval
|
||||
`(begin
|
||||
,load-libc
|
||||
(define f (foreign-procedure "printf" (string double double double double double double) int))
|
||||
(define f (foreign-procedure __varargs "printf" (string double double double double double double) int))
|
||||
(f "(%g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5)
|
||||
(void)))
|
||||
read)
|
||||
|
|
@ -2707,7 +2736,7 @@
|
|||
(separate-eval
|
||||
`(begin
|
||||
,load-libc
|
||||
(define f (foreign-procedure "printf" (string double double double double double double double double) int))
|
||||
(define f (foreign-procedure __varargs "printf" (string double double double double double double double double) int))
|
||||
(f "(%g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5)
|
||||
(void)))
|
||||
read)
|
||||
|
|
@ -2717,11 +2746,30 @@
|
|||
(separate-eval
|
||||
`(begin
|
||||
,load-libc
|
||||
(define f (foreign-procedure "printf" (string double double double double double double double double double double) int))
|
||||
(define f (foreign-procedure __varargs "printf" (string double double double double double double double double double double) int))
|
||||
(f "(%g %g %g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5)
|
||||
(void)))
|
||||
read)
|
||||
'(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5))
|
||||
|
||||
(equal? (let ([cb (foreign-callable __varargs
|
||||
(lambda (x y) (+ x y 5))
|
||||
(double-float double-float) double-float)])
|
||||
(with-object-kept-live
|
||||
cb
|
||||
((foreign-procedure __varargs (foreign-callable-entry-point cb)
|
||||
(double-float double-float) double-float)
|
||||
3.4 5.5)))
|
||||
13.9)
|
||||
(equal? (let ([cb (foreign-callable __varargs
|
||||
(lambda (x y) (+ x y 5))
|
||||
(double-float double-float) single-float)])
|
||||
(with-object-kept-live
|
||||
cb
|
||||
((foreign-procedure __varargs (foreign-callable-entry-point cb)
|
||||
(double-float double-float) single-float)
|
||||
3.5 -5.25)))
|
||||
3.25)
|
||||
)
|
||||
|
||||
(mat structs
|
||||
|
|
|
|||
|
|
@ -244,6 +244,17 @@ EXPORT double_float call_df(ptr code, double_float x, int m, int k) {
|
|||
return (*((double_float (*) (double_float))Sforeign_callable_entry_point(code)))(x + m) + k;
|
||||
}
|
||||
|
||||
EXPORT double_float call_varargs_df(ptr code, double_float x, int m, int k) {
|
||||
return (*((double_float (*) (double, ...))Sforeign_callable_entry_point(code)))(x - m, x + m) + k;
|
||||
}
|
||||
|
||||
EXPORT double_float call_varargs_i7df(ptr code, int i,
|
||||
double_float a, double_float b, double_float c,
|
||||
double_float d, double_float e, double_float f,
|
||||
double_float g) {
|
||||
return (*((double_float (*) (int, ...))Sforeign_callable_entry_point(code)))(i, a, b, c, d, e, f, g);
|
||||
}
|
||||
|
||||
EXPORT u8 *u8_star_to_u8_star(u8 *s) {
|
||||
return s == (u8 *)0 ? (u8 *)0 : s + 1;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -9950,6 +9950,7 @@ foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid
|
|||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
|
||||
foreign.mo:Expected error in mat foreign-C-types: "int-to-int: invalid foreign-procedure argument qqq".
|
||||
foreign.mo:Expected error in mat foreign-C-types: "unsigned-to-unsigned: invalid foreign-procedure argument qqq".
|
||||
foreign.mo:Expected error in mat foreign-C-types: "unsigned-int-to-unsigned-int: invalid foreign-procedure argument qqq".
|
||||
|
|
|
|||
201
s/arm32.ss
201
s/arm32.ss
|
|
@ -1218,6 +1218,7 @@
|
|||
(define-op mrc mrc/mcr-op #b1)
|
||||
|
||||
(define-op vadd vadd-op #b11 #b0 #b11100)
|
||||
|
||||
(define-op vsub vadd-op #b11 #b1 #b11100)
|
||||
(define-op vmul vadd-op #b10 #b0 #b11100)
|
||||
(define-op vdiv vadd-op #b00 #b0 #b11101)
|
||||
|
|
@ -2561,6 +2562,8 @@
|
|||
(or (andmap double-member? members)
|
||||
(andmap float-member? members)))))]
|
||||
[else #f]))
|
||||
(define num-int-regs 4) ; number of integer registers normally usd by the ABI
|
||||
(define num-dbl-regs 8) ; number of `double` registers normally usd by the ABI
|
||||
(define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b
|
||||
%Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b)))
|
||||
(define-who asm-foreign-call
|
||||
|
|
@ -2615,6 +2618,15 @@
|
|||
(lambda (fpreg fp-disp single?)
|
||||
(lambda (x) ; requires var
|
||||
`(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))]
|
||||
[load-double-int-reg
|
||||
(lambda (loreg hireg)
|
||||
(lambda (x) ; requires var
|
||||
(let-values ([(endreg otherreg) (constant-case native-endianness
|
||||
[(little) (values loreg hireg)]
|
||||
[(big) (values hireg loreg)])])
|
||||
(%seq
|
||||
(set! ,endreg ,(%mref ,x ,(constant flonum-data-disp)))
|
||||
(set! ,otherreg ,(%mref ,x ,(fx+ 4 (constant flonum-data-disp))))))))]
|
||||
[load-int-reg
|
||||
(lambda (ireg)
|
||||
(lambda (x)
|
||||
|
|
@ -2648,23 +2660,35 @@
|
|||
(set! ,loreg ,(%mref ,x ,from-offset))
|
||||
(set! ,hireg ,(%mref ,x ,(fx+ from-offset 4))))))]
|
||||
[do-args
|
||||
(lambda (types)
|
||||
(lambda (types varargs?)
|
||||
; sgl* is always of even-length, i.e., has a sgl/dbl reg first
|
||||
; bsgl is set to "b" single (second half of double) if we have one to fill
|
||||
(let loop ([types types] [locs '()] [live* '()] [int* (int-regs)] [sgl* (sgl-regs)] [bsgl #f] [isp 0])
|
||||
(let loop ([types types] [locs '()] [live* '()] [int* (int-regs)] [sgl* (if varargs? '() (sgl-regs))] [bsgl #f] [isp 0])
|
||||
(if (null? types)
|
||||
(values isp locs live*)
|
||||
(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-double-float)
|
||||
(if (null? sgl*)
|
||||
(let ([isp (align 8 isp)])
|
||||
(loop (cdr types)
|
||||
(cond
|
||||
[(and varargs?
|
||||
;; For varargs, treat a double like a 64-bit integer
|
||||
(let ([int* (if (even? (length int*)) int* (cdr int*))])
|
||||
(and (pair? int*)
|
||||
int*)))
|
||||
=> (lambda (int*)
|
||||
(loop (cdr types)
|
||||
(cons (load-double-int-reg (car int*) (cadr int*)) locs)
|
||||
(cons* (car int*) (cadr int*) live*) (cddr int*) sgl* bsgl isp))]
|
||||
[(null? sgl*)
|
||||
(let ([isp (align 8 isp)])
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack isp) locs)
|
||||
live* int* '() #f (fx+ isp 8)))
|
||||
(loop (cdr types)
|
||||
(cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs)
|
||||
live* int* (cddr sgl*) bsgl isp))]
|
||||
live* int* '() #f (fx+ isp 8)))]
|
||||
[else
|
||||
(loop (cdr types)
|
||||
(cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs)
|
||||
live* int* (cddr sgl*) bsgl isp)])]
|
||||
[(fp-single-float)
|
||||
(safe-assert (not varargs?))
|
||||
(if bsgl
|
||||
(loop (cdr types)
|
||||
(cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs)
|
||||
|
|
@ -2687,7 +2711,8 @@
|
|||
[(8)
|
||||
(let* ([int* (if (even? (length int*)) int* (cdr int*))]
|
||||
[num-members (length members)]
|
||||
[doubles? (and (fx<= num-members 4)
|
||||
[doubles? (and (not varargs?)
|
||||
(fx<= num-members 4)
|
||||
(andmap double-member? members))])
|
||||
;; Sequence of up to 4 doubles that fits in registers?
|
||||
(cond
|
||||
|
|
@ -2720,7 +2745,8 @@
|
|||
(cons* (car int*) (cadr int*) live*) (cddr int*) isp))]))]))]
|
||||
[else
|
||||
(let* ([num-members (length members)]
|
||||
[floats? (and (fx<= num-members 4)
|
||||
[floats? (and (not varargs?)
|
||||
(fx<= num-members 4)
|
||||
(andmap float-member? members))])
|
||||
;; Sequence of up to 4 floats that fits in registers?
|
||||
(cond
|
||||
|
|
@ -2820,9 +2846,11 @@
|
|||
(lambda (info)
|
||||
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
|
||||
(let* ([arg-type* (info-foreign-arg-type* info)]
|
||||
[varargs? (memq 'varargs (info-foreign-conv* info))]
|
||||
[result-type (info-foreign-result-type info)]
|
||||
[fill-result-here? (indirect-result-that-fits-in-registers? result-type)])
|
||||
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
|
||||
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)
|
||||
varargs?)
|
||||
(lambda (args-frame-size locs live*)
|
||||
(let* ([frame-size (align 8 (+ args-frame-size
|
||||
(if fill-result-here?
|
||||
|
|
@ -2846,13 +2874,23 @@
|
|||
`(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0)))
|
||||
(nanopass-case (Ltype Type) result-type
|
||||
[(fp-double-float)
|
||||
(lambda (lvalue)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
|
||||
,(%constant flonum-data-disp)))]
|
||||
(if varargs?
|
||||
(lambda (lvalue)
|
||||
`(set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp)
|
||||
,(%inline fpcastfrom ,%r1 ,%Cretval)))
|
||||
(lambda (lvalue)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
|
||||
,(%constant flonum-data-disp))))]
|
||||
[(fp-single-float)
|
||||
(lambda (lvalue)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero
|
||||
,(%constant flonum-data-disp)))]
|
||||
(if varargs?
|
||||
(lambda (lvalue)
|
||||
`(seq
|
||||
(set! ,%fptmp1 ,(%inline fpcastfrom ,%r1 ,%Cretval)) ; we don't actuall care about the hi/%r1 part
|
||||
(inline ,(make-info-loadfl %fptmp1) ,%store-single->double ,lvalue ,%zero,
|
||||
(%constant flonum-data-disp))))
|
||||
(lambda (lvalue)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero
|
||||
,(%constant flonum-data-disp))))]
|
||||
[(fp-integer ,bits)
|
||||
(case bits
|
||||
[(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%r0)))]
|
||||
|
|
@ -2956,16 +2994,19 @@
|
|||
(lambda (lvalue)
|
||||
`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
|
||||
(define count-reg-args
|
||||
(lambda (types synthesize-first?)
|
||||
(lambda (types synthesize-first? varargs?)
|
||||
; bsgl? is #t iff we have a "b" single (second half of double) float reg to fill
|
||||
(let f ([types types] [iint (if synthesize-first? -1 0)] [idbl 0] [bsgl? #f])
|
||||
(if (null? types)
|
||||
(values iint idbl)
|
||||
(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-double-float)
|
||||
(if (fx< idbl 8)
|
||||
(f (cdr types) iint (fx+ idbl 1) bsgl?)
|
||||
(f (cdr types) iint idbl #f))]
|
||||
(if varargs?
|
||||
(let ([iint (align 2 iint)])
|
||||
(f (cdr types) (if (fx< iint num-int-regs) (fx+ iint 2) iint) idbl bsgl?))
|
||||
(if (fx< idbl 8)
|
||||
(f (cdr types) iint (fx+ idbl 1) bsgl?)
|
||||
(f (cdr types) iint idbl #f)))]
|
||||
[(fp-single-float)
|
||||
(if bsgl?
|
||||
(f (cdr types) iint idbl #f)
|
||||
|
|
@ -3006,8 +3047,8 @@
|
|||
[(fp-unsigned ,bits) (fx= bits 64)]
|
||||
[else #f])
|
||||
(let ([iint (align 2 iint)])
|
||||
(f (cdr types) (if (fx< iint 4) (fx+ iint 2) iint) idbl bsgl?))
|
||||
(f (cdr types) (if (fx< iint 4) (fx+ iint 1) iint) idbl bsgl?))])))))
|
||||
(f (cdr types) (if (fx< iint num-int-regs) (fx+ iint 2) iint) idbl bsgl?))
|
||||
(f (cdr types) (if (fx< iint num-int-regs) (fx+ iint 1) iint) idbl bsgl?))])))))
|
||||
(define do-stack
|
||||
; all of the args are on the stack at this point, though not contiguous since
|
||||
; we push all of the int reg args with one push instruction and all of the
|
||||
|
|
@ -3015,7 +3056,7 @@
|
|||
; continue on into the stack variables, which is convenient when a struct
|
||||
; argument is split across registers and the stack
|
||||
(lambda (types saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
|
||||
synthesize-first?)
|
||||
synthesize-first? varargs?)
|
||||
(let* ([return-space-offset (fx+ saved-reg-bytes pre-pad-bytes)]
|
||||
[float-reg-offset (fx+ return-space-offset return-bytes)]
|
||||
[int-reg-offset (fx+ float-reg-offset float-reg-bytes post-pad-bytes)]
|
||||
|
|
@ -3036,20 +3077,36 @@
|
|||
locs))
|
||||
(nanopass-case (Ltype Type) (car types)
|
||||
[(fp-double-float)
|
||||
(if (< idbl 8)
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack float-reg-offset) locs)
|
||||
iint (fx+ idbl 1) bsgl-offset int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)
|
||||
(let ([stack-arg-offset (align 8 stack-arg-offset)])
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack stack-arg-offset) locs)
|
||||
iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))))]
|
||||
(cond
|
||||
[(and varargs?
|
||||
;; For varargs, treat a double like a 64-bit integer
|
||||
(let ([iint (align 2 iint)])
|
||||
(and (fx< iint num-int-regs)
|
||||
iint)))
|
||||
=> (lambda (new-iint)
|
||||
(let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
|
||||
[iint new-iint])
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack int-reg-offset) locs)
|
||||
(fx+ iint 2) idbl bsgl-offset (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)))]
|
||||
[(and (not varargs?)
|
||||
(< idbl num-dbl-regs))
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack float-reg-offset) locs)
|
||||
iint (fx+ idbl 1) bsgl-offset int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)]
|
||||
[else
|
||||
(let ([stack-arg-offset (align 8 stack-arg-offset)]
|
||||
[iint (if varargs? (align 2 iint) iint)]) ; use up register if argument didn't fit
|
||||
(loop (cdr types)
|
||||
(cons (load-double-stack stack-arg-offset) locs)
|
||||
iint num-dbl-regs #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))])]
|
||||
[(fp-single-float)
|
||||
(safe-assert (not varargs?))
|
||||
(if bsgl-offset
|
||||
(loop (cdr types)
|
||||
(cons (load-single-stack bsgl-offset) locs)
|
||||
iint idbl #f int-reg-offset float-reg-offset stack-arg-offset)
|
||||
(if (< idbl 8)
|
||||
(if (< idbl num-dbl-regs)
|
||||
(loop (cdr types)
|
||||
; with big-endian ARM might need to adjust offset +/- 4 since pair of
|
||||
; single floats in a pushed double float might be reversed
|
||||
|
|
@ -3057,28 +3114,30 @@
|
|||
iint (fx+ idbl 1) (fx+ float-reg-offset 4) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)
|
||||
(loop (cdr types)
|
||||
(cons (load-single-stack stack-arg-offset) locs)
|
||||
iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))]
|
||||
iint num-dbl-regs #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))]
|
||||
[(fp-ftd& ,ftd)
|
||||
(let* ([size ($ftd-size ftd)]
|
||||
[members ($ftd->members ftd)]
|
||||
[num-members (length members)])
|
||||
(cond
|
||||
[(and (fx<= num-members 4)
|
||||
[(and (not varargs?)
|
||||
(fx<= num-members 4)
|
||||
(andmap double-member? members))
|
||||
;; doubles are either in registers or all on stack
|
||||
(if (fx<= (fx+ idbl num-members) 8)
|
||||
(if (fx<= (fx+ idbl num-members) num-dbl-regs)
|
||||
(loop (cdr types)
|
||||
(cons (load-stack-address float-reg-offset) locs)
|
||||
iint (fx+ idbl num-members) #f int-reg-offset (fx+ float-reg-offset size) stack-arg-offset)
|
||||
(let ([stack-arg-offset (align 8 stack-arg-offset)])
|
||||
(loop (cdr types)
|
||||
(cons (load-stack-address stack-arg-offset) locs)
|
||||
iint 8 #f int-reg-offset #f (fx+ stack-arg-offset size))))]
|
||||
[(and (fx<= num-members 4)
|
||||
iint num-dbl-regs #f int-reg-offset #f (fx+ stack-arg-offset size))))]
|
||||
[(and (not varargs?)
|
||||
(fx<= num-members 4)
|
||||
(andmap float-member? members))
|
||||
;; floats are either in registers or all on stack
|
||||
(let ([amt (fxsrl (align 2 (fx- num-members (if bsgl-offset 1 0))) 1)])
|
||||
(if (fx<= (fx+ idbl amt) 8)
|
||||
(if (fx<= (fx+ idbl amt) num-dbl-regs)
|
||||
(let ([odd-floats? (fxodd? num-members)])
|
||||
(if bsgl-offset
|
||||
(let ([dbl-size (align 8 (fx- size 4))])
|
||||
|
|
@ -3093,15 +3152,15 @@
|
|||
(fx+ float-reg-offset dbl-size) stack-arg-offset))))
|
||||
(loop (cdr types)
|
||||
(cons (load-stack-address stack-arg-offset) locs)
|
||||
iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]
|
||||
iint num-dbl-regs #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]
|
||||
[(fx= 8 ($ftd-alignment ftd))
|
||||
(let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
|
||||
[iint (align 2 iint)]
|
||||
[amt (fxsrl size 2)])
|
||||
(if (fx< iint 4) ; argument starts in registers, may continue on stack
|
||||
(if (fx< iint num-int-regs) ; argument starts in registers, may continue on stack
|
||||
(loop (cdr types)
|
||||
(cons (load-stack-address int-reg-offset) locs)
|
||||
(fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
|
||||
(fxmin num-int-regs (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
|
||||
(fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
|
||||
(let ([stack-arg-offset (align 8 stack-arg-offset)])
|
||||
(loop (cdr types)
|
||||
|
|
@ -3110,10 +3169,10 @@
|
|||
[else
|
||||
(let* ([size (align 4 size)]
|
||||
[amt (fxsrl size 2)])
|
||||
(if (fx< iint 4) ; argument starts in registers, may continue on stack
|
||||
(if (fx< iint num-int-regs) ; argument starts in registers, may continue on stack
|
||||
(loop (cdr types)
|
||||
(cons (load-stack-address int-reg-offset) locs)
|
||||
(fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
|
||||
(fxmin num-int-regs (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
|
||||
(fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
|
||||
(loop (cdr types)
|
||||
(cons (load-stack-address stack-arg-offset) locs)
|
||||
|
|
@ -3125,7 +3184,7 @@
|
|||
[else #f])
|
||||
(let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
|
||||
[iint (align 2 iint)])
|
||||
(if (fx= iint 4)
|
||||
(if (fx= iint num-int-regs)
|
||||
(let ([stack-arg-offset (align 8 stack-arg-offset)])
|
||||
(loop (cdr types)
|
||||
(cons (load-int64-stack stack-arg-offset) locs)
|
||||
|
|
@ -3133,7 +3192,7 @@
|
|||
(loop (cdr types)
|
||||
(cons (load-int64-stack int-reg-offset) locs)
|
||||
(fx+ iint 2) idbl bsgl-offset (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)))
|
||||
(if (fx= iint 4)
|
||||
(if (fx= iint num-int-regs)
|
||||
(loop (cdr types)
|
||||
(cons (load-int-stack (car types) stack-arg-offset) locs)
|
||||
iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))
|
||||
|
|
@ -3141,13 +3200,14 @@
|
|||
(cons (load-int-stack (car types) int-reg-offset) locs)
|
||||
(fx+ iint 1) idbl bsgl-offset (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset)))]))))))
|
||||
(define do-result
|
||||
(lambda (result-type synthesize-first? return-stack-offset)
|
||||
(lambda (result-type synthesize-first? varargs? return-stack-offset)
|
||||
(nanopass-case (Ltype Type) result-type
|
||||
[(fp-ftd& ,ftd)
|
||||
(let* ([members ($ftd->members ftd)]
|
||||
[num-members (length members)])
|
||||
(cond
|
||||
[(and (fx<= 1 num-members 4)
|
||||
[(and (not varargs?)
|
||||
(fx<= 1 num-members 4)
|
||||
(or (andmap double-member? members)
|
||||
(andmap float-member? members)))
|
||||
;; double/float results returned in floating-point registers
|
||||
|
|
@ -3185,16 +3245,34 @@
|
|||
(list %Cretval)
|
||||
4)])]))]
|
||||
[(fp-double-float)
|
||||
(values (lambda (rhs)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double
|
||||
,rhs ,%zero ,(%constant flonum-data-disp)))
|
||||
'()
|
||||
(values (if varargs?
|
||||
(lambda (rhs)
|
||||
(let-values ([(endreg otherreg) (constant-case native-endianness
|
||||
[(little) (values %Cretval %r1)]
|
||||
[(big) (values %r1 %Cretval)])])
|
||||
`(seq
|
||||
(set! ,endreg ,(%mref ,rhs ,(constant flonum-data-disp)))
|
||||
(set! ,otherreg ,(%mref ,rhs ,(fx+ 4 (constant flonum-data-disp)))))))
|
||||
(lambda (rhs)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double
|
||||
,rhs ,%zero ,(%constant flonum-data-disp))))
|
||||
(if varargs?
|
||||
(list %Cretval %r1)
|
||||
'())
|
||||
0)]
|
||||
[(fp-single-float)
|
||||
(values (lambda (rhs)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single
|
||||
,rhs ,%zero ,(%constant flonum-data-disp)))
|
||||
'()
|
||||
(values (if varargs?
|
||||
(lambda (rhs)
|
||||
`(seq
|
||||
(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single
|
||||
,rhs ,%zero ,(%constant flonum-data-disp))
|
||||
(set! ,%Cretval ,(%inline fpcastto/lo ,%Cfpretval))))
|
||||
(lambda (rhs)
|
||||
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single
|
||||
,rhs ,%zero ,(%constant flonum-data-disp))))
|
||||
(if varargs?
|
||||
(list %Cretval)
|
||||
'())
|
||||
0)]
|
||||
[(fp-void)
|
||||
(values (lambda () `(nop))
|
||||
|
|
@ -3221,15 +3299,16 @@
|
|||
(define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr))
|
||||
(define isaved (length callee-save-regs+lr))
|
||||
(let* ([arg-type* (info-foreign-arg-type* info)]
|
||||
[varargs? (memq 'varargs (info-foreign-conv* info))]
|
||||
[result-type (info-foreign-result-type info)]
|
||||
[synthesize-first? (indirect-result-that-fits-in-registers? result-type)])
|
||||
(let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first?)])
|
||||
[synthesize-first? (indirect-result-that-fits-in-registers? result-type)])
|
||||
(let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first? varargs?)])
|
||||
(let ([saved-reg-bytes (fx* isaved 4)]
|
||||
[pre-pad-bytes (if (fxeven? isaved) 0 4)]
|
||||
[int-reg-bytes (fx* iint 4)]
|
||||
[post-pad-bytes (if (fxeven? iint) 0 4)]
|
||||
[float-reg-bytes (fx* idbl 8)])
|
||||
(let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first?
|
||||
(let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first? varargs?
|
||||
(fx+ saved-reg-bytes pre-pad-bytes))])
|
||||
(let ([return-bytes (align 8 return-bytes)])
|
||||
(values
|
||||
|
|
@ -3255,7 +3334,7 @@
|
|||
; list of procedures that marshal arguments from their C stack locations
|
||||
; to the Scheme argument locations
|
||||
(do-stack arg-type* saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
|
||||
synthesize-first?)
|
||||
synthesize-first? varargs?)
|
||||
get-result
|
||||
(lambda ()
|
||||
(in-context Tail
|
||||
|
|
|
|||
|
|
@ -93,6 +93,7 @@
|
|||
[(i3nt-stdcall) '__stdcall]
|
||||
[(i3nt-com) '__com]
|
||||
[(adjust-active) '__collect_safe]
|
||||
[(varargs) '__varargs]
|
||||
[else #f]))
|
||||
x*)))
|
||||
(define-who uncprep-fp-specifier
|
||||
|
|
|
|||
71
s/syntax.ss
71
s/syntax.ss
|
|
@ -8920,39 +8920,40 @@
|
|||
(define squawk
|
||||
(lambda (x)
|
||||
(syntax-error x (format "invalid ~s convention" who))))
|
||||
(let loop ([conv* conv*] [accum '()] [keep-accum '()])
|
||||
(let loop ([conv* conv*] [selected #f] [accum '()] [keep-accum '()])
|
||||
(cond
|
||||
[(null? conv*) (datum->syntax #'filter-conv keep-accum)]
|
||||
[else
|
||||
(let* ([orig-c (car conv*)]
|
||||
[c (syntax->datum orig-c)]
|
||||
[c (cond
|
||||
[(not c) #f]
|
||||
[(eq? c '__collect_safe) 'adjust-active]
|
||||
[else
|
||||
(case ($target-machine)
|
||||
[(i3nt ti3nt)
|
||||
(case c
|
||||
[(__stdcall) 'i3nt-stdcall]
|
||||
[(__cdecl) #f]
|
||||
[(__com) 'i3nt-com]
|
||||
[else (squawk orig-c)])]
|
||||
[(ppcnt)
|
||||
(case c
|
||||
[(__stdcall __cdecl) #f]
|
||||
[else (squawk orig-c)])]
|
||||
[else (squawk orig-c)])])])
|
||||
(when (member c accum)
|
||||
(syntax-error orig-c (format "redundant ~s convention" who)))
|
||||
(unless (or (null? accum)
|
||||
(eq? c 'adjust-active)
|
||||
(and (eq? 'adjust-active (car accum))
|
||||
(null? (cdr accum))))
|
||||
(syntax-error orig-c (format "conflicting ~s convention" who)))
|
||||
(loop (cdr conv*) (cons c accum)
|
||||
(if c
|
||||
(cons c keep-accum)
|
||||
keep-accum)))]))))
|
||||
[c (syntax->datum orig-c)])
|
||||
(let-values ([(c select?)
|
||||
(cond
|
||||
[(not c) (values #f #f)]
|
||||
[(eq? c '__collect_safe) (values 'adjust-active #f)]
|
||||
[(eq? c '__varargs) (values 'varargs #f)]
|
||||
[else
|
||||
(values
|
||||
(case ($target-machine)
|
||||
[(i3nt ti3nt)
|
||||
(case c
|
||||
[(__stdcall) 'i3nt-stdcall]
|
||||
[(__cdecl) #f]
|
||||
[(__com) 'i3nt-com]
|
||||
[else (squawk orig-c)])]
|
||||
[(ppcnt)
|
||||
(case c
|
||||
[(__stdcall __cdecl) #f]
|
||||
[else (squawk orig-c)])]
|
||||
[else (squawk orig-c)])
|
||||
#t)])])
|
||||
(when (member c accum)
|
||||
(syntax-error orig-c (format "redundant ~s convention" who)))
|
||||
(when (and select? selected)
|
||||
(syntax-error orig-c (format "conflicting ~s convention" who)))
|
||||
(loop (cdr conv*) (if select? c selected) (cons c accum)
|
||||
(if c
|
||||
(cons c keep-accum)
|
||||
keep-accum))))]))))
|
||||
|
||||
(define $make-foreign-procedure
|
||||
(lambda (who conv* foreign-name ?foreign-addr type* result-type)
|
||||
|
|
@ -8960,6 +8961,9 @@
|
|||
(define (check-strings-allowed)
|
||||
(when (memq 'adjust-active (syntax->datum conv*))
|
||||
($oops who "string argument not allowed with __collect_safe procedure")))
|
||||
(define (check-floats-allowed)
|
||||
(when (memq 'varargs (syntax->datum conv*))
|
||||
($oops who "float argument not allowed for __varargs procedure")))
|
||||
(with-syntax ([conv* conv*]
|
||||
[foreign-name foreign-name]
|
||||
[?foreign-addr ?foreign-addr]
|
||||
|
|
@ -9056,6 +9060,9 @@
|
|||
($fp-string->utf32 x 'big)
|
||||
(err ($moi) x)))))
|
||||
(u32*))]
|
||||
[(single-float)
|
||||
(check-floats-allowed)
|
||||
#f]
|
||||
[else #f])
|
||||
(if (or ($ftd? type) ($ftd-as-box? type))
|
||||
(let ([ftd (if ($ftd? type) type (unbox type))])
|
||||
|
|
@ -9151,6 +9158,9 @@
|
|||
(define (check-strings-allowed)
|
||||
(when (memq 'adjust-active (syntax->datum conv*))
|
||||
($oops who "string result not allowed with __collect_safe callable")))
|
||||
(define (check-floats-allowed)
|
||||
(when (memq 'varargs (syntax->datum conv*))
|
||||
($oops who "float argument not allowed for __varargs procedure")))
|
||||
(with-syntax ([conv* conv*] [?proc ?proc])
|
||||
(with-syntax ([((actual (t ...) (arg ...)) ...)
|
||||
(map
|
||||
|
|
@ -9240,6 +9250,9 @@
|
|||
#`((mod x #x100000000000000)
|
||||
(x)
|
||||
(unsigned-64)))]
|
||||
[(single-float)
|
||||
(check-floats-allowed)
|
||||
#f]
|
||||
[else #f])
|
||||
(with-syntax ([(x) (generate-temporaries #'(*))])
|
||||
#`(x (x) (#,(datum->syntax #'foreign-callable type))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user