fix custodian of tcp-accept-evt

svn: r15335

collects/tests/mzscheme/file.ss

@@ -1287,6 +1287,26 @@
 
 (arity-test tcp-port? 1 1)
 
+;; Check that `tcp-accept-evt' uses the right custodian
+(let ()
+  (define l (tcp-listen 40000 5 #t))
+  (define c (make-custodian))
+  
+  (define-values (i o) (values #f #f))
+  
+  (define t
+    (thread
+     (lambda ()
+       (parameterize ([current-custodian c])
+         (set!-values (i o) (apply values (sync (tcp-accept-evt l))))))))
+  
+  (define-values (ci co) (tcp-connect "localhost" 40000))
+  
+  (sync t)
+  
+  (custodian-shutdown-all c)
+  (port-closed? i))
+
 ;;----------------------------------------------------------------------
 ;; UDP
 

src/mzscheme/include/mzscheme.exp

@@ -57,6 +57,7 @@ scheme_tls_get
 scheme_make_custodian
 scheme_add_managed
 scheme_custodian_check_available
+scheme_custodian_is_available
 scheme_remove_managed
 scheme_close_managed
 scheme_schedule_custodian_close
@@ -407,6 +408,7 @@ scheme_is_output_port
 scheme_make_port_type
 scheme_make_input_port
 scheme_make_output_port
+scheme_set_next_port_custodian
 scheme_set_port_location_fun
 scheme_set_port_count_lines_fun
 scheme_progress_evt_via_get

src/mzscheme/include/mzscheme3m.exp

@@ -57,6 +57,7 @@ scheme_tls_get
 scheme_make_custodian
 scheme_add_managed
 scheme_custodian_check_available
+scheme_custodian_is_available
 scheme_remove_managed
 scheme_close_managed
 scheme_schedule_custodian_close
@@ -418,6 +419,7 @@ scheme_is_output_port
 scheme_make_port_type
 scheme_make_input_port
 scheme_make_output_port
+scheme_set_next_port_custodian
 scheme_set_port_location_fun
 scheme_set_port_count_lines_fun
 scheme_progress_evt_via_get

src/mzscheme/include/mzwin.def

@@ -59,6 +59,7 @@ EXPORTS
  scheme_make_custodian
  scheme_add_managed
  scheme_custodian_check_available
+ scheme_custodian_is_available
  scheme_remove_managed
  scheme_close_managed
  scheme_schedule_custodian_close
@@ -395,6 +396,7 @@ EXPORTS
  scheme_make_port_type
  scheme_make_input_port
  scheme_make_output_port
+ scheme_set_next_port_custodian
  scheme_set_port_location_fun
  scheme_set_port_count_lines_fun
  scheme_progress_evt_via_get

src/mzscheme/include/mzwin3m.def

@@ -59,6 +59,7 @@ EXPORTS
  scheme_make_custodian
  scheme_add_managed
  scheme_custodian_check_available
+ scheme_custodian_is_available
  scheme_remove_managed
  scheme_close_managed
  scheme_schedule_custodian_close
@@ -410,6 +411,7 @@ EXPORTS
  scheme_make_port_type
  scheme_make_input_port
  scheme_make_output_port
+ scheme_set_next_port_custodian
  scheme_set_port_location_fun
  scheme_set_port_count_lines_fun
  scheme_progress_evt_via_get

src/mzscheme/src/network.c

@@ -1576,10 +1576,13 @@ tcp_out_buffer_mode(Scheme_Port *p, int mode)
 }
 
 static Scheme_Object *
-make_tcp_input_port(void *data, const char *name)
+make_tcp_input_port(void *data, const char *name, Scheme_Object *cust)
 {
   Scheme_Input_Port *ip;
 
+  if (cust)
+    scheme_set_next_port_custodian((Scheme_Custodian *)cust);
+  
   ip = scheme_make_input_port(scheme_tcp_input_port_type,
 			      data,
 			      scheme_intern_symbol(name),
@@ -1598,10 +1601,13 @@ make_tcp_input_port(void *data, const char *name)
 }
 
 static Scheme_Object *
-make_tcp_output_port(void *data, const char *name)
+make_tcp_output_port(void *data, const char *name, Scheme_Object *cust)
 {
   Scheme_Output_Port *op;
 
+  if (cust)
+    scheme_set_next_port_custodian((Scheme_Custodian *)cust);
+
   op = scheme_make_output_port(scheme_tcp_output_port_type,
 						  data,
 						  scheme_intern_symbol(name),
@@ -1805,8 +1811,8 @@ static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[])
 
 	      tcp = make_tcp_port_data(s, 2);
 	      
-	      v[0] = make_tcp_input_port(tcp, address);
+	      v[0] = make_tcp_input_port(tcp, address, NULL);
-	      v[1] = make_tcp_output_port(tcp, address);
+	      v[1] = make_tcp_output_port(tcp, address, NULL);
 	      
 	      REGISTER_SOCKET(s);
 
@@ -2175,7 +2181,8 @@ tcp_accept_ready(int argc, Scheme_Object *argv[])
 }
 
 static Scheme_Object *
-tcp_accept(int argc, Scheme_Object *argv[])
+do_tcp_accept(int argc, Scheme_Object *argv[], Scheme_Object *cust, char **_fail_reason)
+/* If _fail_reason is not NULL, never raise an exception. */
 {
 #ifdef USE_TCP
   int was_closed = 0, errid, ready_pos;
@@ -2206,12 +2213,22 @@ tcp_accept(int argc, Scheme_Object *argv[])
     ready_pos = 0;
 
   if (was_closed) {
+    if (_fail_reason)
+      *_fail_reason = "tcp-accept-evt: listener is closed";
+    else
       scheme_raise_exn(MZEXN_FAIL_NETWORK,
                        "tcp-accept: listener is closed");
     return NULL;
   }
 
-  scheme_custodian_check_available(NULL, "tcp-accept", "network");
+  if (!_fail_reason)
+    scheme_custodian_check_available((Scheme_Custodian *)cust, "tcp-accept", "network");
+  else {
+    if (!scheme_custodian_is_available((Scheme_Custodian *)cust)) {
+      *_fail_reason = "tcp-accept-evt: custodian is shutdown";
+      return NULL;
+    }
+  }
   
 # ifdef USE_SOCKETS_TCP
   ls = ((listener_t *)listener)->s[ready_pos-1];
@@ -2235,8 +2252,8 @@ tcp_accept(int argc, Scheme_Object *argv[])
 
     tcp = make_tcp_port_data(s, 2);
 
-    v[0] = make_tcp_input_port(tcp, "tcp-accepted");
+    v[0] = make_tcp_input_port(tcp, "tcp-accepted", cust);
-    v[1] = make_tcp_output_port(tcp, "tcp-accepted");
+    v[1] = make_tcp_output_port(tcp, "tcp-accepted", cust);
 
     scheme_file_open_count++;
     REGISTER_SOCKET(s);
@@ -2246,6 +2263,9 @@ tcp_accept(int argc, Scheme_Object *argv[])
   errid = SOCK_ERRNO();
 # endif
   
+  if (_fail_reason)
+    *_fail_reason = "tcp-accept-evt: accept from listener failed";
+  else
     scheme_raise_exn(MZEXN_FAIL_NETWORK,
                      "tcp-accept: accept from listener failed (%E)", errid);
 #else
@@ -2255,6 +2275,12 @@ tcp_accept(int argc, Scheme_Object *argv[])
   return NULL;
 }
 
+static Scheme_Object *
+tcp_accept(int argc, Scheme_Object *argv[])
+{
+  return do_tcp_accept(argc, argv, NULL, NULL);
+}
+
 static Scheme_Object *
 tcp_accept_break(int argc, Scheme_Object *argv[])
 {
@@ -2460,35 +2486,54 @@ static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *tcp_accept_evt(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *r;
+  Scheme_Object *r, *custodian;
 
   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
     scheme_wrong_type("tcp-accept-evt", "tcp-listener", 0, argc, argv);
 
-  r = scheme_alloc_small_object();
+  custodian = scheme_get_param(scheme_current_config(), MZCONFIG_CUSTODIAN);
+
+  scheme_custodian_check_available((Scheme_Custodian *)custodian, "tcp-accept", "network");
+  
+  r = scheme_alloc_object();
   r->type = scheme_tcp_accept_evt_type;
-  SCHEME_PTR_VAL(r) = argv[0];
+  SCHEME_PTR1_VAL(r) = argv[0];
+  SCHEME_PTR2_VAL(r) = custodian;
 
   return r;
 }
 
+static Scheme_Object *accept_failed(void *msg, int argc, Scheme_Object **argv)
+{
+  scheme_raise_exn(MZEXN_FAIL_NETWORK, msg ? (const char *)msg : "accept failed");
+  return NULL;
+} 
+
 static int tcp_check_accept_evt(Scheme_Object *ae, Scheme_Schedule_Info *sinfo)
 {
-  if (tcp_check_accept(SCHEME_PTR_VAL(ae))) {
+  if (tcp_check_accept(SCHEME_PTR1_VAL(ae))) {
     Scheme_Object *a[2];
-    a[0] = SCHEME_PTR_VAL(ae);
+    char *fail_reason = NULL;
-    tcp_accept(1, a);
+    a[0] = SCHEME_PTR1_VAL(ae);
+    if (do_tcp_accept(1, a, SCHEME_PTR2_VAL(ae), &fail_reason)) {
       a[0] = scheme_current_thread->ku.multiple.array[0];
       a[1] = scheme_current_thread->ku.multiple.array[1];
       scheme_set_sync_target(sinfo, scheme_build_list(2, a), NULL, NULL, 0, 0, NULL);
       return 1;
+    } else {
+      /* error on accept */
+      scheme_set_sync_target(sinfo, scheme_always_ready_evt, 
+                             scheme_make_closed_prim(accept_failed, fail_reason), 
+                             NULL, 0, 0, NULL);
+      return 1;
+    }
   } else
     return 0;
 }
 
 static void tcp_accept_evt_needs_wakeup(Scheme_Object *ae, void *fds)
 {
-  tcp_accept_needs_wakeup(SCHEME_PTR_VAL(ae), fds);
+  tcp_accept_needs_wakeup(SCHEME_PTR1_VAL(ae), fds);
 }
 
 int scheme_get_port_socket(Scheme_Object *p, long *_s)
@@ -2533,9 +2578,9 @@ void scheme_socket_to_ports(long s, const char *name, int takeover,
 
   tcp = make_tcp_port_data(s, takeover ? 2 : 3);
 
-  v = make_tcp_input_port(tcp, name);
+  v = make_tcp_input_port(tcp, name, NULL);
   *_inp = v;
-  v = make_tcp_output_port(tcp, name);
+  v = make_tcp_output_port(tcp, name, NULL);
   *_outp = v;
   
   if (takeover) {

src/mzscheme/src/port.c

@@ -347,6 +347,8 @@ int scheme_force_port_closed;
 static int flush_out;
 static int flush_err;
 
+static THREAD_LOCAL Scheme_Custodian *new_port_cust; /* back-door argument */
+
 #if defined(FILES_HAVE_FDS)
 static int external_event_fd, put_external_event_fd;
 #endif
@@ -1276,6 +1278,11 @@ static void init_port_locations(Scheme_Port *ip)
   ip->count_lines = cl;
 }
 
+void scheme_set_next_port_custodian(Scheme_Custodian *c)
+{
+  new_port_cust = c;
+}
+
 Scheme_Input_Port *
 scheme_make_input_port(Scheme_Object *subtype,
 		       void *data,
@@ -1290,6 +1297,9 @@ scheme_make_input_port(Scheme_Object *subtype,
 		       int must_close)
 {
   Scheme_Input_Port *ip;
+  Scheme_Custodian *cust = new_port_cust;
+
+  new_port_cust = NULL;
 
   ip = MALLOC_ONE_TAGGED(Scheme_Input_Port);
   ip->p.so.type = scheme_input_port_type;
@@ -1313,7 +1323,7 @@ scheme_make_input_port(Scheme_Object *subtype,
 
   if (must_close) {
     Scheme_Custodian_Reference *mref;
-    mref = scheme_add_managed(NULL,
+    mref = scheme_add_managed(cust,
 			      (Scheme_Object *)ip,
 			      (Scheme_Close_Custodian_Client *)force_close_input_port,
 			      NULL, must_close);
@@ -1355,6 +1365,9 @@ scheme_make_output_port(Scheme_Object *subtype,
 			int must_close)
 {
   Scheme_Output_Port *op;
+  Scheme_Custodian *cust = new_port_cust;
+
+  new_port_cust = NULL;
 
   op = MALLOC_ONE_TAGGED(Scheme_Output_Port);
   op->p.so.type = scheme_output_port_type;
@@ -1376,7 +1389,7 @@ scheme_make_output_port(Scheme_Object *subtype,
 
   if (must_close) {
     Scheme_Custodian_Reference *mref;
-    mref = scheme_add_managed(NULL,
+    mref = scheme_add_managed(cust,
 			      (Scheme_Object *)op,
 			      (Scheme_Close_Custodian_Client *)force_close_output_port,
 			      NULL, must_close);

src/mzscheme/src/schemef.h

@@ -140,6 +140,7 @@ MZ_EXTERN Scheme_Custodian_Reference *scheme_add_managed(Scheme_Custodian *m, Sc
 							 Scheme_Close_Custodian_Client *f, void *data,
 							 int strong);
 MZ_EXTERN void scheme_custodian_check_available(Scheme_Custodian *m, const char *who, const char *what);
+MZ_EXTERN int scheme_custodian_is_available(Scheme_Custodian *m);
 MZ_EXTERN void scheme_remove_managed(Scheme_Custodian_Reference *m, Scheme_Object *o);
 MZ_EXTERN void scheme_close_managed(Scheme_Custodian *m);
 MZ_EXTERN void scheme_schedule_custodian_close(Scheme_Custodian *c);
@@ -800,6 +801,7 @@ MZ_EXTERN Scheme_Output_Port *scheme_make_output_port(Scheme_Object *subtype, vo
 						      Scheme_Write_Special_Evt_Fun write_special_evt_fun,
 						      Scheme_Write_Special_Fun write_special_fun,
 						      int must_close);
+MZ_EXTERN void scheme_set_next_port_custodian(Scheme_Custodian *c);
 
 MZ_EXTERN void scheme_set_port_location_fun(Scheme_Port *port,
 					    Scheme_Location_Fun location_fun);

src/mzscheme/src/schemex.h

@@ -111,6 +111,7 @@ Scheme_Custodian_Reference *(*scheme_add_managed)(Scheme_Custodian *m, Scheme_Ob
 							 Scheme_Close_Custodian_Client *f, void *data,
 							 int strong);
 void (*scheme_custodian_check_available)(Scheme_Custodian *m, const char *who, const char *what);
+int (*scheme_custodian_is_available)(Scheme_Custodian *m);
 void (*scheme_remove_managed)(Scheme_Custodian_Reference *m, Scheme_Object *o);
 void (*scheme_close_managed)(Scheme_Custodian *m);
 void (*scheme_schedule_custodian_close)(Scheme_Custodian *c);
@@ -674,6 +675,7 @@ Scheme_Output_Port *(*scheme_make_output_port)(Scheme_Object *subtype, void *dat
 						      Scheme_Write_Special_Evt_Fun write_special_evt_fun,
 						      Scheme_Write_Special_Fun write_special_fun,
 						      int must_close);
+void (*scheme_set_next_port_custodian)(Scheme_Custodian *c);
 void (*scheme_set_port_location_fun)(Scheme_Port *port,
 					    Scheme_Location_Fun location_fun);
 void (*scheme_set_port_count_lines_fun)(Scheme_Port *port,

src/mzscheme/src/schemex.inc

@@ -65,6 +65,7 @@
   scheme_extension_table->scheme_make_custodian = scheme_make_custodian;
   scheme_extension_table->scheme_add_managed = scheme_add_managed;
   scheme_extension_table->scheme_custodian_check_available = scheme_custodian_check_available;
+  scheme_extension_table->scheme_custodian_is_available = scheme_custodian_is_available;
   scheme_extension_table->scheme_remove_managed = scheme_remove_managed;
   scheme_extension_table->scheme_close_managed = scheme_close_managed;
   scheme_extension_table->scheme_schedule_custodian_close = scheme_schedule_custodian_close;
@@ -458,6 +459,7 @@
   scheme_extension_table->scheme_make_port_type = scheme_make_port_type;
   scheme_extension_table->scheme_make_input_port = scheme_make_input_port;
   scheme_extension_table->scheme_make_output_port = scheme_make_output_port;
+  scheme_extension_table->scheme_set_next_port_custodian = scheme_set_next_port_custodian;
   scheme_extension_table->scheme_set_port_location_fun = scheme_set_port_location_fun;
   scheme_extension_table->scheme_set_port_count_lines_fun = scheme_set_port_count_lines_fun;
   scheme_extension_table->scheme_progress_evt_via_get = scheme_progress_evt_via_get;

src/mzscheme/src/schemexm.h

@@ -65,6 +65,7 @@
 #define scheme_make_custodian (scheme_extension_table->scheme_make_custodian)
 #define scheme_add_managed (scheme_extension_table->scheme_add_managed)
 #define scheme_custodian_check_available (scheme_extension_table->scheme_custodian_check_available)
+#define scheme_custodian_is_available (scheme_extension_table->scheme_custodian_is_available)
 #define scheme_remove_managed (scheme_extension_table->scheme_remove_managed)
 #define scheme_close_managed (scheme_extension_table->scheme_close_managed)
 #define scheme_schedule_custodian_close (scheme_extension_table->scheme_schedule_custodian_close)
@@ -458,6 +459,7 @@
 #define scheme_make_port_type (scheme_extension_table->scheme_make_port_type)
 #define scheme_make_input_port (scheme_extension_table->scheme_make_input_port)
 #define scheme_make_output_port (scheme_extension_table->scheme_make_output_port)
+#define scheme_set_next_port_custodian (scheme_extension_table->scheme_set_next_port_custodian)
 #define scheme_set_port_location_fun (scheme_extension_table->scheme_set_port_location_fun)
 #define scheme_set_port_count_lines_fun (scheme_extension_table->scheme_set_port_count_lines_fun)
 #define scheme_progress_evt_via_get (scheme_extension_table->scheme_progress_evt_via_get)

src/mzscheme/src/thread.c

@@ -1331,16 +1331,22 @@ static void managed_object_gone(void *o, void *mr)
     remove_managed(mr, o, NULL, NULL);
 }
 
+int scheme_custodian_is_available(Scheme_Custodian *m)
+{
+  if (m->shut_down)
+    return 0;
+  return 1;
+}
+
 void scheme_custodian_check_available(Scheme_Custodian *m, const char *who, const char *what)
 {
   if (!m)
     m = (Scheme_Custodian *)scheme_get_param(scheme_current_config(), MZCONFIG_CUSTODIAN);
   
-  if (m->shut_down) {
+  if (!scheme_custodian_is_available(m))
     scheme_arg_mismatch(who, "the custodian has been shut down: ",
                         (Scheme_Object *)m);
 }
-}
 
 Scheme_Custodian_Reference *scheme_add_managed(Scheme_Custodian *m, Scheme_Object *o, 
 					       Scheme_Close_Custodian_Client *f, void *data, 

src/mzscheme/src/type.c

@@ -599,7 +599,7 @@ void scheme_register_traversers(void)
   GC_REG_TRAV(scheme_rt_buf_holder, buf_holder);
   GC_REG_TRAV(scheme_rt_pipe, mark_pipe);
 
-  GC_REG_TRAV(scheme_tcp_accept_evt_type, small_object);
+  GC_REG_TRAV(scheme_tcp_accept_evt_type, twoptr_obj);
 
   GC_REG_TRAV(scheme_special_comment_type, small_object);