diff --git a/LOG b/LOG index 92e80fba6c..c04c17326c 100644 --- a/LOG +++ b/LOG @@ -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 diff --git a/csug/foreign.stex b/csug/foreign.stex index e9627d2f14..767ff03e84 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -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}} diff --git a/mats/foreign.ms b/mats/foreign.ms index 39bf4dbc7a..c20f74ef7c 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -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) diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f index 722c43cdd2..7802c33cea 100644 --- a/mats/root-experr-compile-0-f-f-f +++ b/mats/root-experr-compile-0-f-f-f @@ -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)". diff --git a/mats/root-experr-compile-2-f-f-f b/mats/root-experr-compile-2-f-f-f index 722c43cdd2..7802c33cea 100644 --- a/mats/root-experr-compile-2-f-f-f +++ b/mats/root-experr-compile-2-f-f-f @@ -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)". diff --git a/s/base-lang.ss b/s/base-lang.ss index cde6e9c23d..6f7f4bdd93 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -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)) diff --git a/s/cp0.ss b/s/cp0.ss index 90bd1542ce..9c3a761288 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -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* ...) diff --git a/s/cpcheck.ss b/s/cpcheck.ss index 18b4f3e440..1ed58cf14a 100644 --- a/s/cpcheck.ss +++ b/s/cpcheck.ss @@ -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) diff --git a/s/cpcommonize.ss b/s/cpcommonize.ss index a1fdc6a990..12f44e615f 100644 --- a/s/cpcommonize.ss +++ b/s/cpcommonize.ss @@ -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 diff --git a/s/cpletrec.ss b/s/cpletrec.ss index 1c6ff967e0..f5b2fb00c0 100644 --- a/s/cpletrec.ss +++ b/s/cpletrec.ss @@ -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)] diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index a1ce75dd55..f7d9580126 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -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 diff --git a/s/cprep.ss b/s/cprep.ss index a855069ad6..aabac1574b 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -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)] diff --git a/s/cpvalid.ss b/s/cpvalid.ss index d99d8f54c5..4602814814 100644 --- a/s/cpvalid.ss +++ b/s/cpvalid.ss @@ -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)] diff --git a/s/ftype.ss b/s/ftype.ss index 6e009c2813..0304320b1b 100644 --- a/s/ftype.ss +++ b/s/ftype.ss @@ -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)) diff --git a/s/interpret.ss b/s/interpret.ss index d258d8c237..49c7110743 100644 --- a/s/interpret.ss +++ b/s/interpret.ss @@ -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)]))) diff --git a/s/ppc32.ss b/s/ppc32.ss index 886a7c2bfe..2278b7cafe 100644 --- a/s/ppc32.ss +++ b/s/ppc32.ss @@ -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)))] diff --git a/s/syntax.ss b/s/syntax.ss index d1755b29a8..f7365944d7 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -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 diff --git a/s/x86.ss b/s/x86.ss index 5a41d039d8..386093e1b9 100644 --- a/s/x86.ss +++ b/s/x86.ss @@ -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 diff --git a/s/x86_64.ss b/s/x86_64.ss index dbe664a664..0289add3f2 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -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?)])