cs: fix checking for a non-atomic argument to a foreign call

In CS, a pointer to non-atomic memory cannot usefully be passed to a
foreign function. The general foreign-call path checked for that kind
of argument and raised an exception, but the check was missing from
the common-case fast path, so a meaningless argument would be quietly
passed to the foreign function.

Related to #3825

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

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)

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)])
+                                         (unwrap-cpointer-for-foreign-call arg orig-arg proc-p)
-                                           (when (and (cpointer-nonatomic? p)
-                                                      (not (cpointer/cell? p)))
-                                             (disallow-nonatomic-pointer 'argument orig-arg proc-p))
-                                           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)
+(define (unwrap-cpointer-for-foreign-call arg orig-arg proc-p)
-  (raise-arguments-error 'foreign-call "cannot pass non-atomic pointer to a function"
+  (let ([p (unwrap-cpointer 'ffi-call arg)])
-                         "pointer" arg
+    (when (and (cpointer-nonatomic? p)
-                         "function" (or (cpointer->name proc-p)
+               (not (cpointer/cell? p)))
-                                        'unknown)))
+      (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