cs: force all foreign callbacks to be in atomic mode

Non-atomic mode is questionable at best with BC, and more so with CS.

With BC, a thread swap at least copies the fragment of the C stack
that is between a foreign call and a callback; that can work with some
C libraries, but it goes wrong often enough that it really shouldn't
be relied on. On the plus side, if it's going to go wrong, at least it
tends to go wrong right away (i.e., something in the C frame tends to
get broken in normal runs).

With CS, the C stack is not captured as part of a thread, and so
non-atomic mode 's even more broken. Non-atomic mode could work if you
know that no other thread is running that can involve foreign calls
and callbacks, but that assumption is usually not a good one. Worse,
when things finally go wrong, it's likely several scheduling steps and
thread interleavings away from the problem (e.g., #3459).

There's a chance that this change will stop some existing programs
from working ok on CS. It's more likely to make existing programs work
as intended on CS; the common case is that atomic mode is technically
needed even though non-atomic mode happened to work in practice with
BC.

pkgs/racket-doc/scribblings/foreign/types.scrbl

@@ -705,12 +705,13 @@ For @tech{callbacks} to Racket functions with the generated type:
        @racket[keep] is based on the original function for the
        callback, not the result of @racket[wrapper].}
 
- @item{If @racket[atomic?] is true, then when a Racket procedure is
-       given this procedure type and called as a @tech{callback} from
-       foreign code, then the Racket process is put into atomic mode
-       while evaluating the Racket procedure body.
+ @item{If @racket[atomic?] is true or when using the @CS[] variant of
+       Racket, then when a Racket procedure is given this type and
+       called as a @tech{callback} from foreign code, then the Racket
+       process is put into atomic mode while evaluating the Racket
+       procedure body.
 
-        In atomic mode, other Racket threads do not run, so the Racket
+       In atomic mode, other Racket threads do not run, so the Racket
        code must not call any function that potentially blocks on
        synchronization with other threads, or else it may lead to
        deadlock. In addition, the Racket code must not perform any
@@ -718,7 +719,13 @@ For @tech{callbacks} to Racket functions with the generated type:
        an uncaught exception, it must not perform any escaping
        continuation jumps, and its non-tail recursion must be minimal
        to avoid C-level stack overflow; otherwise, the process may
-       crash or misbehave.}
+       crash or misbehave.
+
+       Callbacks are always atomic in the @CS[] variant of Racket,
+       because Racket threads do not capture C-stack context. Even on
+       the @3m[] or @CGC[] variants of Racket, atomic mode is
+       typically needed for callbacks, because capturing by copying a
+       portion of the C stack is often incompatible with C libraries.}
 
  @item{If a @racket[async-apply] is provided as a procedure or box, then a Racket
        @tech{callback} procedure with the generated procedure type can

pkgs/racket-test-core/tests/racket/foreign-test.c

@@ -290,14 +290,13 @@ void *do_f(void *_data)
   return data;
 }
 
-X void* foreign_thread_callback(test_callback_t f, 
-                                void *data,
-                                sleep_callback_t s)
+X void** foreign_thread_callback_setup(test_callback_t f,
+                                      void *data)
 {
   pthread_t th;
-  void *r, **d;
+  void **d;
 
-  d = malloc(3 * sizeof(void*));
+  d = malloc(4 * sizeof(void*));
   d[0] = f;
   d[1] = data;
   d[2] = NULL;
@@ -305,15 +304,42 @@ X void* foreign_thread_callback(test_callback_t f,
   if (pthread_create(&th, NULL, do_f, d))
     return NULL;
 
-  while (!d[2]) {
-    s();
-  }
-  
+  d[3] = (void *)th;
+
+  return d;
+}
+
+X int foreign_thread_callback_check_done(void **d)
+{
+  return d[2] != NULL;
+}
+
+X void *foreign_thread_callback_finish(void **d)
+{
+  void *r;
+  pthread_t th = (pthread_t)d[3];
+
   if (pthread_join(th, &r))
     return NULL;
 
+  free(d);
+
   return r;
 }
+
+/* only works if callbacks can be in non-atomic mode: */
+X void* foreign_thread_callback(test_callback_t f,
+                                void *data,
+                                sleep_callback_t s)
+{
+  void **d = foreign_thread_callback_setup(f, data);
+
+  while (!foreign_thread_callback_check_done(d)) {
+    s();
+  }
+
+  return foreign_thread_callback_finish(d);
+}
 #endif
 
 /* This testing function doesn't work reliably on Windows, because it sometimes

pkgs/racket-test-core/tests/racket/foreign-test.rktl

@@ -869,15 +869,36 @@
 ;; check async:
 (when test-async?
   (define (check async like)
-    (define foreign_thread_callback (get-ffi-obj 'foreign_thread_callback test-lib 
-                                                 (_fun #:blocking? #t
-                                                       (_fun #:async-apply async
-                                                             _intptr -> _intptr)
-                                                       _intptr
-                                                       (_fun #:async-apply (lambda (f) (f))
-                                                             -> _void)
-                                                       -> _intptr)))
-    (test (like 16) foreign_thread_callback (lambda (v) (add1 v)) 16 sleep))
+    (cond
+      [(eq? (system-type 'vm) 'racket)
+       (define foreign_thread_callback (get-ffi-obj 'foreign_thread_callback test-lib 
+                                                    (_fun #:blocking? #t
+                                                          (_fun #:async-apply async
+                                                                _intptr -> _intptr)
+                                                          _intptr
+                                                          (_fun #:async-apply (lambda (f) (f))
+                                                                -> _void)
+                                                          -> _intptr)))
+       (test (like 16) foreign_thread_callback (lambda (v) (add1 v)) 16 sleep)]
+      [else
+       (define foreign_thread_callback_setup (get-ffi-obj 'foreign_thread_callback_setup test-lib 
+                                                          (_fun #:blocking? #t ; doesn't do anything in this case
+                                                                (_fun #:async-apply async
+                                                                      _intptr -> _intptr)
+                                                                _intptr
+                                                                -> _pointer)))
+       (define foreign_thread_callback_check_done (get-ffi-obj 'foreign_thread_callback_check_done test-lib 
+                                                               (_fun _pointer
+                                                                     -> _bool)))
+       (define foreign_thread_callback_finish (get-ffi-obj 'foreign_thread_callback_finish test-lib 
+                                                           (_fun _pointer
+                                                                 -> _intptr)))
+       (define d (foreign_thread_callback_setup (lambda (v) (add1 v)) 16))
+       (let loop ()
+         (unless (foreign_thread_callback_check_done d)
+           (sleep)
+           (loop)))
+       (test (like 16) foreign_thread_callback_finish d)]))
   (check (lambda (f) (f)) add1)
   (check (box 20) (lambda (x) 20)))
 

racket/src/cs/README.txt

@@ -381,6 +381,9 @@ several different ways:
    cannot be usefully passed to foreign functions, since the layout is
    not actually an array of pointers.
 
+ * Callbacks are always in atomic mode (i.e., the `#:atomic?` option
+   in `_fun` and `_cprocedure` is ignored).
+
 Threads, Threads, Atomicity, Atomicity, and Atomicity
 -----------------------------------------------------
 

racket/src/cs/rumble/foreign.ss

@@ -1849,7 +1849,7 @@
                                                                    (addr->gcpointer-memory arg)]
                                                                   [else arg])]))])
                                               (cons arg (loop (cdr args) (cdr in-types))))])))))
-                              atomic?
+                              (or #t atomic?) ; force all callbacks to be atomic
                               async-apply
                               async-callback-queue)])
                       (if ret-id