diff --git a/pkgs/racket-doc/scribblings/foreign/types.scrbl b/pkgs/racket-doc/scribblings/foreign/types.scrbl index da71a5c0d7..424bc20d3a 100644 --- a/pkgs/racket-doc/scribblings/foreign/types.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/types.scrbl @@ -1125,6 +1125,11 @@ allocated using @racket[(malloc type-expr)] if @racket[maybe-malloc-mode] is not specified or if it is @racket[#f], @racket[(malloc type-expr '@#,racket[maybe-malloc-mode])] otherwise. +Note that in the @CS[] implementation of Racket, a @racket[(_ptr i +__ctype)] argument will trigger an error if @racket[__ctype] indicates +values that are managed by the garbage collector, since pointers to +non-atomic memory cannot be passed to foreign functions. + @history[#:changed "7.7.0.6" @elem{The modes @racket[i], @racket[o], and @racket[io] match as symbols instead of free identifiers.} @@ -1195,6 +1200,11 @@ return two values, the vector and the boolean. -> (values vec res)) ] +Note that in the @CS[] implementation of Racket, a @racket[(_list i +__ctype)] argument will trigger an error if @racket[__ctype] indicates +values that are managed by the garbage collector, since pointers to +non-atomic memory cannot be passed to foreign functions. + @history[#:changed "7.7.0.2" @elem{Added @racket[maybe-mode].}] #:changed "7.7.0.6" @elem{The modes @racket[i], @racket[o], and @racket[io] match as symbols diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index 51772ebab7..2ea119bc14 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -360,6 +360,13 @@ (with-keeper b) (set-box! b #f))) ;; --- + ;; test error reported when trying to pass non-atomic on CS + (when (eq? 'chez-scheme (system-type 'vm)) + (err/rt-test ((ffi 'grab7th (_fun (_list i _string) -> _int )) + (list "hello")) + exn:fail? + "non-atomic")) + ;; --- ;; test exposing internal mzscheme functionality (when (eq? 'racket (system-type 'vm)) (test '(1 2) diff --git a/racket/src/cs/rumble/foreign.ss b/racket/src/cs/rumble/foreign.ss index ef6948dabb..260224432f 100644 --- a/racket/src/cs/rumble/foreign.ss +++ b/racket/src/cs/rumble/foreign.ss @@ -1717,7 +1717,7 @@ [unwrap (lambda (arg in-type) (let ([c (s->c name in-type arg)]) (if (cpointer? c) - (unwrap-cpointer 'ffi-call c) + (unwrap-cpointer-for-foreign-call c arg proc-p) c)))] [unpack (lambda (arg in-type) (case (array-rep-to-pointer-rep (ctype-host-rep in-type)) @@ -1787,11 +1787,7 @@ (let ([arg (s->c name in-type orig-arg)]) (if (and (cpointer? arg) (not (eq? 'scheme-object (ctype-host-rep in-type)))) - (let ([p (unwrap-cpointer 'ffi-call arg)]) - (when (and (cpointer-nonatomic? p) - (not (cpointer/cell? p))) - (disallow-nonatomic-pointer 'argument orig-arg proc-p)) - p) + (unwrap-cpointer-for-foreign-call arg orig-arg proc-p) arg))) orig-args in-types)] [r (let ([ret-ptr (and ret-id @@ -1905,11 +1901,15 @@ (loop (cdr types) (cons id reps) (append id-decls decls))) (loop (cdr types) (cons (ctype-host-rep type) reps) decls)))]))) -(define (disallow-nonatomic-pointer what arg proc-p) - (raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function" - "pointer" arg - "function" (or (cpointer->name proc-p) - 'unknown))) +(define (unwrap-cpointer-for-foreign-call arg orig-arg proc-p) + (let ([p (unwrap-cpointer 'ffi-call arg)]) + (when (and (cpointer-nonatomic? p) + (not (cpointer/cell? p))) + (raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function" + "pointer" arg + "function" (or (cpointer->name proc-p) + 'unknown))) + p)) ;; Rely on the fact that a virtual register defaults to 0 to detect a ;; thread that we didn't start. For a thread that we did start, a