87 lines
2.9 KiB
Racket
87 lines
2.9 KiB
Racket
#lang scheme
|
|
(require "match.ss"
|
|
"contract.ss")
|
|
|
|
(define (call-with-semaphore s thunk)
|
|
(semaphore-wait s)
|
|
(let ([result (thunk)])
|
|
(semaphore-post s)
|
|
result))
|
|
|
|
(define Mcons mcons)
|
|
(define release void)
|
|
|
|
(define-struct mailbox (old-head old-last head tail sem-count sem-space lock-enqueue) #:mutable)
|
|
|
|
(define (new-mailbox)
|
|
(let* ([sentinel (Mcons empty empty)]
|
|
[old-sentinel (Mcons empty empty)]
|
|
[old-head (Mcons empty old-sentinel)])
|
|
(make-mailbox old-head
|
|
old-sentinel
|
|
sentinel
|
|
sentinel
|
|
(make-semaphore)
|
|
(make-semaphore 1000)
|
|
(make-semaphore 1))))
|
|
|
|
(define (try-extract m l)
|
|
(let loop ([prev l] [cur (mcdr l)])
|
|
(if (empty? (mcdr cur))
|
|
#f
|
|
(let ([v (m (mcar cur))])
|
|
(if (eq? v match-fail)
|
|
(loop cur (mcdr cur))
|
|
(begin0 v
|
|
(set-mcdr! prev (mcdr cur))
|
|
(release cur)))))))
|
|
|
|
(define (mailbox-receive mb timeout timeout-thunk matcher)
|
|
(define start-time (current-inexact-milliseconds))
|
|
(match (try-extract matcher (mailbox-old-head mb))
|
|
[#f
|
|
(let wait ()
|
|
(let* ([elapsed (- (current-inexact-milliseconds) start-time)]
|
|
[wait-time (cond
|
|
[(not timeout) false]
|
|
[(> elapsed timeout) 0]
|
|
[else (/ (- timeout elapsed) 1000.0)])]
|
|
[not-timeout? (sync/timeout wait-time (mailbox-sem-count mb))])
|
|
(if not-timeout?
|
|
(let* ([oldhead (mailbox-head mb)]
|
|
[msg (mcar oldhead)]
|
|
[v
|
|
(begin (set-mailbox-head! mb (mcdr oldhead))
|
|
(release oldhead)
|
|
(semaphore-post (mailbox-sem-space mb))
|
|
(matcher msg))])
|
|
(if (eq? v match-fail)
|
|
(let ([new-last (Mcons empty empty)]
|
|
[old-last (mailbox-old-last mb)])
|
|
(set-mcar! old-last msg)
|
|
(set-mcdr! old-last new-last)
|
|
(set-mailbox-old-last! mb new-last)
|
|
(wait))
|
|
v))
|
|
timeout-thunk)))]
|
|
[val
|
|
val]))
|
|
|
|
(define (mailbox-send! mbox msg)
|
|
(call-with-semaphore
|
|
(mailbox-lock-enqueue mbox)
|
|
(lambda ()
|
|
(let ([newtail (Mcons empty empty)]
|
|
[oldtail (mailbox-tail mbox)])
|
|
(set-mcar! oldtail msg)
|
|
(set-mcdr! oldtail newtail)
|
|
(set-mailbox-tail! mbox newtail)
|
|
(semaphore-wait (mailbox-sem-space mbox))
|
|
(semaphore-post (mailbox-sem-count mbox))))))
|
|
|
|
(provide/contract*
|
|
[mailbox? (any/c . -> . boolean?)]
|
|
[new-mailbox (-> mailbox?)]
|
|
[mailbox-send! (mailbox? any/c . -> . void)]
|
|
[mailbox-receive (mailbox? (or/c false/c number?) (-> any) (any/c . -> . (-> any)) . -> . (-> any))])
|