91 lines
2.3 KiB
Scheme
91 lines
2.3 KiB
Scheme
#lang scheme
|
|
(require "match.ss"
|
|
"contract.ss"
|
|
#;"sema-mailbox.ss"
|
|
"mailbox.ss")
|
|
|
|
(define-struct tid (lid) #:prefab)
|
|
(define (create-tid thr) (make-tid thr))
|
|
|
|
; We need a mapping from MzScheme's tids to our tids (just for `self')
|
|
; and a mapping from symbols to mailboxes (for local threads).
|
|
|
|
(define tids (make-weak-hash))
|
|
(define mailboxes (make-hash))
|
|
|
|
(define (do-receive timeout timeout-thunk matcher)
|
|
(define mb (hash-ref mailboxes (tid-lid (self))))
|
|
(define val-thunk (mailbox-receive mb timeout timeout-thunk matcher))
|
|
(val-thunk))
|
|
|
|
(define-syntax receive
|
|
(syntax-rules (after)
|
|
[(_ (after timeout to-expr ...) (pat expr ...) ...)
|
|
(do-receive
|
|
timeout
|
|
(lambda () to-expr ...)
|
|
(match-lambda
|
|
(pat (lambda () expr ...)) ...
|
|
[_ match-fail]))]
|
|
[(_ clause ...) (receive (after false (void)) clause ...)]))
|
|
|
|
; must ensure name not already taken
|
|
(define (spawn/name-help thunk name)
|
|
(if (hash-ref mailboxes name (lambda () #f))
|
|
#f
|
|
(let ([new-tid (create-tid name)]
|
|
[parent-tid (self)])
|
|
(thread
|
|
(lambda ()
|
|
(hash-set! tids (current-thread) new-tid)
|
|
(hash-set! mailboxes name (new-mailbox))
|
|
(! parent-tid new-tid)
|
|
(thunk)))
|
|
(receive [(? (lambda (m) (equal? m new-tid))) new-tid]))))
|
|
|
|
(define next-thread
|
|
(let ([last-thread 1]
|
|
[lock (make-semaphore 1)])
|
|
(lambda ()
|
|
(call-with-semaphore
|
|
lock
|
|
(lambda ()
|
|
(begin0
|
|
last-thread
|
|
(set! last-thread (add1 last-thread))))))))
|
|
(define (next-thread-name)
|
|
(string->symbol
|
|
(string-append "thread" (number->string (next-thread)))))
|
|
|
|
(define-syntax spawn/name
|
|
(syntax-rules ()
|
|
[(_ name expr ...)
|
|
(spawn/name-help
|
|
(lambda () expr ...)
|
|
name)]))
|
|
|
|
(define (! tid msg)
|
|
(define mb (hash-ref mailboxes (tid-lid tid) (lambda () false)))
|
|
(when mb
|
|
(send-msg mb msg)))
|
|
|
|
(define (send-msg mbox msg)
|
|
(mailbox-send! mbox msg))
|
|
|
|
(define (self)
|
|
(hash-ref!
|
|
tids (current-thread)
|
|
; allows thread not created by spawn to receive messages
|
|
(lambda ()
|
|
(define name (next-thread-name))
|
|
(define new-tid (create-tid name))
|
|
(hash-set! mailboxes name (new-mailbox))
|
|
new-tid)))
|
|
|
|
(provide
|
|
spawn/name
|
|
receive)
|
|
(provide/contract*
|
|
[! (tid? any/c . -> . void)]
|
|
[self (-> tid?)])
|