[plt-scheme] sync deadlock weirdness

Hi everyone,

I was tracking down a deadlock in a multi-thread program, and isolated
what seems like a bug in sync. The bug is related to the order by
which non-mutually exclusive thread-dead-events are supplied to
sync.

The following code triggers the deadlock consistently in my gnu box
(gcc 4.1.1, glibc 2.4.4) with mzscheme-360.

(make-foos foo) deadlocks after a little while.
(make-foos foo-nobug) works fine.
The only difference between the two functions is the relative order
of the thread-dead/channel-put choice and the wrapped thread-dead.

-- code --

(define (foo me ch)
  (let* ((pinfo (channel-get ch))
         (peer (car pinfo))
         (peer-ch (cdr pinfo)))
    (sleep 1)
    (let lp ((n 0))
      (unless (> n 100000)
        (sync (handle-evt ch (lambda (v)
                               (printf "~a: received ~a~n" me v)
                               (unless (eq? v 'die) (lp n))))
              (handle-evt (choice-evt (thread-dead-evt peer)
                                      (channel-put-evt peer-ch (random)))
                          (lambda (evt) (lp (add1 n))))
              (handle-evt (wrap-evt (thread-dead-evt peer)
                                    (lambda (evt) (void)))
                          (lambda (evt) (printf "~a: my peer died~n" me))))))))

(define (foo-nobug me ch)
  (let* ((pinfo (channel-get ch))
         (peer (car pinfo))
         (peer-ch (cdr pinfo)))
    (sleep 1)
    (let lp ((n 0))
      (unless (> n 100000)
        (sync (handle-evt ch (lambda (v)
                               (printf "~a: received ~a~n" me v)
                               (unless (eq? v 'die) (lp n))))
              (handle-evt (wrap-evt (thread-dead-evt peer)
                                    (lambda (evt) (void)))
                          (lambda (evt) (printf "~a: my peer died~n" me)))
              (handle-evt (choice-evt (thread-dead-evt peer)
                                      (channel-put-evt peer-ch (random)))
                          (lambda (evt) (lp (add1 n)))))))))


(define (make-foos foo)
  (let* ((ch1 (make-channel))
         (ch2 (make-channel))
         (thr1 (thread (lambda () (foo 'jekyll ch1))))
         (thr2 (thread (lambda () (foo 'hyde ch2)))))
    (channel-put ch1 (cons thr2 ch2))
    (channel-put ch2 (cons thr1 ch1))
    (values (cons thr1 ch1) (cons thr2 ch2))))

;; deadlocks!
(make-foos foo)

;; does not deadlock
(make-foos foo-nobug)

-- vyzo