[plt-scheme] BUG: tcp-accept-evt not always respecting current-custodian

When I use (sync (tcp-accept-evt ...)) to accept connections...  those ports
don't always end up on the (current-custodian) managed list.

If I used tcp-accept procedure instead of (sync (tcp-accept-evt listener))
everything works as expected.

I'm using PLT Scheme 4.2  and running this example in DrScheme. My OS is
64bit Ubuntu using the 64bit debian plt installer.

This does reproduce under mzscheme as well.


The output is the pair of ports that are accepted followed by the objects
that belong to the (current-custodian) after the accept happens for each
accepted connection.


This output is when using (sync (tcp-accept-evt listener)).
Note: This is the buggy behavior.

 (test #t 1)
"listener connected in-port 250545 out-port 250546  custodian objects ()"

(test #t 3)
"listener connected in-port 250568 out-port 250569  custodian objects ()"
"listener connected in-port 250571 out-port 250572  custodian objects ()"
"listener connected in-port 250574 out-port 250575  custodian objects ()"

(test #t 5)
"listener connected in-port 250597 out-port 250598  custodian objects ()"
"listener connected in-port 250599 out-port 250600  custodian objects ()"
"listener connected in-port 250601 out-port 250602  custodian objects
((#<output-port:tcp-accepted> . 250602) (#<input-port:tcp-accepted> .
250601))"
"listener connected in-port 250606 out-port 250607  custodian objects ()"
"listener connected in-port 250608 out-port 250609  custodian objects
((#<output-port:tcp-accepted> . 250609) (#<input-port:tcp-accepted> .
250608))"

(test #t 10)
"listener connected in-port 250632 out-port 250633  custodian objects ()"
"listener connected in-port 250634 out-port 250635  custodian objects ()"
"listener connected in-port 250636 out-port 250637  custodian objects
((#<output-port:tcp-accepted> . 250637) (#<input-port:tcp-accepted> .
250636))"
"listener connected in-port 250641 out-port 250642  custodian objects ()"
"listener connected in-port 250643 out-port 250644  custodian objects
((#<output-port:tcp-accepted> . 250644) (#<input-port:tcp-accepted> .
250643))"
"listener connected in-port 250645 out-port 250646  custodian objects
((#<output-port:tcp-accepted> . 250646) (#<input-port:tcp-accepted> .
250645))"
"listener connected in-port 250647 out-port 250648  custodian objects
((#<output-port:tcp-accepted> . 250648) (#<input-port:tcp-accepted> .
250647))"
"listener connected in-port 250649 out-port 250650  custodian objects
((#<output-port:tcp-accepted> . 250650) (#<input-port:tcp-accepted> .
250649))"
"listener connected in-port 250651 out-port 250652  custodian objects
((#<output-port:tcp-accepted> . 250652) (#<input-port:tcp-accepted> .
250651))"
"listener connected in-port 250659 out-port 250660  custodian objects ()"




This output is when using (tcp-accept) instead of the (sync (tcp-accept-evt
listener))
Note: This is the behavior that I expect


(test #f 1)
"listener connected in-port 250709 out-port 250710  custodian objects
((#<output-port:tcp-accepted> . 250710) (#<input-port:tcp-accepted> .
250709))"

(test #f 3)
"listener connected in-port 250732 out-port 250733  custodian objects
((#<output-port:tcp-accepted> . 250733) (#<input-port:tcp-accepted> .
250732))"
"listener connected in-port 250735 out-port 250736  custodian objects
((#<output-port:tcp-accepted> . 250736) (#<input-port:tcp-accepted> .
250735))"
"listener connected in-port 250738 out-port 250739  custodian objects
((#<output-port:tcp-accepted> . 250739) (#<input-port:tcp-accepted> .
250738))"

(test #f 5)
"listener connected in-port 250761 out-port 250762  custodian objects
((#<output-port:tcp-accepted> . 250762) (#<input-port:tcp-accepted> .
250761))"
"listener connected in-port 250763 out-port 250764  custodian objects
((#<output-port:tcp-accepted> . 250764) (#<input-port:tcp-accepted> .
250763))"
"listener connected in-port 250765 out-port 250766  custodian objects
((#<output-port:tcp-accepted> . 250766) (#<input-port:tcp-accepted> .
250765))"
"listener connected in-port 250770 out-port 250771  custodian objects
((#<output-port:tcp-accepted> . 250771) (#<input-port:tcp-accepted> .
250770))"
"listener connected in-port 250772 out-port 250773  custodian objects
((#<output-port:tcp-accepted> . 250773) (#<input-port:tcp-accepted> .
250772))"

(test #f 10)
"listener connected in-port 250796 out-port 250797  custodian objects
((#<output-port:tcp-accepted> . 250797) (#<input-port:tcp-accepted> .
250796))"
"listener connected in-port 250798 out-port 250799  custodian objects
((#<output-port:tcp-accepted> . 250799) (#<input-port:tcp-accepted> .
250798))"
"listener connected in-port 250800 out-port 250801  custodian objects
((#<output-port:tcp-accepted> . 250801) (#<input-port:tcp-accepted> .
250800))"
"listener connected in-port 250805 out-port 250806  custodian objects
((#<output-port:tcp-accepted> . 250806) (#<input-port:tcp-accepted> .
250805))"
"listener connected in-port 250807 out-port 250808  custodian objects
((#<output-port:tcp-accepted> . 250808) (#<input-port:tcp-accepted> .
250807))"
"listener connected in-port 250809 out-port 250810  custodian objects
((#<output-port:tcp-accepted> . 250810) (#<input-port:tcp-accepted> .
250809))"
"listener connected in-port 250811 out-port 250812  custodian objects
((#<output-port:tcp-accepted> . 250812) (#<input-port:tcp-accepted> .
250811))"
"listener connected in-port 250813 out-port 250814  custodian objects
((#<output-port:tcp-accepted> . 250814) (#<input-port:tcp-accepted> .
250813))"
"listener connected in-port 250815 out-port 250816  custodian objects
((#<output-port:tcp-accepted> . 250816) (#<input-port:tcp-accepted> .
250815))"
"listener connected in-port 250823 out-port 250824  custodian objects
((#<output-port:tcp-accepted> . 250824) (#<input-port:tcp-accepted> .
250823))"



Here is the program listing...


#lang scheme

(define (test use-accept-evt connector-count)
  (parameterize ([current-custodian (make-custodian)])
    (define main (current-thread))

    ;thread that pretty prints any messages it receives in its mailbox
    (define printer
      (thread
       (lambda ()
         (let loop ()
           (pretty-print (thread-receive))
           (loop)))))

    ;sends a message to be printed by the printer
    (define (pr fmt . args)
      (thread-send printer (apply format fmt args)))


    ;makes a thread that will connect to the local tcp listener
    (define (make-connector)
      (let ([super (current-custodian)]
            [cust (make-custodian)])
        (parameterize ([current-custodian cust])
          (thread
           (lambda ()
             (tcp-connect "localhost" 5000)
             (custodian-shutdown-all (current-custodian)))))
        cust))

    ;generats a list of pairs that contain the object its eq-hash-code
    ;of all objects managed by a given custodian
    (define (custodian-list-hash custodian super)
      (map (lambda (obj)
             (cons obj (eq-hash-code obj)))
           (custodian-managed-list custodian super)))


    ;thread that starts a tcp-listener and accepts incoming requests
    (define listener
      (thread
       (lambda ()
         (let ([listener (tcp-listen 5000 100 #t)]
               [super (current-custodian)])
           (thread-send main 'listener-ok)
           (let accept-loop ()
             (parameterize ([current-custodian (make-custodian super)])
               (if use-accept-evt
                   (let ([ports (sync (tcp-accept-evt listener))])
                     (pr "listener connected in-port ~a out-port ~a
custodian objects ~a" (eq-hash-code (first ports)) (eq-hash-code (second
ports)) (custodian-list-hash (current-custodian) super)))
                   (let-values ([(in out) (tcp-accept listener)])
                     (pr "listener connected in-port ~a out-port ~a
custodian objects ~a" (eq-hash-code in) (eq-hash-code out)
(custodian-list-hash (current-custodian) super)))))
             (accept-loop))))))

    ;wait for listener to initialize
    (thread-receive)

    ;spawn the connections
    (let conn-loop ([count connector-count])
      (unless (= count 0)
        (make-connector)
        (sleep 0)
        (conn-loop (sub1 count))))

    ;wait 2 seconds and shutdown everything
    (sleep 2)
    (custodian-shutdown-all (current-custodian))))



bug?

Thanks
   -Curt
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20090629/39d52436/attachment.html>