suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improvements to __collect_safe

Browse Source 
Improve error reporting and improve docs as suggested by Andy, and
adjust `conv` -> `conv*` to fit a naming convention.

original commit: b34817aea5d3c4862e7bb313ee9f5281472a832f
This commit is contained in:
Matthew Flatt 2018-04-20 19:02:50 -06:00
parent 9f78570343
commit 270b0a44c5
19 changed files with 177 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
LOG
View File

@ -895,9 +895,10 @@
- reworked the S_call_help/S_return CCHAIN handling to fix a bug in which
the signal handler could trip over the NULL jumpbuf in a CCHAIN record.
schlib.c
- add a __thread convention for foreign procedures and callables
- add a __collect_safe convention for foreign procedures and callables
to automate thread [de]activation
syntax.ss, ftype.ss, x86.ss, x86_64.ss, ppc32.ss,
cmacros.ss, base-lang.ss, np-languages.ss, cprep.ss
cmacros.ss, base-lang.ss, np-languages.ss, cprep.ss, cpcommonize.ss,
cp0.ss, cpcheck.ss, cpvalid.ss, interpret.ss, cpletrec.ss,
thread.c, prim.c, externs.h, foreign.stex, release_notes.stex,
mats/Mf-t*, foreign.ms, foreign4.c

36
csug/foreign.stex
View File

@ -256,7 +256,9 @@ allowed concurrent to the foreign procedure. The
\scheme{__collect_safe} declaration allows concurrent collection by
deactivating the current thread (see \scheme{fork-thread}) when the
foreign procedure is called, and the thread is activated again when
the foreign procedure returns. Refrain from passing collectable memory to a
the foreign procedure returns. The \scheme{__collect_safe} declaration
is useful, for example, when calling a blocking I/O call to allow
other Scheme threads to run normally. Refrain from passing collectable memory to a
\scheme{__collect_safe} foreign procedure, or use \scheme{lock-object}
to lock the memory in place; see also \scheme{Sdeactivate_thread}. The
\scheme{__collect_safe} declaration has no effect on a non-threaded
@ -278,7 +280,8 @@ invoke callables, then each callable should also be declared with
\scheme{__collect_safe} so that the callable reactivates the thread.
Complete type checking and conversion is performed on the parameters.
Complete type checking and conversion is performed on the parameters
to a foreign procedure.
The types
\index{\scheme{scheme-object}}\scheme{scheme-object},
\index{\scheme{string}}\scheme{string},
@ -295,17 +298,28 @@ and
must be used with caution, however, since they allow allocated
Scheme objects to be used in places the Scheme memory management system
cannot control. No problems will arise as long as such objects are not
retained in
foreign variables or data structures while Scheme code is running,
since garbage collection can occur only while Scheme code is running.
The types \scheme{string}, \scheme{wstring}, and \scheme{utf-8} through \scheme{utf-32be}
are disallowed as argument types for a \scheme{__collect_safe} foreign procedure, since the object
passed to the foreign procedure is not accessible for locking
before concurrent garbage collection is enabled.
Parameter types other than \scheme{scheme-object} through \scheme{utf-32be}
are converted to equivalent foreign
retained in foreign variables or data structures while Scheme code is running,
and as long as they are not passed as arguments to a \scheme{__collect_safe} procedure,
since garbage collection can occur only while Scheme code is running
or when concurrent garbage collection is enabled.
Other parameter types are converted to equivalent foreign
representations and consequently they can be retained indefinitely in
foreign variables and data structures.
For argument types \scheme{string}, \scheme{wstring},
\index{\scheme{utf-8}}\scheme{utf-8},
\index{\scheme{utf-16le}}\scheme{utf-16le},
\index{\scheme{utf-16be}}\scheme{utf-16be},
\index{\scheme{utf-32le}}\scheme{utf-32le}, and
\index{\scheme{utf-32be}}\scheme{utf-32be}, an argument is converted
to a fresh object that is passed to the foreign procedure. Since the
fresh object is not accessible for locking before the call, it can
never be treated correctly for a \scheme{__collect_safe} foreign
procedure, so those types are disallowed as argument types for
a \scheme{__collect_safe} foreign procedure. For analogous reasons,
those types are disallowed as the result of a \scheme{__collect_safe}
foreign callable.
Following are the valid parameter types:
\foreigntype{\scheme{integer-8}}

