suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adjust FrTime mailbox implementation to use `thread-{receive,send}'

Browse Source 
instead of async channels. This change allows Fred to work. The
  change is needed due to implementation weaknesses at multiple
  levels, but mostly because `on-subwindow-event' has to complete
  atomically --- or else events are pessimistically discarded, and
  async-channel communication never completes atomically. In contrast,
  messages can be posted to the built-in message queue for a thread
  (because it's built in). Probably the async-channel library should
  switch to using the built-in thread queue support.
 Merge to 5.1
This commit is contained in:
Matthew Flatt 2011-02-05 16:36:05 -07:00
parent 3e38071dae
commit 3c6652b83c
1 changed files with 10 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/frtime/core/mailbox.rkt
View File

@ -7,10 +7,12 @@
(define (snoc x l) (append l (list x))) (define (snoc x l) (append l (list x)))
; Define mailboxes ; Define mailboxes
(define-struct mailbox (manager control msgs)) (define-struct mailbox (manager control))
(define (new-mailbox) (define (new-mailbox)
(define control-ch (make-channel)) (define control-ch (make-channel))
(define msgs-ch (make-async-channel)) (define (thread-recv-evt)
(handle-evt (thread-receive-evt)
(lambda (e) (thread-receive))))
; Try to match one message ; Try to match one message
(define (try-to-match req msg) (define (try-to-match req msg)
(match req (match req
@ -32,7 +34,7 @@
(list* msg (try-to-match* req msgs)))])) (list* msg (try-to-match* req msgs)))]))
; Accept new messages until we need to match one ; Accept new messages until we need to match one
(define (not-on-receive msgs) (define (not-on-receive msgs)
(sync (handle-evt msgs-ch (sync (handle-evt (thread-recv-evt)
(lambda (new-msg) (lambda (new-msg)
(not-on-receive (snoc new-msg msgs)))) (not-on-receive (snoc new-msg msgs))))
(handle-evt control-ch (handle-evt control-ch
@ -51,7 +53,7 @@
[(not timeout) false] [(not timeout) false]
[(> elapsed timeout) 0] [(> elapsed timeout) 0]
[else (/ (- timeout elapsed) 1000.0)])) [else (/ (- timeout elapsed) 1000.0)]))
(define new-msg (sync/timeout wait-time msgs-ch)) (define new-msg (sync/timeout wait-time (thread-recv-evt)))
(if new-msg (if new-msg
(if (try-to-match req new-msg) (if (try-to-match req new-msg)
(not-on-receive msgs) (not-on-receive msgs)
@ -63,17 +65,17 @@
(thread (thread
(lambda () (lambda ()
(not-on-receive empty)))) (not-on-receive empty))))
(make-mailbox manager control-ch msgs-ch)) (make-mailbox manager control-ch))
(define-struct receive (reply-ch timeout timeout-thunk matcher)) (define-struct receive (reply-ch timeout timeout-thunk matcher))
(define (mailbox-send! mb msg) (define (mailbox-send! mb msg)
(match mb (match mb
[(struct mailbox (thd _ msgs)) [(struct mailbox (thd _))
(thread-resume thd) (thread-resume thd)
(async-channel-put msgs msg)])) (thread-send thd msg)]))
(define (mailbox-receive mb timeout timeout-thunk matcher) (define (mailbox-receive mb timeout timeout-thunk matcher)
(match mb (match mb
[(struct mailbox (thd control _)) [(struct mailbox (thd control))
(define reply-ch (make-channel)) (define reply-ch (make-channel))
(thread-resume thd) (thread-resume thd)
(channel-put control (make-receive reply-ch timeout timeout-thunk matcher)) (channel-put control (make-receive reply-ch timeout timeout-thunk matcher))