Improvements to __collect_safe

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

5
LOG
View File

@ -895,9 +895,10 @@
- reworked the S_call_help/S_return CCHAIN handling to fix a bug in which - 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. the signal handler could trip over the NULL jumpbuf in a CCHAIN record.
schlib.c 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 to automate thread [de]activation
syntax.ss, ftype.ss, x86.ss, x86_64.ss, ppc32.ss, 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, thread.c, prim.c, externs.h, foreign.stex, release_notes.stex,
mats/Mf-t*, foreign.ms, foreign4.c mats/Mf-t*, foreign.ms, foreign4.c

View File

@ -256,7 +256,9 @@ allowed concurrent to the foreign procedure. The
\scheme{__collect_safe} declaration allows concurrent collection by \scheme{__collect_safe} declaration allows concurrent collection by
deactivating the current thread (see \scheme{fork-thread}) when the deactivating the current thread (see \scheme{fork-thread}) when the
foreign procedure is called, and the thread is activated again when 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} \scheme{__collect_safe} foreign procedure, or use \scheme{lock-object}
to lock the memory in place; see also \scheme{Sdeactivate_thread}. The to lock the memory in place; see also \scheme{Sdeactivate_thread}. The
\scheme{__collect_safe} declaration has no effect on a non-threaded \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. \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 The types
\index{\scheme{scheme-object}}\scheme{scheme-object}, \index{\scheme{scheme-object}}\scheme{scheme-object},
\index{\scheme{string}}\scheme{string}, \index{\scheme{string}}\scheme{string},
@ -295,17 +298,28 @@ and
must be used with caution, however, since they allow allocated must be used with caution, however, since they allow allocated
Scheme objects to be used in places the Scheme memory management system 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 cannot control. No problems will arise as long as such objects are not
retained in retained in foreign variables or data structures while Scheme code is running,
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. 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} or when concurrent garbage collection is enabled.
are disallowed as argument types for a \scheme{__collect_safe} foreign procedure, since the object Other parameter types are converted to equivalent foreign
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
representations and consequently they can be retained indefinitely in representations and consequently they can be retained indefinitely in
foreign variables and data structures. 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: Following are the valid parameter types:
\foreigntype{\scheme{integer-8}} \foreigntype{\scheme{integer-8}}

View File

@ -2932,14 +2932,14 @@
(error? (foreign-procedure __collect_safe "unknown" (utf-32be) void)) (error? (foreign-procedure __collect_safe "unknown" (utf-32be) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-32le) void)) (error? (foreign-procedure __collect_safe "unknown" (utf-32le) void))
(error? (foreign-procedure __collect_safe "unknown" (string) 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-8))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-16le)) (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-16be))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-32le)) (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) () utf-32be))
(error? (foreign-callable __collect_safe (lambda () #f) () string)) (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 (begin
(define-ftype thread-callback-T (function __collect_safe (double) double)) (define-ftype thread-callback-T (function __collect_safe (double) double))
(define (call-with-thread-callback cb-proc proc) (define (call-with-thread-callback cb-proc proc)

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 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: string 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: string 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: string 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: string 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: string 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-procedure: string 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-procedure: string argument not allowed with __collect_safe procedure".
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: string 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: string 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: string 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: string 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-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)". 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)".

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 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: string 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: string 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: string 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: string 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: string 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-procedure: string 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-procedure: string argument not allowed with __collect_safe procedure".
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: string 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: string 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: string 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: string 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-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)". 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)".

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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