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

* code reformatting

Browse Source 
* use kw.ss instead of opt-lambda
* moved a debugging comment into an `if'

svn: r4273
This commit is contained in:
Eli Barzilay 2006-09-07 19:55:41 +00:00
parent a0ccd557f5
commit a0c4d3b454
1 changed files with 163 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/mzlib/thread.ss
View File

@ -1,6 +1,6 @@
(module thread mzscheme (module thread mzscheme
(require "etc.ss" "contract.ss") (require "kw.ss" "contract.ss")
(provide run-server (provide run-server
consumer-thread) consumer-thread)
@ -12,10 +12,7 @@
block. block.
|# |#
(define consumer-thread (define/kw (consumer-thread f #:optional [init void])
(case-lambda
[(f) (consumer-thread f void)]
[(f init)
(unless (procedure? f) (raise-type-error 'consumer-thread "procedure" f)) (unless (procedure? f) (raise-type-error 'consumer-thread "procedure" f))
(let ([sema (make-semaphore 0)] (let ([sema (make-semaphore 0)]
[protect (make-semaphore 1)] [protect (make-semaphore 1)]
@ -56,12 +53,10 @@
(semaphore-wait protect) (semaphore-wait protect)
(set! front-state (cons new-state front-state)) (set! front-state (cons new-state front-state))
(semaphore-post protect) (semaphore-post protect)
(semaphore-post sema))))])) (semaphore-post sema)))))
(define run-server (define/kw (run-server port-number handler connection-timeout
(opt-lambda (port-number #:optional
handler
connection-timeout
[handle-exn void] [handle-exn void]
[tcp-listen tcp-listen] [tcp-listen tcp-listen]
[tcp-close tcp-close] [tcp-close tcp-close]
@ -114,7 +109,7 @@
(sync/timeout connection-timeout t) (sync/timeout connection-timeout t)
(custodian-shutdown-all c))))))))) (custodian-shutdown-all c)))))))))
(loop)))) (loop))))
(lambda () (tcp-close l)))))) (lambda () (tcp-close l)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Couroutine ;; Couroutine
@ -127,44 +122,43 @@
;; coroutine : ((bool ->) -> X) -> X-coroutine-object ;; coroutine : ((bool ->) -> X) -> X-coroutine-object
(define (coroutine f) (define (coroutine f)
;;(printf "2. new coroutine~n") ;;(printf "2. new coroutine~n")
(let* ((can-stop-lock (make-semaphore 1)) (let* ([can-stop-lock (make-semaphore 1)]
(done-ch (make-channel)) [done-ch (make-channel)]
(ex-ch (make-channel)) [ex-ch (make-channel)]
(proceed-sema (make-semaphore)) [proceed-sema (make-semaphore)]
(stop-enabled? #t) [stop-enabled? #t]
(enable-stop [enable-stop
(lambda (enable?) (lambda (enable?)
;;(printf "3. enabling ~a~n" enable?) ;;(printf "3. enabling ~a~n" enable?)
(cond (cond
((and enable? (not stop-enabled?)) [(and enable? (not stop-enabled?))
(semaphore-post can-stop-lock) (semaphore-post can-stop-lock)
(set! stop-enabled? #t)) (set! stop-enabled? #t)]
((and (not enable?) stop-enabled?) [(and (not enable?) stop-enabled?)
(semaphore-wait can-stop-lock) (semaphore-wait can-stop-lock)
(set! stop-enabled? #f))) (set! stop-enabled? #f)])
;;(printf "3. finished enabling~n") ;;(printf "3. finished enabling~n")
)) )]
(tid (thread (lambda () [tid (thread (lambda ()
(semaphore-wait proceed-sema) (semaphore-wait proceed-sema)
;;(printf "3. creating coroutine thread~n") ;;(printf "3. creating coroutine thread~n")
(with-handlers (((lambda (exn) #t) (with-handlers ([(lambda (exn) #t)
(lambda (exn) (lambda (exn)
(enable-stop #t) (enable-stop #t)
(channel-put ex-ch exn)))) (channel-put ex-ch exn))])
(let ([v (f enable-stop)]) (let ([v (f enable-stop)])
(enable-stop #t) (enable-stop #t)
(channel-put done-ch v))))))) (channel-put done-ch v)))))])
(begin0 (begin0 (make-coroutine-object tid can-stop-lock done-ch ex-ch #f)
(make-coroutine-object tid can-stop-lock done-ch ex-ch #f)
(thread-suspend tid) (thread-suspend tid)
(semaphore-post proceed-sema)))) (semaphore-post proceed-sema))))
;; coroutine : real-number X-coroutine-object -> bool ;; coroutine : real-number X-coroutine-object -> bool
(define (coroutine-run timeout w) (define (coroutine-run timeout w)
(if (coroutine-object-worker w) (if (coroutine-object-worker w)
(let ([can-stop-lock (coroutine-object-can-stop-lock w)]
[worker (coroutine-object-worker w)])
#;(printf "2. starting coroutine~n") #;(printf "2. starting coroutine~n")
(let ((can-stop-lock (coroutine-object-can-stop-lock w))
(worker (coroutine-object-worker w)))
(thread-resume worker) (thread-resume worker)
(dynamic-wind (dynamic-wind
void void
@ -218,4 +212,3 @@
(coroutine-run (real? coroutine? . -> . boolean?)) (coroutine-run (real? coroutine? . -> . boolean?))
(coroutine-result (coroutine? . -> . any)) (coroutine-result (coroutine? . -> . any))
(coroutine-kill (coroutine? . -> . any)))) (coroutine-kill (coroutine? . -> . any))))