abandon unused scheme_socket_to_ports during place copy

collects/tests/racket/place-channel-fd2.rkt

@@ -0,0 +1,66 @@
+#lang racket/base
+(require racket/match
+         racket/place
+         rackunit)
+
+(define (racket-subprocess o i e . args)
+  (define (current-executable-path)
+    (parameterize ([current-directory (find-system-path 'orig-dir)])
+      (find-executable-path (find-system-path 'exec-file) #f)))
+
+  (apply subprocess o i e (current-executable-path) args))
+
+(provide main)
+(define (main)
+  (test-case
+    "test file descriptors copied across place channesl"
+;; write out "fdt.rkt"
+    (with-output-to-file "fdt.rkt" #:exists 'replace (lambda ()
+      (display
+#<<END
+#lang racket/base
+(define (write-flush x [p (current-output-port)])
+  (write x p)
+  (flush-output p))
+
+(sleep 3)
+(with-handlers ([exn? (lambda (e) (eprintf "Child Read Exception Caught ~e\n" e))])
+  (fprintf (current-error-port) "ChildRead1 ~a\n" (read)))
+(with-handlers ([exn? (lambda (e) (eprintf "Child Read Exception Caught ~e\n" e))])
+  (fprintf (current-error-port) "ChildRead2 ~a\n" (read)))
+;(close-input-port)
+
+(sleep 3)
+(with-handlers ([exn? (lambda (e) (eprintf "Child Write StdOut Exception Caught ~e\n" e))])
+  (write-flush "ByeO"))
+(with-handlers ([exn? (lambda (e) (fprintf "Child Write StdErr Exception Caught ~e\n" e))])
+  (write-flush "ByeE" (current-error-port)))
+END
+)))
+
+    (define (write-flush x [port (current-output-port)])
+      (write x port)
+      (flush-output port))
+
+    (define p
+      (place ch
+        (match (place-channel-get ch)
+          [(list in out)
+           (with-handlers ([exn? (lambda (e) (printf "Place Write Exception Caught ~e\n" e) (raise e))])
+             (write "BFrom Place" out)
+             (flush-output out))
+             (close-output-port out)])))
+
+    (let ()
+      (define-values (s o i e) (racket-subprocess #f #f (current-error-port) "fdt.rkt"))
+      (place-channel-put p (list o i))
+      ;(close-output-port i)
+      ;(close-input-port o)
+      (place-wait p)
+      (with-handlers ([exn? (lambda (e) (printf "Parent Write Exception Caught ~e\n" e) (raise e))])
+        (write-flush "AFrom Parent" i))
+      (with-handlers ([exn? (lambda (e) (printf "Parent Read Exception Caught ~e\n" e) (raise e))])
+        (printf "ParentRead ~v\n" (read o)))
+      (subprocess-wait s)
+      (displayln (subprocess-status s)))))
+

collects/tests/racket/place-channel-socket.rkt

@@ -0,0 +1,58 @@
+#lang racket/base
+(require racket/match
+         racket/place
+         racket/tcp
+         rackunit)
+
+(provide main)
+
+(define (main)
+  (test-case
+    "places use of scheme_socket_to_ports abandons ports correctly"
+    (define port-ch (make-channel))
+
+    (define p 
+      (place ch
+        (match (place-channel-get ch)
+          [(list in out)
+            (printf "IN PLACE\n")
+            (with-handlers ([exn? (lambda (e) (printf "Place Write Exception Caught ~e\n" e) (raise e))])
+              (write "From Place" out)
+              (flush-output out))
+              ;(sleep 12)
+            (tcp-abandon-port in)
+            (tcp-abandon-port out)
+            ])))
+
+    (define t 
+      (thread
+        (lambda ()
+
+          (define s (tcp-listen 0))
+          (define-values (h1 p1 h2 p2) (tcp-addresses s #t))
+          (printf "~a ~a ~a ~a\n" h1 p1 h2 p2)
+          (channel-put port-ch p1)
+          (define-values (in out) (tcp-accept s))
+          (place-channel-put p (list in out))
+          (place-wait p)
+          ;(close-input-port in)
+          ;(close-output-port out)
+          (with-handlers ([exn? (lambda (e) (printf "Server Write Exception Caught ~e\n" e) (raise e))])
+            (write "From Server" out)
+            (flush-output out))
+          (with-handlers ([exn? (lambda (e) (printf "Server Read Exception Caught2 ~e\n" e) (raise e))])
+            (define x (read in))
+            (printf "SERVER IN ~a\n" x))
+          )))
+
+    (define-values (in out) (tcp-connect "localhost" (channel-get port-ch)))
+    (printf "Connected\n")
+    (sleep 3)
+    (with-handlers ([exn? (lambda (e) (printf "Client Write Exception Caught ~e\n" (raise e)))])
+      (write "From Client" out)
+      (flush-output out))
+    (printf "CLIENT IN1 ~a\n" (read in))
+    (printf "CLIENT IN2 ~a\n" (read in))
+    (thread-wait t)
+    (place-wait p)))
+

src/racket/src/network.c

@@ -2383,6 +2383,10 @@ static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
   return NULL;
 }
 
+void scheme_tcp_abandon_port(Scheme_Object *port) {
+  tcp_abandon_port(1, &port);
+}
+
 static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[])
 {
 #ifdef USE_TCP

src/racket/src/place.c

@@ -1118,7 +1118,14 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h
         int type = ((Scheme_Simple_Object *) so)->u.two_int_val.int1;
         int fd   = ((Scheme_Simple_Object *) so)->u.two_int_val.int2;
         scheme_socket_to_ports(fd, "", 1, &in, &out);
-        new_so = (type == scheme_input_port_type) ? in : out;
+        if (type == scheme_input_port_type) {
+          scheme_tcp_abandon_port(out);
+          new_so = in;
+        }
+        else {
+          scheme_tcp_abandon_port(in);
+          new_so = out;
+        }
       }
       break;
     case scheme_serialized_file_fd_type:

src/racket/src/schpriv.h

@@ -3697,6 +3697,7 @@ intptr_t scheme_dup_socket(intptr_t fd);
 intptr_t scheme_dup_file(intptr_t fd);
 void scheme_close_socket_fd(intptr_t fd);
 void scheme_close_file_fd(intptr_t fd);
+void scheme_tcp_abandon_port(Scheme_Object *port);
 
 
 #define SCHEME_PLACE_OBJECTP(o) (SCHEME_TYPE(o) == scheme_place_object_type)