4
mats/foreign.ms
View File

@ -2932,14 +2932,14 @@
(error? (foreign-procedure __collect_safe "unknown" (utf-32be) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-32le) void))
(error? (foreign-procedure __collect_safe "unknown" (string) void))
;; (error? (foreign-procedure __collect_safe "unknown" (wstring) void)) <- error message varies by platform
(error? (foreign-procedure __collect_safe "unknown" (wstring) void))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-8))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-16le))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-16be))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-32le))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-32be))
(error? (foreign-callable __collect_safe (lambda () #f) () string))
;; (error? (foreign-callable __collect_safe (lambda () #f) () wstring)) <- error message varies by platform
(error? (foreign-callable __collect_safe (lambda () #f) () wstring))
(begin
(define-ftype thread-callback-T (function __collect_safe (double) double))
(define (call-with-thread-callback cb-proc proc)

26
mats/root-experr-compile-0-f-f-f
View File

@ -9484,18 +9484,20 @@ foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-8 argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-16be argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-16le argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-32be argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-32le argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-8 argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-8 result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-16le result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-16be result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-32le result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-32be result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-8 result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".

26
mats/root-experr-compile-2-f-f-f
View File

@ -9484,18 +9484,20 @@ foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-8 argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-16be argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-16le argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-32be argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-32le argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: utf-8 argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-8 result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-16le result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-16be result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-32le result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-32be result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: utf-8 result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".

4
s/base-lang.ss
View File

@ -248,8 +248,8 @@
(record-ref rtd type index e)
(record-set! rtd type index e1 e2)
(cte-optimization-loc box e)
(foreign (conv ...) name e (arg-type* ...) result-type)
(fcallable (conv ...) e (arg-type* ...) result-type)
(foreign (conv* ...) name e (arg-type* ...) result-type)
(fcallable (conv* ...) e (arg-type* ...) result-type)
(profile src) => (profile)
; used only in cpvalid
(cpvalid-defer e))

36
s/cp0.ss
View File

@ -949,13 +949,13 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))]
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
[(record-type ,rtd ,e) (memoize (pure? e))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))]
[(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (pure? e))]
[(moi) #t]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(pariah) #t]
[else ($oops who "unrecognized record ~s" e)]))))
@ -1008,13 +1008,13 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))]
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
[(record-type ,rtd ,e) (memoize (ivory? e))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))]
[(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (ivory? e))]
[(moi) #t]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(pariah) #t]
[else ($oops who "unrecognized record ~s" e)]))))
@ -1052,14 +1052,14 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple? e))]
[(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[(record-type ,rtd ,e) (memoize (simple? e))]
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))]
[(pariah) #f]
[(profile ,src) #f]
[(cte-optimization-loc ,box ,e) (memoize (simple? e))]
[(moi) #t]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[else ($oops who "unrecognized record ~s" e)]))))
(define-who simple/profile?
@ -1097,14 +1097,14 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile? e))]
[(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[(record-type ,rtd ,e) (memoize (simple/profile? e))]
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))]
[(pariah) #t]
[(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))]
[(moi) #t]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[else ($oops who "unrecognized record ~s" e)]))))
(define-who boolean-valued?
@ -1137,8 +1137,8 @@
[(profile ,src) #f]
[(set! ,maybe-src ,x ,e) #f]
[(moi) #f]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) #f]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) #f]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #f]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #f]
[(pariah) #f]
[else ($oops who "unrecognized record ~s" e)])))))
@ -2058,8 +2058,8 @@
[(set! ,maybe-src ,x0 ,e0) (list e)]
[(case-lambda ,preinfo ,cl* ...) (list e)]
[,pr (list e)]
[(foreign (,conv ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)]
[(fcallable (,conv ...) ,e0 (,arg-type* ...) ,result-type) (list e)]
[(foreign (,conv* ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)]
[(fcallable (,conv* ...) ,e0 (,arg-type* ...) ,result-type) (list e)]
[(record-type ,rtd0 ,e0) (list e)]
[(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)]
[(immutable-list (,e0* ...) ,e0) (list e)]
@ -3363,8 +3363,8 @@
(nanopass-case (Lsrc Expr) xres
[(case-lambda ,preinfo ,cl ...) #t]
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) #t]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) #t]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #t]
[(immutable-list (,e* ...) ,e) #t]
[else #f])))
@ -4609,13 +4609,13 @@
true-rec
(begin (bump sc 1) pr))]
[(app) (fold-primref pr ctxt sc wd name moi)])]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type)
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(context-case ctxt
[(value app) (bump sc 1) `(foreign (,conv ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(value app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
(context-case ctxt
[(value app) (bump sc 1) `(fcallable (,conv ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(value app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect) (cp0 e 'effect env sc wd #f moi)]
[(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])]
[(record ,rtd ,rtd-expr ,e* ...)

8
s/cpcheck.ss
View File

@ -130,11 +130,11 @@
[(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)]
[(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)]
[(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type)
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(check! ctxt (list (length arg-type*)))
`(foreign (,conv ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
[(fcallable (,conv ...) ,[e #f -> e] (,arg-type* ...) ,result-type)
`(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)]
`(foreign (,conv* ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
[(fcallable (,conv* ...) ,[e #f -> e] (,arg-type* ...) ,result-type)
`(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)]
[(call ,preinfo0
(case-lambda ,preinfo1
(clause (,x* ...) ,interface ,body)

24
s/cpcommonize.ss
View File

@ -73,10 +73,10 @@
(values `(seq ,e1 ,e2) (fx+ size1 size2))]
[(if ,[e1 size1] ,[e2 size2] ,[e3 size3])
(values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))]
[(foreign (,conv ...) ,name ,[e size] (,arg-type* ...) ,result-type)
(values `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(fcallable (,conv ...) ,[e size] (,arg-type* ...) ,result-type)
(values `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(foreign (,conv* ...) ,name ,[e size] (,arg-type* ...) ,result-type)
(values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(fcallable (,conv* ...) ,[e size] (,arg-type* ...) ,result-type)
(values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
; ($top-level-value 'x) adds just 1 to the size
[(call ,preinfo ,pr (quote ,d))
(guard (eq? (primref-name pr) '$top-level-value))
@ -379,24 +379,24 @@
(with-env x1* x2*
`(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))]
[else #f])]
[(foreign (,conv1 ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1)
[(foreign (,conv1* ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2
[(foreign (,conv2 ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2)
(and (equal? conv1 conv2)
[(foreign (,conv2* ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2)
(and (equal? conv1* conv2*)
(equal? name1 name2)
(fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2)
`(foreign (,conv1 ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
`(foreign (,conv1* ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])]
[(fcallable (,conv1 ...) ,e1 (,arg-type1* ...) ,result-type1)
[(fcallable (,conv1* ...) ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2
[(fcallable (,conv2 ...) ,e2 (,arg-type2* ...) ,result-type2)
(and (equal? conv1 conv2)
[(fcallable (,conv2* ...) ,e2 (,arg-type2* ...) ,result-type2)
(and (equal? conv1* conv2*)
(fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2)
`(fcallable (,conv1 ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
`(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])]
[(cte-optimization-loc ,box1 ,e1)
(nanopass-case (Lcommonize1 Expr) e2

8
s/cpletrec.ss
View File

@ -348,11 +348,11 @@ Handling letrec and letrec*
(with-initialized-ids x*
(lambda (x*)
(cpletrec-letrec #t x* e* body)))]
[(foreign (,conv ...) ,name ,[e pure?] (,arg-type* ...) ,result-type)
(values `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type)
[(foreign (,conv* ...) ,name ,[e pure?] (,arg-type* ...) ,result-type)
(values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))]
[(fcallable (,conv ...) ,[e pure?] (,arg-type* ...) ,result-type)
(values `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)
[(fcallable (,conv* ...) ,[e pure?] (,arg-type* ...) ,result-type)
(values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))]
[(record-ref ,rtd ,type ,index ,[e pure?])
(values `(record-ref ,rtd ,type ,index ,e) #f)]

14
s/cpnanopass.ss
View File

@ -940,11 +940,11 @@
(define-record-type info-foreign (nongenerative)
(parent info)
(sealed #t)
(fields conv arg-type* result-type (mutable name))
(fields conv* arg-type* result-type (mutable name))
(protocol
(lambda (pargs->new)
(lambda (conv arg-type* result-type)
((pargs->new) conv arg-type* result-type #f)))))
(lambda (conv* arg-type* result-type)
((pargs->new) conv* arg-type* result-type #f)))))
(define-record-type info-literal (nongenerative)
(parent info)
@ -1045,12 +1045,12 @@
[(call ,preinfo ,e ,[e*] ...)
`(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (fx< (optimize-level) 3) #f #f)
,(Expr e) ,e* ...)]
[(foreign (,conv ...) ,name ,[e] (,arg-type* ...) ,result-type)
(let ([info (make-info-foreign conv arg-type* result-type)])
[(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
(let ([info (make-info-foreign conv* arg-type* result-type)])
(info-foreign-name-set! info name)
`(foreign ,info ,e))]
[(fcallable (,conv ...) ,[e] (,arg-type* ...) ,result-type)
`(fcallable ,(make-info-foreign conv arg-type* result-type) ,e)])
[(fcallable (,conv* ...) ,[e] (,arg-type* ...) ,result-type)
`(fcallable ,(make-info-foreign conv* arg-type* result-type) ,e)])
(CaseLambdaExpr ir #f))
(define find-matching-clause

8
s/cprep.ss
View File

@ -187,12 +187,12 @@
[(letrec* ([,x* ,[e*]] ...) ,body)
`(letrec* ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*)
,@(uncprep-sequence body '()))]
[(foreign (,conv ...) ,name ,[e] (,arg-type* ...) ,result-type)
`($foreign-procedure ,(uncprep-fp-conv conv) ,name ,e
[(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
`($foreign-procedure ,(uncprep-fp-conv conv*) ,name ,e
,(map uncprep-fp-specifier arg-type*)
,(uncprep-fp-specifier result-type))]
[(fcallable (,conv ...) ,[e] (,arg-type* ...) ,result-type)
`($foreign-callable ,(uncprep-fp-conv conv) ,e
[(fcallable (,conv* ...) ,[e] (,arg-type* ...) ,result-type)
`($foreign-callable ,(uncprep-fp-conv conv*) ,e
,(map uncprep-fp-specifier arg-type*)
,(uncprep-fp-specifier result-type))]
[(record-ref ,rtd ,type ,index ,[e]) `(record-ref ,rtd ',type ,e ,index)]

16
s/cpvalid.ss
View File

@ -328,10 +328,10 @@
(let-values ([(e* vals-dl?) (undefer* e* proxy dl?)])
(defer-or-not (or body-dl? vals-dl?)
`(letrec* ([,x* ,e*] ...) ,body)))]
[(foreign (,conv ...) ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type))]
[(foreign (,conv* ...) ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[undefer : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)]
@ -547,10 +547,10 @@
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
[(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
[(foreign (,conv ...) ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type))]
[(foreign (,conv* ...) ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[cpvalid : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)]

8
s/ftype.ss
View File

@ -56,7 +56,7 @@ ftype ->
(array length ftype)
(bits (field-name signedness bits) ...)
(function (arg-type ...) result-type)
(function conv (arg-type ...) result-type)
(function conv ... (arg-type ...) result-type)
(packed ftype)
(unpacked ftype)
(endian endianness ftype)
@ -322,7 +322,7 @@ ftype operators:
(define-ftd-record-type array #{rtd/ftd-array a9pth58056u34h517jsrqv-5} length ftd)
(define-ftd-record-type pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-6} (mutable ftd))
(define-ftd-record-type bits #{rtd/ftd-ibits a9pth58056u34h517jsrqv-9} swap? field*)
(define-ftd-record-type function #{rtd/ftd-function a9pth58056u34h517jsrqv-10} conv arg-type* result-type)
(define-ftd-record-type function #{rtd/ftd-function a9pth58056u34h517jsrqv-11} conv* arg-type* result-type)
(module (pointer-size alignment pointer-alignment native-base-ftds swap-base-ftds)
(define alignment
(lambda (max-alignment size)
@ -729,7 +729,7 @@ ftype operators:
;; (foreign-callable-entry-point code-object)
[(procedure? x)
(let ([co #,($make-foreign-callable 'make-ftype-pointer
(ftd-function-conv ftd)
(ftd-function-conv* ftd)
#'x
(map indirect-ftd-pointer (ftd-function-arg-type* ftd))
(indirect-ftd-pointer (ftd-function-result-type ftd)))])
@ -1198,7 +1198,7 @@ ftype operators:
[(ftd-pointer? ftd) #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-ftd ftd))]
[(ftd-function? ftd)
($make-foreign-procedure 'make-ftype-pointer
(ftd-function-conv ftd)
(ftd-function-conv* ftd)
#f
#`($fptr-offset-addr #,fptr-expr offset)
(map indirect-ftd-pointer (ftd-function-arg-type* ftd))

8
s/interpret.ss
View File

@ -459,7 +459,7 @@
[(seq ,e1 ,e2)
(let ((e1 (ip2 e1)) (e2 (ip2 e2)))
($rt lambda () ($rt e1) ($rt e2)))]
[(foreign (,conv ...) ,name ,e (,arg-type* ...) ,result-type)
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(unless $compiler-is-loaded?
($oops 'interpret "cannot compile foreign-procedure: compiler is not loaded"))
(let ([p ($compile-backend
@ -468,11 +468,11 @@
(with-output-language (Lsrc Expr)
`(case-lambda ,(make-preinfo-lambda)
(clause (,t) 1
(foreign (,conv ...) ,name (ref #f ,t)
(foreign (,conv* ...) ,name (ref #f ,t)
(,arg-type* ...) ,result-type))))))])
(let ([e (ip2 e)])
($rt lambda () ((p) ($rt e)))))]
[(fcallable (,conv ...) ,e (,arg-type* ...) ,result-type)
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
(unless $compiler-is-loaded?
($oops 'interpret "cannot compile foreign-callable: compiler is not loaded"))
(let ([p ($compile-backend
@ -481,7 +481,7 @@
(with-output-language (Lsrc Expr)
`(case-lambda ,(make-preinfo-lambda)
(clause (,t) 1
(fcallable (,conv ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))])
(fcallable (,conv* ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))])
(let ([e (ip2 e)])
($rt lambda () ((p) ($rt e)))))]
[else (unexpected-record x)])))

4
s/ppc32.ss
View File

@ -2461,7 +2461,7 @@
(let* ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[fill-result-here? (indirect-result-that-fits-in-registers? result-type)]
[adjust-active? (memq 'adjust-active (info-foreign-conv info))])
[adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
(lambda (orig-frame-size locs live* fp-live-count)
;; NB: add 4 to frame size for CR save word
@ -3016,7 +3016,7 @@
float-reg-offset
(fx+ (fx* fp-reg-count 8) float-reg-offset))]
[synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)]
[adjust-active? (memq 'adjust-active (info-foreign-conv info))]
[adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)]
[unactivate-mode-offset (fx+ (fx* isaved 4) callee-save-offset)]
[return-space-offset (align 8 (fx+ unactivate-mode-offset (if adjust-active? 4 0)))]
[stack-size (align 16 (fx+ return-space-offset (if synthesize-first-argument? 8 0)))]

74
s/syntax.ss
View File

@ -687,16 +687,16 @@
($oops #f "invalid ~a ~a specifier ~s" who what x)))))
(define build-foreign-procedure
(lambda (ae conv foreign-name foreign-addr params result)
(lambda (ae conv* foreign-name foreign-addr params result)
(build-profile ae
`(foreign (,conv ...) ,foreign-name ,foreign-addr
`(foreign (,conv* ...) ,foreign-name ,foreign-addr
(,(map (lambda (x) (build-fp-specifier 'foreign-procedure 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-procedure "result" result #t)))))
(define build-foreign-callable
(lambda (ae conv proc params result)
(lambda (ae conv* proc params result)
(build-profile ae
`(fcallable (,conv ...) ,proc
`(fcallable (,conv* ...) ,proc
(,(map (lambda (x) (build-fp-specifier 'foreign-callable 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-callable "result" result #t))))))
@ -5991,9 +5991,9 @@
(global-extend 'core '$foreign-procedure
(lambda (e r w ae)
(syntax-case e ()
((_ conv foreign-name foreign-addr (arg ...) result)
((_ conv* foreign-name foreign-addr (arg ...) result)
(build-foreign-procedure ae
(strip (syntax conv) w)
(strip (syntax conv*) w)
(strip (syntax foreign-name) w)
(chi (syntax foreign-addr) r w)
(map (lambda (x) (strip x w)) (syntax (arg ...)))
@ -6002,9 +6002,9 @@
(global-extend 'core '$foreign-callable
(lambda (e r w ae)
(syntax-case e ()
((_ conv proc (arg ...) result)
((_ conv* proc (arg ...) result)
(build-foreign-callable ae
(strip (syntax conv) w)
(strip (syntax conv*) w)
(chi (syntax proc) r w)
(map (lambda (x) (strip x w)) (syntax (arg ...)))
(strip (syntax result) w))))))
@ -8540,15 +8540,15 @@
[else ($oops '$fp-type->pred "unrecognized type ~s" type)])])))
(define $filter-conv
(lambda (who conv)
(lambda (who conv*)
(define squawk
(lambda (x)
(syntax-error x (format "invalid ~s convention" who))))
(let loop ([conv conv] [accum '()] [keep-accum '()])
(let loop ([conv* conv*] [accum '()] [keep-accum '()])
(cond
[(null? conv) (datum->syntax #'filter-conv keep-accum)]
[(null? conv*) (datum->syntax #'filter-conv keep-accum)]
[else
(let* ([orig-c (car conv)]
(let* ([orig-c (car conv*)]
[c (syntax->datum orig-c)]
[c (cond
[(not c) #f]
@ -8573,18 +8573,18 @@
(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 (and c (if-feature pthreads #t (not (eq? c 'adjust-active))))
(loop (cdr conv*) (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)
(lambda (who conv* foreign-name ?foreign-addr type* result-type)
(let ([unsafe? (= (optimize-level) 3)])
(define (check-strings-allowed type)
(when (memq 'adjust-active (syntax->datum conv))
($oops who "~s argument not allowed with __collect_safe procedure" type)))
(with-syntax ([conv conv]
(define (check-strings-allowed)
(when (memq 'adjust-active (syntax->datum conv*))
($oops who "string argument not allowed with __collect_safe procedure")))
(with-syntax ([conv* conv*]
[foreign-name foreign-name]
[?foreign-addr ?foreign-addr]
[(t ...) (generate-temporaries type*)])
@ -8626,7 +8626,7 @@
(err ($moi) x))))
(unsigned-32))])]
[(utf-8)
(check-strings-allowed type)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8637,7 +8637,7 @@
(err ($moi) x)))))
(u8*))]
[(utf-16le)
(check-strings-allowed type)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8648,7 +8648,7 @@
(err ($moi) x)))))
(u16*))]
[(utf-16be)
(check-strings-allowed type)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8659,7 +8659,7 @@
(err ($moi) x)))))
(u16*))]
[(utf-32le)
(check-strings-allowed type)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8670,7 +8670,7 @@
(err ($moi) x)))))
(u32*))]
[(utf-32be)
(check-strings-allowed type)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8739,7 +8739,7 @@
#`[]
#`[(unless (record? &-result '#,(unbox result-type)) (err ($moi) &-result))]))]
[else #'([] [] [])])])
#`(let ([p ($foreign-procedure conv foreign-name ?foreign-addr (extra-arg ... arg ... ...) result)]
#`(let ([p ($foreign-procedure conv* foreign-name ?foreign-addr (extra-arg ... arg ... ...) result)]
#,@(if unsafe?
#'()
#'([err (lambda (who x)
@ -8766,16 +8766,16 @@
(filter-type r #'result #t)))])))
(define $make-foreign-callable
(lambda (who conv ?proc type* result-type)
(lambda (who conv* ?proc type* result-type)
(for-each (lambda (c)
(when (eq? (syntax->datum c) 'i3nt-com)
($oops who "unsupported convention ~s" c)))
(syntax->list conv))
(syntax->list conv*))
(let ([unsafe? (= (optimize-level) 3)])
(define (check-strings-allowed result-type)
(when (memq 'adjust-active (syntax->datum conv))
($oops who "~s result not allowed with __collect_safe callable" result-type)))
(with-syntax ([conv conv] [?proc ?proc])
(define (check-strings-allowed)
(when (memq 'adjust-active (syntax->datum conv*))
($oops who "string result not allowed with __collect_safe callable")))
(with-syntax ([conv* conv*] [?proc ?proc])
(with-syntax ([((actual (t ...) (arg ...)) ...)
(map
(lambda (type)
@ -8905,7 +8905,7 @@
unsigned-16
[] [])])]
[(utf-8)
(check-strings-allowed result-type)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8917,7 +8917,7 @@
u8*
[] [])]
[(utf-16le)
(check-strings-allowed result-type)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8929,7 +8929,7 @@
u16*
[] [])]
[(utf-16be)
(check-strings-allowed result-type)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8941,7 +8941,7 @@
u16*
[] [])]
[(utf-32le)
(check-strings-allowed result-type)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8953,7 +8953,7 @@
u32*
[] [])]
[(utf-32be)
(check-strings-allowed result-type)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8994,7 +8994,7 @@
[] []))])])])
; use a gensym to avoid giving the procedure a confusing name
(with-syntax ([p (datum->syntax #'foreign-callable (gensym))])
#`($foreign-callable conv
#`($foreign-callable conv*
(let ([p ?proc])
(define (err x)
($oops 'foreign-callable

18
s/x86.ss
View File

@ -2504,7 +2504,7 @@
,(save-and-restore result-regs result-fp-count `(set! ,%eax ,(%inline activate-thread))))))]
[else e]))
(define returnem
(lambda (conv orig-frame-size locs result-type ccall r-loc)
(lambda (conv* orig-frame-size locs result-type ccall r-loc)
(let ([frame-size (constant-case machine-type-name
; maintain 16-byte alignment not including the return address pushed
; by the call instruction, which counts as part of callee's frame
@ -2519,7 +2519,7 @@
r-loc
; Windows __stdcall convention requires callee to clean up
(lambda ()
(if (or (fx= frame-size 0) (memq 'i3nt-stdcall conv) (memq 'i3nt-com conv))
(if (or (fx= frame-size 0) (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*))
`(nop)
(let ([frame-size (if (callee-pops-result-pointer? result-type)
(fx- frame-size (constant ptr-bytes))
@ -2527,20 +2527,20 @@
`(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))))
(lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let ([conv (info-foreign-conv info)]
(let ([conv* (info-foreign-conv* info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(with-values (do-stack arg-type* '() 0 result-type)
(lambda (frame-size locs)
(returnem conv frame-size locs result-type
(returnem conv* frame-size locs result-type
(lambda (t0)
(let* ([fill-result-here? (fill-result-pointer-from-registers? result-type)]
[adjust-active? (memq 'adjust-active conv)]
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
[t (if adjust-active? %edx t0)] ; need a register if `adjust-active?`
[call
(add-deactivate adjust-active? fill-result-here? t0 result-type
(cond
[(memq 'i3nt-com conv)
[(memq 'i3nt-com conv*)
(when (null? arg-type*)
($oops 'foreign-procedure
"__com convention requires instance argument"))
@ -2803,8 +2803,8 @@
,e
,(pop-registers result-regs result-num-fp-regs 1)))))
(lambda (info)
(let* ([conv (info-foreign-conv info)]
[adjust-active? (memq 'adjust-active conv)]
(let* ([conv* (info-foreign-conv* info)]
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[indirect-result-space (constant-case machine-type-name
@ -2867,7 +2867,7 @@
(set! ,%ebp ,(%inline pop))
; Windows __stdcall convention requires callee to clean up
,((lambda (e)
(if (or (memq 'i3nt-stdcall conv) (memq 'i3nt-com conv))
(if (or (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*))
(let ([arg-size (fx- frame-size init-stack-offset)])
(if (fx> arg-size 0)
(%seq

8
s/x86_64.ss
View File

@ -2883,12 +2883,12 @@
`(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))
(lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let* ([conv (info-foreign-conv info)]
(let* ([conv* (info-foreign-conv* info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[result-classes (classify-type result-type)]
[fill-result-here? (result-fits-in-registers? result-classes)]
[adjust-active? (memq 'adjust-active conv)])
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp))
(lambda (frame-size nfp locs live*)
(with-values (add-save-fill-target fill-result-here? frame-size locs)
@ -3282,11 +3282,11 @@
,e
,(pop-registers result-regs)))))
(lambda (info)
(let ([conv (info-foreign-conv info)]
(let ([conv* (info-foreign-conv* info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(let* ([result-classes (classify-type result-type)]
[adjust-active? (memq 'adjust-active conv)]
[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?)])