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

Change __thread to __collect_safe

Browse Source 
Also, report an error if a string type is misused as an argument (for
foreign procedures) or result (for foreign callables) with
`__collect_safe`.

original commit: cdbfa3d86cb0719bf0979b3fe0aa5c4383282b77
This commit is contained in:
Matthew Flatt 2018-03-28 09:29:47 -06:00
parent 22d4fd9978
commit 7c94235f6b
8 changed files with 115 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
csug/foreign.stex
View File

@ -213,13 +213,14 @@ Multiple procedures may be created for the same \index{foreign entry}foreign ent
\label{page:conv-description}% \label{page:conv-description}%
Each \var{conv} adjusts specifies the calling convention to be used. Each \var{conv} adjusts specifies the calling convention to be used.
A \scheme{#f} is allowed as \var{conv} to inicated the default calling convention A \scheme{#f} is allowed as \var{conv} to indicate the default calling convention
on the target machine (so the \scheme{#f} has no effect). on the target machine (so the \scheme{#f} has no effect).
Three other conventions are currently supported under Three other conventions are currently supported under
Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only). Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only).
Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is
equivalent to specifying \scheme{#f} or no convention. equivalent to specifying \scheme{#f} or no convention.
Finally, \var{conv} can be \scheme{__thread} to control thread deactivation. Finally, \var{conv} can be \scheme{__collect_safe} to indicate that garbage
collection is allowed concurrent to a call of the foreign procedure.
Use \scheme{__stdcall} to access most Windows API procedures. Use \scheme{__stdcall} to access most Windows API procedures.
Use \scheme{__cdecl} for Windows API varargs procedures, Use \scheme{__cdecl} for Windows API varargs procedures,
@ -250,29 +251,31 @@ encapsulated within the COM instance passed as the first argument,
with the second argument being a double float and the return with the second argument being a double float and the return
value being an integer. value being an integer.
Use \scheme{__thread} to make the current thread deactivated (see Use \scheme{__collect_safe} to declare that garbage collection is
\scheme{fork-thread}) while a foreign procedure is called. The allowed concurrent to the foreign procedure. The
thread is activated again when the foreign procedure returns. Deactivation \scheme{__collect_safe} declaration allows concurrent collection by
of the thread allows garbage collection to proceed in other threads, deactivating the current thread (see \scheme{fork-thread}) when the
so do not pass collectable memory to the foreign procedure, or use foreign procedure is called, and the thread is activated again when
\scheme{lock-object} to lock the memory in place; see also the foreign procedure returns. Refrain from passing collectable memory to a
\scheme{Sdeactivate_thread}. The \scheme{__thread} \scheme{__collect_safe} foreign procedure, or use \scheme{lock-object}
declaration has no effect on a non-threaded version of the system. to lock the memory in place; see also \scheme{Sdeactivate_thread}. The
\scheme{__collect_safe} declaration has no effect on a non-threaded
version of the system.
For example, calling the C \scheme{sleep} function with the default For example, calling the C \scheme{sleep} function with the default
convention will block other Scheme threads from performing a garbage convention will block other Scheme threads from performing a garbage
collection, but adding the \scheme{__thread} declaration avoids that collection, but adding the \scheme{__collect_safe} declaration avoids that
problem: problem:
\schemedisplay \schemedisplay
(define c-sleep (foreign-procedure __thread "sleep" (unsigned) unsigned)) (define c-sleep (foreign-procedure __collect_safe "sleep" (unsigned) unsigned))
(c-sleep 10) \var{; sleeps for 10 seconds without blocking other threads} (c-sleep 10) \var{; sleeps for 10 seconds without blocking other threads}
\endschemedisplay \endschemedisplay
\noindent \noindent
If a foreign procedure that is called with \scheme{__thread} can If a foreign procedure that is called with \scheme{__collect_safe} can
invoke callables, then each callable should also be declared with invoke callables, then each callable should also be declared with
\scheme{__thread} 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.
@ -291,13 +294,17 @@ and
\index{\scheme{utf-32be}}\scheme{utf-32be}, \index{\scheme{utf-32be}}\scheme{utf-32be},
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. cannot control. No problems will arise as long as such objects are not
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,
since garbage collection can occur only while Scheme code is running. since garbage collection can occur only while Scheme code is running.
All other parameter types are converted to equivalent foreign The types \scheme{string}, \scheme{wstring}, and \scheme{utf-8} through \scheme{utf-32be}
representations and consequently can be retained indefinitely in 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
representations and consequently they can be retained indefinitely in
foreign variables and data structures. foreign variables and data structures.
Following are the valid parameter types: Following are the valid parameter types:
@ -534,8 +541,9 @@ with an added null byte, and the address of the first byte of the
bytevector is passed to C. bytevector is passed to C.
The bytevector should not be retained in foreign variables or data The bytevector should not be retained in foreign variables or data
structures, since the memory management system may relocate or discard structures, since the memory management system may relocate or discard
them between foreign procedure calls, and use their storage for some them between foreign procedure calls and use their storage for some
other purpose. other purpose. The \scheme{utf-8} argument type is not allowed for a
\scheme{__collect_safe} foreign procedure.
\foreigntype{\scheme{utf-16le}} \foreigntype{\scheme{utf-16le}}
\index{\scheme{utf-16le}}Arguments of this type are treated like arguments \index{\scheme{utf-16le}}Arguments of this type are treated like arguments
@ -1029,7 +1037,7 @@ correct.
Each \var{conv} adjusts the calling convention to be used. Each \var{conv} adjusts the calling convention to be used.
\scheme{foreign-callable} supports the same conventions as \scheme{foreign-callable} supports the same conventions as
\scheme{foreign-procedure} with the exception of \scheme{__com}. \scheme{foreign-procedure} with the exception of \scheme{__com}.
The \scheme{__thread} convention for a callable activates a The \scheme{__collect_safe} convention for a callable activates a
calling thread if the thread is not already activated, and calling thread if the thread is not already activated, and
the thread's activation state is reverted when the callable the thread's activation state is reverted when the callable
returns. If a calling thread is not currently registered with returns. If a calling thread is not currently registered with
@ -1123,7 +1131,7 @@ Interfaces to these functions may be defined in Scheme as follows.
(define register-callback (define register-callback
(foreign-procedure "register_callback" (char void*) void)) (foreign-procedure "register_callback" (char void*) void))
(define event-loop (define event-loop
(foreign-procedure __thread "event_loop" () void)) (foreign-procedure __collect_safe "event_loop" () void))
\endschemedisplay \endschemedisplay
\noindent \noindent
@ -1132,7 +1140,7 @@ A callback for selected characters can then be defined.
\schemedisplay \schemedisplay
(define callback (define callback
(lambda (p) (lambda (p)
(let ([code (foreign-callable __thread p (char) void)]) (let ([code (foreign-callable __collect_safe p (char) void)])
(lock-object code) (lock-object code)
(foreign-callable-entry-point code)))) (foreign-callable-entry-point code))))
(define ouch (define ouch
@ -1166,7 +1174,7 @@ Ouch! Hit by 'e'
\endschemedisplay \endschemedisplay
\noindent \noindent
The \scheme{__thread} declarations in this example ensure that The \scheme{__collect_safe} declarations in this example ensure that
other threads can continue working while \scheme{event-loop} other threads can continue working while \scheme{event-loop}
blocks waiting for input. blocks waiting for input.
A more well-behaved version of the example would save each code object A more well-behaved version of the example would save each code object
@ -3464,7 +3472,7 @@ in the active state and need not be activated.
Any thread that has been deactivated, and any Any thread that has been deactivated, and any
thread created by some mechanism other than \scheme{fork-thread} must, thread created by some mechanism other than \scheme{fork-thread} must,
however, be activated before before it can access Scheme data or execute however, be activated before before it can access Scheme data or execute
Scheme code. A foreign callable that is declared with \scheme{__thread} Scheme code. A foreign callable that is declared with \scheme{__collect_safe}
can activate a calling thread. can activate a calling thread.
Otherwise, \scheme{Sactivate_thread} must be used to activate a thread. Otherwise, \scheme{Sactivate_thread} must be used to activate a thread.
It returns 1 the first time the thread is activated and 0 on each It returns 1 the first time the thread is activated and 0 on each
@ -3473,7 +3481,7 @@ subsequent call until the activation is destroyed with \scheme{Sdestroy_thread}.
Since active threads operating in C code prevent the storage management Since active threads operating in C code prevent the storage management
system from garbage collecting, system from garbage collecting,
a thread should be deactivated via \scheme{Sdeactivate_thread} or a thread should be deactivated via \scheme{Sdeactivate_thread} or
through a \scheme{foreign-procedure} \scheme{__thread} declaration whenever through a \scheme{foreign-procedure} \scheme{__collect_safe} declaration whenever
the thread may spend a significant amount of time in C code. the thread may spend a significant amount of time in C code.
This is especially important whenever the thread calls a C library This is especially important whenever the thread calls a C library
function, like \scheme{read}, that may block indefinitely. function, like \scheme{read}, that may block indefinitely.

40
mats/foreign.ms
View File

@ -2792,7 +2792,7 @@
(syntax-rules () (syntax-rules ()
[(_ arg ...) [(_ arg ...)
(and (check* () arg ...) (and (check* () arg ...)
(check* (__thread) arg ...))])) (check* (__collect_safe) arg ...))]))
(define-syntax check-n (define-syntax check-n
(syntax-rules () (syntax-rules ()
[(_ [ni ti vi] ...) [(_ [ni ti vi] ...)
@ -2925,9 +2925,23 @@
(check-union [x double 68.0] [y int 0]) (check-union [x double 68.0] [y int 0])
) )
(mat thread (mat collect-safe
(error? (foreign-procedure __collect_safe "unknown" (utf-8) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-16be) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-16le) 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" (string) void))
;; (error? (foreign-procedure __collect_safe "unknown" (wstring) void)) <- error message varies by platform
(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
(begin (begin
(define-ftype thread-callback-T (function __thread (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)
(let ([callback (make-ftype-pointer thread-callback-T cb-proc)]) (let ([callback (make-ftype-pointer thread-callback-T cb-proc)])
(let ([r (proc callback)]) (let ([r (proc callback)])
@ -2966,12 +2980,12 @@
(lambda (callback) (call callback arg n-times #t #t))))) (lambda (callback) (call callback arg n-times #t #t)))))
call-in-unknown-thread-1)) call-in-unknown-thread-1))
(define call-in-unknown-thread-4 (define call-in-unknown-thread-4
;; In an truly unknown thread, but also using `__thread` to ;; In an truly unknown thread, but also using `__collect_safe` to
;; deactivate the current thread instead of using `Sdeactivate_thread` ;; deactivate the current thread instead of using `Sdeactivate_thread`
;; within the foreign function: ;; within the foreign function:
(if (and (threaded?) (if (and (threaded?)
(foreign-entry? "call_in_unknown_thread")) (foreign-entry? "call_in_unknown_thread"))
(let ([call (foreign-procedure __thread "call_in_unknown_thread" (let ([call (foreign-procedure __collect_safe "call_in_unknown_thread"
((* thread-callback-T) double int boolean boolean) ((* thread-callback-T) double int boolean boolean)
double)]) double)])
(lambda (proc arg n-times) (lambda (proc arg n-times)
@ -2999,7 +3013,7 @@
n n
1)) 1))
10.5) 10.5)
;; Try to crash a `__thread` foreign-procedure call by moving the ;; Try to crash a `__collect_safe` foreign-procedure call by moving the
;; return address out from under the foreign procedure. This attempt ;; return address out from under the foreign procedure. This attempt
;; should fail, because deactivating a thread first locks the ;; should fail, because deactivating a thread first locks the
;; current code object. ;; current code object.
@ -3014,7 +3028,7 @@
(fork-thread (lambda () (fork-thread (lambda ()
(let loop ([i 10]) (let loop ([i 10])
(unless (zero? i) (unless (zero? i)
(let ([spin (eval '(foreign-procedure __thread "spin_a_while" (int unsigned unsigned) unsigned))]) (let ([spin (eval '(foreign-procedure __collect_safe "spin_a_while" (int unsigned unsigned) unsigned))])
(spin 1000000 0 1)) (spin 1000000 0 1))
(loop (sub1 i)))) (loop (sub1 i))))
(mutex-acquire m) (mutex-acquire m)
@ -3035,20 +3049,20 @@
(machine-case (machine-case
[(i3nt ti3nt) [(i3nt ti3nt)
(mat i3nt-stdcall-thread (mat i3nt-stdcall-collect-safe
(equal? (equal?
(let () (let ()
(define sum (foreign-procedure __thread __stdcall "_sum_stdcall@8" (int int) int)) (define sum (foreign-procedure __collect_safe __stdcall "_sum_stdcall@8" (int int) int))
(sum 3 7)) (sum 3 7))
10) 10)
(equal? (equal?
(let () (let ()
(define Sinvoke2 (define Sinvoke2
(foreign-procedure __thread "Sinvoke2_stdcall" (foreign-procedure __collect_safe "Sinvoke2_stdcall"
(scheme-object scheme-object iptr) (scheme-object scheme-object iptr)
scheme-object)) scheme-object))
(define Fcons (define Fcons
(foreign-callable __thread __stdcall (foreign-callable __collect_safe __stdcall
(lambda (x y) (cons x y)) (lambda (x y) (cons x y))
(scheme-object iptr) (scheme-object iptr)
scheme-object)) scheme-object))
@ -3058,6 +3072,6 @@
(eqv? (eqv?
(let () (let ()
(define com-instance ((foreign-procedure "get_com_instance" () iptr))) (define com-instance ((foreign-procedure "get_com_instance" () iptr)))
((foreign-procedure __thread __com 0 (iptr int) int) com-instance 3) ((foreign-procedure __collect_safe __com 0 (iptr int) int) com-instance 3)
((foreign-procedure __thread __com 4 (iptr int) int) com-instance 17)) ((foreign-procedure __collect_safe __com 4 (iptr int) int) com-instance 17))
37))]) 37))])

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

@ -9484,6 +9484,18 @@ 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: 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".
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)".

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

@ -9484,6 +9484,18 @@ 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: 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".
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)".

16
release_notes/release_notes.stex
View File

@ -60,14 +60,14 @@ Online versions of both books can be found at
\subsection{Foreign-procedure thread activation (9.5.1)} \subsection{Foreign-procedure thread activation (9.5.1)}
A new \scheme{__thread} foreign-procedure convention, which can be A new \scheme{__collect_safe} foreign-procedure convention, which can
combined with other conventions, causes a foreign-procedure call be combined with other conventions, causes a foreign-procedure call to
to deactive the current thread during the call. Similarly, the deactive the current thread during the call so that other threads can
\scheme{__thread} convention modifier for callables causes the perform a garbage collection. Similarly, the \scheme{__collect_safe}
current thread to be activated on entry to the callable, and the convention modifier for callables causes the current thread to be
activation state is reverted on exit from the callable; this activated on entry to the callable, and the activation state is
activation makes callables work from threads that are otherwise reverted on exit from the callable; this activation makes callables
unknown to the Scheme system. work from threads that are otherwise unknown to the Scheme system.
\subsection{Foreign-procedure struct arguments and results (9.5.1)} \subsection{Foreign-procedure struct arguments and results (9.5.1)}

2
s/cprep.ss
View File

@ -90,7 +90,7 @@
(case x (case x
[(i3nt-stdcall) '__stdcall] [(i3nt-stdcall) '__stdcall]
[(i3nt-com) '__com] [(i3nt-com) '__com]
[(adjust-active) '__thread] [(adjust-active) '__collect_safe]
[else #f])) [else #f]))
x*))) x*)))
(define-who uncprep-fp-specifier (define-who uncprep-fp-specifier

2
s/ftype.ss
View File

@ -1197,7 +1197,7 @@ ftype operators:
[(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-swap? ftd) offset)] [(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-swap? ftd) offset)]
[(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-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)

22
s/syntax.ss
View File

@ -8552,7 +8552,7 @@
[c (syntax->datum orig-c)] [c (syntax->datum orig-c)]
[c (cond [c (cond
[(not c) #f] [(not c) #f]
[(eq? c '__thread) 'adjust-active] [(eq? c '__collect_safe) 'adjust-active]
[else [else
(case ($target-machine) (case ($target-machine)
[(i3nt ti3nt) [(i3nt ti3nt)
@ -8579,8 +8579,11 @@
keep-accum)))])))) keep-accum)))]))))
(define $make-foreign-procedure (define $make-foreign-procedure
(lambda (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)
(when (memq 'adjust-active (syntax->datum conv))
($oops who "~s argument not allowed with __collect_safe procedure" type)))
(with-syntax ([conv conv] (with-syntax ([conv conv]
[foreign-name foreign-name] [foreign-name foreign-name]
[?foreign-addr ?foreign-addr] [?foreign-addr ?foreign-addr]
@ -8623,6 +8626,7 @@
(err ($moi) x)))) (err ($moi) x))))
(unsigned-32))])] (unsigned-32))])]
[(utf-8) [(utf-8)
(check-strings-allowed type)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8633,6 +8637,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u8*))] (u8*))]
[(utf-16le) [(utf-16le)
(check-strings-allowed type)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8643,6 +8648,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u16*))] (u16*))]
[(utf-16be) [(utf-16be)
(check-strings-allowed type)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8653,6 +8659,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u16*))] (u16*))]
[(utf-32le) [(utf-32le)
(check-strings-allowed type)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8663,6 +8670,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u32*))] (u32*))]
[(utf-32be) [(utf-32be)
(check-strings-allowed type)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8750,7 +8758,7 @@
(syntax-case x () (syntax-case x ()
[(_ c ... ?name (arg ...) result) [(_ c ... ?name (arg ...) result)
(lambda (r) (lambda (r)
($make-foreign-procedure ($make-foreign-procedure 'foreign-procedure
($filter-conv 'foreign-procedure #'(c ...)) ($filter-conv 'foreign-procedure #'(c ...))
(let ([x (datum ?name)]) (and (string? x) x)) (let ([x (datum ?name)]) (and (string? x) x))
#'($foreign-entry ?name) #'($foreign-entry ?name)
@ -8764,6 +8772,9 @@
($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)
(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]) (with-syntax ([conv conv] [?proc ?proc])
(with-syntax ([((actual (t ...) (arg ...)) ...) (with-syntax ([((actual (t ...) (arg ...)) ...)
(map (map
@ -8894,6 +8905,7 @@
unsigned-16 unsigned-16
[] [])])] [] [])])]
[(utf-8) [(utf-8)
(check-strings-allowed result-type)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8905,6 +8917,7 @@
u8* u8*
[] [])] [] [])]
[(utf-16le) [(utf-16le)
(check-strings-allowed result-type)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8916,6 +8929,7 @@
u16* u16*
[] [])] [] [])]
[(utf-16be) [(utf-16be)
(check-strings-allowed result-type)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8927,6 +8941,7 @@
u16* u16*
[] [])] [] [])]
[(utf-32le) [(utf-32le)
(check-strings-allowed result-type)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8938,6 +8953,7 @@
u32* u32*
[] [])] [] [])]
[(utf-32be) [(utf-32be)
(check-strings-allowed result-type)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x