fix another way that `racket/gui' instances can leak

collects/ffi/unsafe.rkt

@@ -1592,11 +1592,25 @@
     ;; are run after non-late weak boxes are cleared).
     (lambda (obj finalizer)
       (unless killer-thread
-        (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)])
+        ;; We need to make a thread that runs in a privildged custodian and
+        ;; that doesn't retain the current namespace --- either directly
+        ;; or indirectly through some parameter setting in the current thread.
+        (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)]
+              [no-cells ((get-ffi-obj 'scheme_empty_cell_table #f (_fun -> _gcpointer)))]
+              [min-config ((get-ffi-obj 'scheme_minimal_config #f (_fun -> _gcpointer)))]
+              [thread/details (get-ffi-obj 'scheme_thread_w_details #f (_fun _scheme 
+                                                                             _gcpointer ; config
+                                                                             _gcpointer ; cells
+                                                                             _pointer ; break_cell
+                                                                             _scheme ; custodian
+                                                                             _int ; suspend-to-kill?
+                                                                             -> _scheme))])
           (set! killer-thread
-                (parameterize ([current-custodian priviledged-custodian]
+                (thread/details (lambda ()
-                               ;; don't hold onto the namespace in the finalizer thread:
+                                  (let loop () (will-execute killer-executor) (loop)))
-                               [current-namespace (make-base-empty-namespace)])
+                                min-config
-                  (thread (lambda ()
+                                no-cells
-                            (let loop () (will-execute killer-executor) (loop))))))))
+                                #f ; default break cell
+                                priviledged-custodian
+                                0))))
       (will-register killer-executor obj finalizer))))

collects/tests/gracket/draw-mem.rkt

@@ -2,17 +2,22 @@
 
 ;; Check for a leak via multiple `racket/draw' instantiations.
 
