ensure short callbacks get around to a garbage collection (#763)

If foreign code invaokes a short callback while also allocating (e.g.,
because it's invoking the callback in a new thread), then memory could
increase indefinitely without a garbage collection triggered. Avoid
that situation by making sure that a callback includes a trap check.
Also, detect on thread creation whether a collection is pending, and
setting the thread's trap value to minimum in that case.

Meanwhile, "foreign4.c" as part of the test suite wasn't checking
threading as intended on some platforms (such as macOS), and that's
fixed in this commit.

boot/pb/equates.h

@@ -1,4 +1,4 @@
-/* equates.h for Chez Scheme Version 9.9.9-pre-release.20 */
+/* equates.h for Chez Scheme Version 9.9.9-pre-release.21 */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -361,7 +361,7 @@ typedef uint64_t U64;
 #define machine_type_a6ob 0x25
 #define machine_type_a6osx 0x1F
 #define machine_type_a6s2 0x29
-#define machine_type_alist ((0 . any) (1 . pb) (2 . tpb) (3 . pb32l) (4 . tpb32l) (5 . pb32b) (6 . tpb32b) (7 . pb64l) (8 . tpb64l) (9 . pb64b) (10 . tpb64b) (11 . i3nt) (12 . ti3nt) (13 . i3osx) (14 . ti3osx) (15 . i3le) (16 . ti3le) (17 . i3fb) (18 . ti3fb) (19 . i3ob) (20 . ti3ob) (21 . i3nb) (22 . ti3nb) (23 . i3s2) (24 . ti3s2) (25 . i3qnx) (26 . ti3qnx) (27 . i3gnu) (28 . ti3gnu) (29 . a6nt) (30 . ta6nt) (31 . a6osx) (32 . ta6osx) (33 . a6le) (34 . ta6le) (35 . a6fb) (36 . ta6fb) (37 . a6ob) (38 . ta6ob) (39 . a6nb) (40 . ta6nb) (41 . a6s2) (42 . ta6s2) (43 . ppc32osx) (44 . tppc32osx) (45 . ppc32le) (46 . tppc32le) (47 . ppc32fb) (48 . tppc32fb) (49 . ppc32ob) (50 . tppc32ob) (51 . ppc32nb) (52 . tppc32nb) (53 . arm32le) (54 . tarm32le) (55 . arm32fb) (56 . tarm32fb) (57 . arm32ob) (58 . tarm32ob) (59 . arm32nb) (60 . tarm32nb) (61 . arm64nt) (62 . tarm64nt) (63 . arm64osx) (64 . tarm64osx) (65 . arm64le) (66 . tarm64le) (67 . arm64fb) (68 . tarm64fb) (69 . arm64ob) (70 . tarm64ob) (71 . arm64nb) (72 . tarm64nb) (73 . rv64le) (74 . trv64le) (75 . rv64fb) (76 . trv64fb) (77 . rv64ob) (78 . trv64ob) (79 . rv64nb) (80 . trv64nb))
+#define machine_type_alist ((0 . any) (1 . pb) (2 . tpb) (3 . pb32l) (4 . tpb32l) (5 . pb32b) (6 . tpb32b) (7 . pb64l) (8 . tpb64l) (9 . pb64b) (10 . tpb64b) (11 . i3nt) (12 . ti3nt) (13 . i3osx) (14 . ti3osx) (15 . i3le) (16 . ti3le) (17 . i3fb) (18 . ti3fb) (19 . i3ob) (20 . ti3ob) (21 . i3nb) (22 . ti3nb) (23 . i3s2) (24 . ti3s2) (25 . i3qnx) (26 . ti3qnx) (27 . i3gnu) (28 . ti3gnu) (29 . a6nt) (30 . ta6nt) (31 . a6osx) (32 . ta6osx) (33 . a6le) (34 . ta6le) (35 . a6fb) (36 . ta6fb) (37 . a6ob) (38 . ta6ob) (39 . a6nb) (40 . ta6nb) (41 . a6s2) (42 . ta6s2) (43 . ppc32osx) (44 . tppc32osx) (45 . ppc32le) (46 . tppc32le) (47 . ppc32fb) (48 . tppc32fb) (49 . ppc32ob) (50 . tppc32ob) (51 . ppc32nb) (52 . tppc32nb) (53 . arm32le) (54 . tarm32le) (55 . arm32fb) (56 . tarm32fb) (57 . arm32ob) (58 . tarm32ob) (59 . arm32nb) (60 . tarm32nb) (61 . arm64nt) (62 . tarm64nt) (63 . arm64osx) (64 . tarm64osx) (65 . arm64le) (66 . tarm64le) (67 . arm64fb) (68 . tarm64fb) (69 . arm64ob) (70 . tarm64ob) (71 . arm64nb) (72 . tarm64nb) (73 . rv64le) (74 . trv64le) (75 . rv64fb) (76 . trv64fb) (77 . rv64ob) (78 . trv64ob) (79 . rv64nb) (80 . trv64nb) (81 . la64le) (82 . tla64le))
 #define machine_type_any 0x0
 #define machine_type_arm32fb 0x37
 #define machine_type_arm32le 0x35
@@ -382,7 +382,8 @@ typedef uint64_t U64;
 #define machine_type_i3osx 0xD
 #define machine_type_i3qnx 0x19
 #define machine_type_i3s2 0x17
-#define machine_type_limit 0x51
+#define machine_type_la64le 0x51
+#define machine_type_limit 0x53
 #define machine_type_name pb
 #define machine_type_pb 0x1
 #define machine_type_pb32b 0x5
@@ -424,6 +425,7 @@ typedef uint64_t U64;
 #define machine_type_ti3osx 0xE
 #define machine_type_ti3qnx 0x1A
 #define machine_type_ti3s2 0x18
+#define machine_type_tla64le 0x52
 #define machine_type_tpb 0x2
 #define machine_type_tpb32b 0x6
 #define machine_type_tpb32l 0x4
@@ -1008,7 +1010,7 @@ typedef uint64_t U64;
 #define rtd_sealed 0x4
 #define sbwp (ptr)0x4E
 #define scaled_shot_1_shot_flag -0x8
-#define scheme_version 0x9090914
+#define scheme_version 0x9090915
 #define seginfo_generation_disp 0x1
 #define seginfo_list_bits_disp 0x8
 #define seginfo_space_disp 0x0
@@ -1547,7 +1549,7 @@ typedef uint64_t U64;
 #define VFASLHEADER_SINGLETONREF_COUNT(x) (*((uptr *)TO_VOIDP((uptr)(x)+104)))
 
 /* machine types */
-#define machine_type_names {"any", "pb", "tpb", "pb32l", "tpb32l", "pb32b", "tpb32b", "pb64l", "tpb64l", "pb64b", "tpb64b", "i3nt", "ti3nt", "i3osx", "ti3osx", "i3le", "ti3le", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3nb", "ti3nb", "i3s2", "ti3s2", "i3qnx", "ti3qnx", "i3gnu", "ti3gnu", "a6nt", "ta6nt", "a6osx", "ta6osx", "a6le", "ta6le", "a6fb", "ta6fb", "a6ob", "ta6ob", "a6nb", "ta6nb", "a6s2", "ta6s2", "ppc32osx", "tppc32osx", "ppc32le", "tppc32le", "ppc32fb", "tppc32fb", "ppc32ob", "tppc32ob", "ppc32nb", "tppc32nb", "arm32le", "tarm32le", "arm32fb", "tarm32fb", "arm32ob", "tarm32ob", "arm32nb", "tarm32nb", "arm64nt", "tarm64nt", "arm64osx", "tarm64osx", "arm64le", "tarm64le", "arm64fb", "tarm64fb", "arm64ob", "tarm64ob", "arm64nb", "tarm64nb", "rv64le", "trv64le", "rv64fb", "trv64fb", "rv64ob", "trv64ob", "rv64nb", "trv64nb"}
+#define machine_type_names {"any", "pb", "tpb", "pb32l", "tpb32l", "pb32b", "tpb32b", "pb64l", "tpb64l", "pb64b", "tpb64b", "i3nt", "ti3nt", "i3osx", "ti3osx", "i3le", "ti3le", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3nb", "ti3nb", "i3s2", "ti3s2", "i3qnx", "ti3qnx", "i3gnu", "ti3gnu", "a6nt", "ta6nt", "a6osx", "ta6osx", "a6le", "ta6le", "a6fb", "ta6fb", "a6ob", "ta6ob", "a6nb", "ta6nb", "a6s2", "ta6s2", "ppc32osx", "tppc32osx", "ppc32le", "tppc32le", "ppc32fb", "tppc32fb", "ppc32ob", "tppc32ob", "ppc32nb", "tppc32nb", "arm32le", "tarm32le", "arm32fb", "tarm32fb", "arm32ob", "tarm32ob", "arm32nb", "tarm32nb", "arm64nt", "tarm64nt", "arm64osx", "tarm64osx", "arm64le", "tarm64le", "arm64fb", "tarm64fb", "arm64ob", "tarm64ob", "arm64nb", "tarm64nb", "rv64le", "trv64le", "rv64fb", "trv64fb", "rv64ob", "trv64ob", "rv64nb", "trv64nb", "la64le", "tla64le"}
 
 /* allocation-space names */
 #define alloc_space_names "new", "impure", "symbol", "port", "pure", "cont", "code", "p-tobj", "ip-rec", "ip-tobj", "closure", "im-impure", "cnt-pure", "cnt-impure", "weakpr", "emph", "ref-array", "data", "im-data", "empty"

boot/pb/scheme.h

@@ -1,4 +1,4 @@
-/* scheme.h for Chez Scheme Version 9.9.9-pre-release.20 (pb) */
+/* scheme.h for Chez Scheme Version 9.9.9-pre-release.21 (pb) */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -40,7 +40,7 @@
 #endif
 
 /* Chez Scheme Version and machine type */
-#define VERSION "9.9.9-pre-release.20"
+#define VERSION "9.9.9-pre-release.21"
 #define MACHINE_TYPE "pb"
 
 /* Integer typedefs */
@@ -228,8 +228,8 @@ EXPORT const char * Skernel_version(void);
 EXPORT void Sretain_static_relocation(void);
 EXPORT void Sset_verbose(int);
 EXPORT void Sscheme_init(void (*)(void));
-EXPORT void Sregister_boot_executable_relative_file(const char *, const char *);
 EXPORT void Sregister_boot_file(const char *);
+EXPORT void Sregister_boot_executable_relative_file(const char *, const char *);
 EXPORT void Sregister_boot_relative_file(const char *);
 EXPORT void Sregister_boot_file_fd(const char *, int fd);
 EXPORT void Sregister_boot_file_fd_region(const char *, int fd, iptr offset, iptr len, int close_after);

c/thread.c

@@ -176,6 +176,10 @@ ptr S_create_thread_object(const char *who, ptr p_tc) {
 
   CP(tc) = 0;
 
+  /* if a collection is needed, then ask the new thread to check right away */
+  if (Sboolean_value(S_symbol_value(S_G.collect_request_pending_id)))
+    TRAP(tc) = (ptr)1;
+
   tc_mutex_release();
 
   return thread;

mats/foreign.ms

@@ -3521,7 +3521,7 @@
       (let* ([exception #f]
              [callback (make-ftype-pointer thread-callback-T
                          (lambda (arg)
-                           ;; Don't let an exception reset this tread.
+                           ;; Don't let an exception reset this thread.
                            (guard [c (else (set! exception c) 0.0)]
                              (cb-proc arg))))]
              [r (proc callback)])
@@ -3538,8 +3538,7 @@
          [else (loop (fx+ i 1) (proc arg))])))
     (define call-in-unknown-thread-2
       ;; Call in the current thread, but through the foreign procedure
-      (if (and (threaded?)
-               (foreign-entry? "call_in_unknown_thread"))
+      (if (threaded?)
           (let ([call (foreign-procedure "call_in_unknown_thread"
                                          ((* thread-callback-T) double int boolean boolean)
                                          double)])
@@ -3550,8 +3549,7 @@
           call-in-unknown-thread-1))
     (define call-in-unknown-thread-3
       ;; Call in a truly unknown thread:
-      (if (and (threaded?)
-               (foreign-entry? "call_in_unknown_thread"))
+      (if (threaded?)
           (let ([call (foreign-procedure "call_in_unknown_thread"
                                          ((* thread-callback-T) double int boolean boolean)
                                          double)])
@@ -3564,8 +3562,7 @@
       ;; In an truly unknown thread, but also using `__collect_safe` to
       ;; deactivate the current thread instead of using `Sdeactivate_thread`
       ;; within the foreign function:
-      (if (and (threaded?)
-               (foreign-entry? "call_in_unknown_thread"))
+      (if (threaded?)
           (let ([call (foreign-procedure __collect_safe "call_in_unknown_thread"
                                          ((* thread-callback-T) double int boolean boolean)
                                          double)])
@@ -3626,6 +3623,26 @@
               (loop))))
         (when exception (raise exception))
         ok?))
+
+  ;; make sure that lots of threads created to perform very little work
+  ;; doesn't use a huge amount of memory --- that is, that some of the
+  ;; threads trigger a GC
+  (or (not (threaded?))
+      (let ([old-max (maximum-memory-bytes)])
+        (let ([call (foreign-procedure __collect_safe
+                                       "call_in_many_unknown_threads" (uptr int int)
+                                       int)]
+              ;; manage callable pointer directly so that callback is minimal
+              [callable (foreign-callable (lambda (n) n) (int) int)])
+          (lock-object callable)
+          (and
+           (equal? 17
+                   (call (foreign-callable-entry-point callable)
+                         17
+                         10000))
+           (begin
+             (unlock-object callable)
+             (< (maximum-memory-bytes) (* 1.2 old-max)))))))
 )
 
 (machine-case

mats/foreign4.c

@@ -17,17 +17,20 @@
 #include <stdio.h>
 #include <stdlib.h>
 
-#if defined(_REENTRANT) || defined(_WIN32)
+#ifdef _WIN32
+# include <Windows.h>
+# define SCHEME_IMPORT
+#endif
+
+#include "scheme.h"
+#undef EXPORT
+
+#ifdef FEATURE_PTHREADS
 # ifdef _WIN32
-#  include <Windows.h>
-#  define SCHEME_IMPORT
-#  include "scheme.h"
 #  include <process.h>
 # else
 #  include <pthread.h>
-#  include "scheme.h"
 # endif
-# undef EXPORT
 #endif
 
 typedef signed char i8;
@@ -102,15 +105,25 @@ EXPORT void free_at_boundary(void *p)
 
 #endif
 
-#if defined(_REENTRANT) || defined(_WIN32)
+#ifdef FEATURE_PTHREADS
+
+#if defined(_WIN32)
+# define os_thread_t unsigned
+# define os_thread_create(addr, proc, arg) (((*(addr)) = _beginthread((void(*)(void*))proc, 0, arg)) == -1)
+# define os_thread_join(t) WaitForSingleObject((HANDLE)(intptr_t)(t), INFINITE)
+#else
+# define os_thread_t pthread_t
+# define os_thread_create(addr, proc, arg) pthread_create(addr, NULL, proc, proc_and_arg)
+# define os_thread_join(t) pthread_join(t, NULL)
+#endif
 
 typedef struct in_thread_args_t {
   double (*proc)(double arg);
   double arg;
   int n_times;
 } in_thread_args_t;
 
-void *in_thread(void *_proc_and_arg)
+static void *in_thread(void *_proc_and_arg)
 {
   in_thread_args_t *proc_and_arg = _proc_and_arg;
   int i;
@@ -122,18 +135,8 @@ void *in_thread(void *_proc_and_arg)
   return NULL;
 }
 
-#if defined(_WIN32)
-# define os_thread_t unsigned
-# define os_thread_create(addr, proc, arg) (((*(addr)) = _beginthread((void(*)(void*))proc, 0, arg)) == -1)
-# define os_thread_join(t) WaitForSingleObject((HANDLE)(intptr_t)(t), INFINITE)
-#else
-# define os_thread_t pthread_t
-# define os_thread_create(addr, proc, arg) pthread_create(addr, NULL, in_thread, proc_and_arg)
-# define os_thread_join(t) pthread_join(t, NULL)
-#endif
-
-#ifdef FEATURE_PTHREADS
-EXPORT double call_in_unknown_thread(double (*proc)(double arg), double arg, int n_times,
+EXPORT double call_in_unknown_thread(double (*proc)(double arg), double arg,
+                                     int n_times,
                                      int do_fork, int do_deactivate) {
   os_thread_t t;
   in_thread_args_t *proc_and_arg = malloc(sizeof(in_thread_args_t));
@@ -157,8 +160,46 @@ EXPORT double call_in_unknown_thread(double (*proc)(double arg), double arg, int
 
   return arg;
 }
+
+typedef struct in_one_thread_args_t {
+  int (*proc)(int);
+  int arg;
+} in_one_thread_args_t;
+
+static void *in_one_thread(void *_proc_and_arg)
+{
+  in_one_thread_args_t *proc_and_arg = _proc_and_arg;
+  int i;
+
+  Sactivate_thread();
+
+  proc_and_arg->arg = proc_and_arg->proc(proc_and_arg->arg);
+
+  Sdestroy_thread();
+
+  return NULL;
+}
+
+EXPORT int call_in_many_unknown_threads(int (*proc)(int), int arg,
+                                        int n_threads) {
+  os_thread_t t;
+  in_one_thread_args_t *proc_and_arg = malloc(sizeof(in_one_thread_args_t));
+
+  proc_and_arg->proc = proc;
+  proc_and_arg->arg = arg;
+
+  while (n_threads-- > 0) {
+    if (!os_thread_create(&t, in_one_thread, proc_and_arg)) {
+      os_thread_join(t);
+    }
+  }
+
+  arg = proc_and_arg->arg;
+  free(proc_and_arg);
+
+  return arg;
+}
 #endif /* FEATURE_PTHREADS */
-#endif
 
 EXPORT unsigned spin_a_while(int amt, unsigned a, unsigned b)
 {

s/cmacros.ss

@@ -357,7 +357,7 @@
 ;; ---------------------------------------------------------------------
 ;; Version and machine types:
 
-(define-constant scheme-version #x09090914)
+(define-constant scheme-version #x09090915)
 
 (define-syntax define-machine-types
   (lambda (x)

s/cpnanopass.ss

@@ -718,7 +718,7 @@
            (let ([e* (map CaseLambdaExpr e* uvar*)])
              `(letrec ([,uvar* ,e*] ...) ,(Expr body))))]
         [(call ,preinfo ,e ,[e*] ...)
-         (unless (preinfo-call? preinfo) (error 'preinfo-call "oops"))
+         (safe-assert (preinfo-call? preinfo))
          `(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (preinfo-call-check? preinfo) #f
                                  (and (preinfo-call-no-return? preinfo) (not (preinfo-call-check? preinfo))))
             ,(Expr e) ,e* ...)]
@@ -3004,6 +3004,8 @@
                    (add-trap-check overflow? call))))
            (let ([noc? (eq? (fold-left combine-seq oc oc*) 'no)])
              (cond
+               [(and (not e?) (trap-check-label? mdcl))
+                (values `(immediate ,(constant svoid)) 'no request-trap-check)]
                [(and (or tail? (and (info-call-error? info) (fx< (debug-level) 2))) noc?)
                 (let ([call `(call ,info ,mdcl ,e? ,e* ...)])
                   (if (info-call-pariah? info)

s/cpprim.ss

@@ -3821,6 +3821,8 @@
       [(e) (build-libcall #f src sexpr call1cc e)])
     (define-inline 2 $event
       [() (build-libcall #f src sexpr event)])
+    (define-inline 2 $event-trap-check
+      [() `(call ,(make-info-call src sexpr #f #f #f) ,(make-trap-check-label '$event-trap-check) #f)])
     (define-inline 3 eq-hashtable-ref
       [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-ref e1 e2 e3)])
 	(define-inline 3 eq-hashtable-ref-cell

s/np-languages.ss

@@ -74,6 +74,7 @@
     aligned-label? make-aligned-label
     return-point-label? make-return-point-label
     return-point-label-compact? return-point-label-compact?-set!
+    trap-check-label? make-trap-check-label
     Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc
     lookup-primref primref? primref-level primref-name primref-flags primref-arity
     preinfo-src preinfo-sexpr preinfo-lambda-name preinfo-lambda-flags preinfo-lambda-libspec
@@ -381,6 +382,12 @@
         (lambda (name)
           ((pargs->new name) #f)))))
 
+  (define-record-type trap-check-label
+    (parent label)
+    (nongenerative #{trap-check-label cqq98nvi9kqrjx85wecpaw2ni-0})
+    (sealed #t)
+    (fields))
+
   (module ()
     (define lookup-unique-label
       (let ([ht (make-eq-hashtable)])

s/primdata.ss

@@ -1977,6 +1977,7 @@
   ($event [flags single-valued])
   ($event-and-resume [flags])
   ($event-and-resume* [flags])
+  ($event-trap-check [flags])
   ($exactnum? [sig [(ptr) -> (boolean)]] [pred $exactnum] [flags pure unrestricted mifoldable])
   ($exactnum-imag-part [flags single-valued])
   ($exactnum-real-part [flags single-valued])

s/prims.ss

@@ -1845,6 +1845,10 @@
 
 (define $event (lambda () ($event)))
 
+;; expected to be inlined, but if not, the fact that an uninlined
+;; function is called will create a trap check
+(define $event-trap-check (lambda () (void)))
+
 (let ()
   (define (inc)
     ;; make up for decrement that will happen immediately on retry:

s/syntax.ss

@@ -9519,7 +9519,9 @@
                       "invalid return value ~s from ~s"
                       x p))
                   #,@(if unsafe? #'() #'((unless (procedure? p) ($oops 'foreign-callable "~s is not a procedure" p))))
-                  (lambda (extra ... t ... ...) (result-filter (p extra ... actual ...))))
+                  (lambda (extra ... t ... ...)
+                    ($event-trap-check) ; ensure eventual `($event)` in the case of many short callbacks
+                    (result-filter (p extra ... actual ...))))
                 (extra-arg ... arg ... ...)
                 result)))))))