-(define-values (incs m)
+(define my-ns-channel (make-parameter #f))
-  (for/fold ([incs 0] [prev-mem 0]) ([i 10])
+
-    (parameterize ([current-namespace (make-base-namespace)])
+(define-values (incs m ns)
+  (for/fold ([incs 0] [max-mem 0] [ns #f]) ([i 10])
+    (define ns (make-base-namespace))
+    (parameterize ([current-namespace ns]
+                   [my-ns-channel ns])
       (dynamic-require 'racket/draw #f))
     (collect-garbage)
     (sync (system-idle-evt))
     (collect-garbage)
     (let ([m (current-memory-use)])
-      (if (m . > . (+ prev-mem (* 100 1024)))
+      (printf "~s\n" m)
-          (values (add1 incs) m)
+      (if (m . > . max-mem)
-          (values incs m)))))
+          (values (add1 incs) m 'ns)
+          (values incs max-mem 'ns)))))
 
 (unless (incs . < . 5)
   (error "multiple `racket/draw' instantiations seem to accumulate memory"))

src/racket/include/mzwin.def

@@ -8,6 +8,7 @@ EXPORTS
  scheme_clear_escape
  scheme_new_jmpupbuf_holder
  scheme_current_config
+ scheme_minimal_config
  scheme_extend_config
  scheme_install_config
  scheme_get_param
@@ -15,6 +16,7 @@ EXPORTS
  scheme_get_thread_param
  scheme_set_thread_param
  scheme_get_env
+ scheme_empty_cell_table
  scheme_inherit_cells
  scheme_current_break_cell
  scheme_current_thread DATA
@@ -491,6 +493,7 @@ EXPORTS
  scheme_get_port_fd
  scheme_get_port_socket
  scheme_socket_to_ports
+ scheme_fd_to_semaphore
  scheme_set_type_printer
  scheme_print_bytes
  scheme_print_utf8

src/racket/include/mzwin3m.def

@@ -8,6 +8,7 @@ EXPORTS
  scheme_clear_escape
  scheme_new_jmpupbuf_holder
  scheme_current_config
+ scheme_minimal_config
  scheme_extend_config
  scheme_install_config
  scheme_get_param
@@ -15,6 +16,7 @@ EXPORTS
  scheme_get_thread_param
  scheme_set_thread_param
  scheme_get_env
+ scheme_empty_cell_table
  scheme_inherit_cells
  scheme_current_break_cell
  scheme_current_thread DATA
@@ -506,6 +508,7 @@ EXPORTS
  scheme_get_port_fd
  scheme_get_port_socket
  scheme_socket_to_ports
+ scheme_fd_to_semaphore
  scheme_set_type_printer
  scheme_print_bytes
  scheme_print_utf8

src/racket/include/racket.exp

@@ -6,6 +6,7 @@ scheme_reset_jmpup_buf
 scheme_clear_escape
 scheme_new_jmpupbuf_holder
 scheme_current_config
+scheme_minimal_config
 scheme_extend_config
 scheme_install_config
 scheme_get_param
@@ -13,6 +14,7 @@ scheme_set_param
 scheme_get_thread_param
 scheme_set_thread_param
 scheme_get_env
+scheme_empty_cell_table
 scheme_inherit_cells
 scheme_current_break_cell
 scheme_current_thread
@@ -508,6 +510,7 @@ scheme_get_port_file_descriptor
 scheme_get_port_fd
 scheme_get_port_socket
 scheme_socket_to_ports
+scheme_fd_to_semaphore
 scheme_set_type_printer
 scheme_print_bytes
 scheme_print_utf8

src/racket/include/racket3m.exp

@@ -6,6 +6,7 @@ scheme_reset_jmpup_buf
 scheme_clear_escape
 scheme_new_jmpupbuf_holder
 scheme_current_config
+scheme_minimal_config
 scheme_extend_config
 scheme_install_config
 scheme_get_param
@@ -13,6 +14,7 @@ scheme_set_param
 scheme_get_thread_param
 scheme_set_thread_param
 scheme_get_env
+scheme_empty_cell_table
 scheme_inherit_cells
 scheme_current_break_cell
 scheme_current_thread
@@ -514,6 +516,7 @@ scheme_get_port_file_descriptor
 scheme_get_port_fd
 scheme_get_port_socket
 scheme_socket_to_ports
+scheme_fd_to_semaphore
 scheme_set_type_printer
 scheme_print_bytes
 scheme_print_utf8

src/racket/include/schthread.h

@@ -250,6 +250,7 @@ typedef struct Thread_Local_Variables {
   struct Scheme_Custodian *main_custodian_;
   struct Scheme_Custodian *last_custodian_;
   struct Scheme_Hash_Table *limited_custodians_;
+  struct Scheme_Config *initial_config_;
   struct Scheme_Thread *swap_target_;
   struct Scheme_Object *scheduled_kills_;
   int do_atomic_;
@@ -598,6 +599,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL;
 #define main_custodian XOA (scheme_get_thread_local_variables()->main_custodian_)
 #define last_custodian XOA (scheme_get_thread_local_variables()->last_custodian_)
 #define limited_custodians XOA (scheme_get_thread_local_variables()->limited_custodians_)
+#define initial_config XOA (scheme_get_thread_local_variables()->initial_config_)
 #define swap_target XOA (scheme_get_thread_local_variables()->swap_target_)
 #define scheduled_kills XOA (scheme_get_thread_local_variables()->scheduled_kills_)
 #define do_atomic XOA (scheme_get_thread_local_variables()->do_atomic_)

src/racket/src/schemef.h

@@ -55,6 +55,7 @@ MZ_EXTERN Scheme_Jumpup_Buf_Holder *scheme_new_jmpupbuf_holder(void);
 /*========================================================================*/
 
 MZ_EXTERN Scheme_Config *scheme_current_config(void);
+MZ_EXTERN Scheme_Config *scheme_minimal_config(void);
 MZ_EXTERN Scheme_Config *scheme_extend_config(Scheme_Config *c, int pos, Scheme_Object *init_val);
 MZ_EXTERN void scheme_install_config(Scheme_Config *);
 
@@ -66,6 +67,7 @@ MZ_EXTERN void scheme_set_thread_param(Scheme_Config *c, Scheme_Thread_Cell_Tabl
 
 MZ_EXTERN Scheme_Env *scheme_get_env(Scheme_Config *config);
 
+MZ_EXTERN Scheme_Thread_Cell_Table *scheme_empty_cell_table();
 MZ_EXTERN Scheme_Thread_Cell_Table *scheme_inherit_cells(Scheme_Thread_Cell_Table *cells);
 
 MZ_EXTERN Scheme_Object *scheme_current_break_cell();

src/racket/src/schemex.h

@@ -31,6 +31,7 @@ Scheme_Jumpup_Buf_Holder *(*scheme_new_jmpupbuf_holder)(void);
 /*                                parameters                              */
 /*========================================================================*/
 Scheme_Config *(*scheme_current_config)(void);
+Scheme_Config *(*scheme_minimal_config)(void);
 Scheme_Config *(*scheme_extend_config)(Scheme_Config *c, int pos, Scheme_Object *init_val);
 void (*scheme_install_config)(Scheme_Config *);
 Scheme_Object *(*scheme_get_param)(Scheme_Config *c, int pos);
@@ -38,6 +39,7 @@ void (*scheme_set_param)(Scheme_Config *c, int pos, Scheme_Object *o);
 Scheme_Object *(*scheme_get_thread_param)(Scheme_Config *c, Scheme_Thread_Cell_Table *cells, int pos);
 void (*scheme_set_thread_param)(Scheme_Config *c, Scheme_Thread_Cell_Table *cells, int pos, Scheme_Object *o);
 Scheme_Env *(*scheme_get_env)(Scheme_Config *config);
+Scheme_Thread_Cell_Table *(*scheme_empty_cell_table)();
 Scheme_Thread_Cell_Table *(*scheme_inherit_cells)(Scheme_Thread_Cell_Table *cells);
 Scheme_Object *(*scheme_current_break_cell)();
 /*========================================================================*/

src/racket/src/schemex.inc

@@ -9,6 +9,7 @@
   scheme_extension_table->scheme_clear_escape = scheme_clear_escape;
   scheme_extension_table->scheme_new_jmpupbuf_holder = scheme_new_jmpupbuf_holder;
   scheme_extension_table->scheme_current_config = scheme_current_config;
+  scheme_extension_table->scheme_minimal_config = scheme_minimal_config;
   scheme_extension_table->scheme_extend_config = scheme_extend_config;
   scheme_extension_table->scheme_install_config = scheme_install_config;
   scheme_extension_table->scheme_get_param = scheme_get_param;
@@ -16,6 +17,7 @@
   scheme_extension_table->scheme_get_thread_param = scheme_get_thread_param;
   scheme_extension_table->scheme_set_thread_param = scheme_set_thread_param;
   scheme_extension_table->scheme_get_env = scheme_get_env;
+  scheme_extension_table->scheme_empty_cell_table = scheme_empty_cell_table;
   scheme_extension_table->scheme_inherit_cells = scheme_inherit_cells;
   scheme_extension_table->scheme_current_break_cell = scheme_current_break_cell;
 #ifndef USE_THREAD_LOCAL
@@ -560,6 +562,7 @@
   scheme_extension_table->scheme_get_port_fd = scheme_get_port_fd;
   scheme_extension_table->scheme_get_port_socket = scheme_get_port_socket;
   scheme_extension_table->scheme_socket_to_ports = scheme_socket_to_ports;
+  scheme_extension_table->scheme_fd_to_semaphore = scheme_fd_to_semaphore;
   scheme_extension_table->scheme_set_type_printer = scheme_set_type_printer;
   scheme_extension_table->scheme_print_bytes = scheme_print_bytes;
   scheme_extension_table->scheme_print_utf8 = scheme_print_utf8;

src/racket/src/schemexm.h

@@ -9,6 +9,7 @@
 #define scheme_clear_escape (scheme_extension_table->scheme_clear_escape)
 #define scheme_new_jmpupbuf_holder (scheme_extension_table->scheme_new_jmpupbuf_holder)
 #define scheme_current_config (scheme_extension_table->scheme_current_config)
+#define scheme_minimal_config (scheme_extension_table->scheme_minimal_config)
 #define scheme_extend_config (scheme_extension_table->scheme_extend_config)
 #define scheme_install_config (scheme_extension_table->scheme_install_config)
 #define scheme_get_param (scheme_extension_table->scheme_get_param)
@@ -16,6 +17,7 @@
 #define scheme_get_thread_param (scheme_extension_table->scheme_get_thread_param)
 #define scheme_set_thread_param (scheme_extension_table->scheme_set_thread_param)
 #define scheme_get_env (scheme_extension_table->scheme_get_env)
+#define scheme_empty_cell_table (scheme_extension_table->scheme_empty_cell_table)
 #define scheme_inherit_cells (scheme_extension_table->scheme_inherit_cells)
 #define scheme_current_break_cell (scheme_extension_table->scheme_current_break_cell)
 #ifndef USE_THREAD_LOCAL
@@ -560,6 +562,7 @@
 #define scheme_get_port_fd (scheme_extension_table->scheme_get_port_fd)
 #define scheme_get_port_socket (scheme_extension_table->scheme_get_port_socket)
 #define scheme_socket_to_ports (scheme_extension_table->scheme_socket_to_ports)
+#define scheme_fd_to_semaphore (scheme_extension_table->scheme_fd_to_semaphore)
 #define scheme_set_type_printer (scheme_extension_table->scheme_set_type_printer)
 #define scheme_print_bytes (scheme_extension_table->scheme_print_bytes)
 #define scheme_print_utf8 (scheme_extension_table->scheme_print_utf8)

src/racket/src/thread.c

@@ -581,6 +581,7 @@ void scheme_init_thread_places(void) {
   REGISTER_SO(gc_prepost_callback_descs);
   REGISTER_SO(place_local_misc_table);
   REGISTER_SO(gc_info_prefab);
+  REGISTER_SO(initial_config);
   gc_info_prefab = scheme_lookup_prefab_type(scheme_intern_symbol("gc-info"), 10);
 }
 
@@ -6622,6 +6623,11 @@ void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells
   scheme_add_to_table(cells, (const char *)cell, (void *)v, 0);
 }
 
+Scheme_Thread_Cell_Table *scheme_empty_cell_table(void)
+{
+  return scheme_make_bucket_table(20, SCHEME_hash_weak_ptr);
+}
+
 static Scheme_Thread_Cell_Table *inherit_cells(Scheme_Thread_Cell_Table *cells,
 					       Scheme_Thread_Cell_Table *t,
 					       int inherited)
@@ -6634,7 +6640,7 @@ static Scheme_Thread_Cell_Table *inherit_cells(Scheme_Thread_Cell_Table *cells,
     cells = scheme_current_thread->cell_values;
   
   if (!t)
-    t = scheme_make_bucket_table(20, SCHEME_hash_weak_ptr);
+    t = scheme_empty_cell_table();
   
   for (i = cells->size; i--; ) {
     bucket = cells->buckets[i];
@@ -7275,6 +7281,13 @@ static void make_initial_config(Scheme_Thread *p)
 	init_param(cells, paramz, i, scheme_false);      
     }
   }
+
+  initial_config = config;
+}
+
+Scheme_Config *scheme_minimal_config(void)
+{
+  return initial_config;
 }
 
 void scheme_set_startup_load_on_demand(int on)