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

323
collects/mzlib/thread.ss
View File

@ -1,9 +1,9 @@
(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)
#| #|
t accepts a function, f, and creates a thread. It returns the thread and a t accepts a function, f, and creates a thread. It returns the thread and a
@ -12,109 +12,104 @@
block. block.
|# |#
(define consumer-thread (define/kw (consumer-thread f #:optional [init void])
(case-lambda (unless (procedure? f) (raise-type-error 'consumer-thread "procedure" f))
[(f) (consumer-thread f void)] (let ([sema (make-semaphore 0)]
[(f init) [protect (make-semaphore 1)]
(unless (procedure? f) (raise-type-error 'consumer-thread "procedure" f)) [front-state null]
(let ([sema (make-semaphore 0)] [back-state null])
[protect (make-semaphore 1)] (values
[front-state null] (thread
[back-state null]) (letrec ([loop
(values (lambda ()
(thread (semaphore-wait sema)
(letrec ([loop (let ([local-state
(lambda () (begin
(semaphore-wait sema) (semaphore-wait protect)
(let ([local-state (if (null? back-state)
(begin (let ([new-front (reverse front-state)])
(semaphore-wait protect) (set! back-state (cdr new-front))
(if (null? back-state) (set! front-state null)
(let ([new-front (reverse front-state)]) (semaphore-post protect)
(set! back-state (cdr new-front)) (car new-front))
(set! front-state null) (begin0
(semaphore-post protect) (car back-state)
(car new-front)) (set! back-state (cdr back-state))
(begin0 (semaphore-post protect))))])
(car back-state) (apply f local-state))
(set! back-state (cdr back-state)) (loop))])
(semaphore-post protect))))]) (lambda ()
(apply f local-state)) (init)
(loop))]) (loop))))
(lambda () (lambda new-state
(init) (let ([num (length new-state)])
(loop)))) (unless (procedure-arity-includes? f num)
(lambda new-state (raise
(let ([num (length new-state)]) (make-exn:fail:contract:arity
(unless (procedure-arity-includes? f num) (string->immutable-string
(raise (format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a"
(make-exn:fail:contract:arity (procedure-arity f) num (if (= 1 num) "" "s")))
(string->immutable-string (current-continuation-marks)))))
(format "<procedure-from-consumer-thread>: consumer procedure arity is ~e; provided ~s argument~a" (semaphore-wait protect)
(procedure-arity f) num (if (= 1 num) "" "s"))) (set! front-state (cons new-state front-state))
(current-continuation-marks))))) (semaphore-post protect)
(semaphore-wait protect) (semaphore-post sema)))))
(set! front-state (cons new-state front-state))
(semaphore-post protect)
(semaphore-post sema))))]))
(define run-server (define/kw (run-server port-number handler connection-timeout
(opt-lambda (port-number #:optional
handler [handle-exn void]
connection-timeout [tcp-listen tcp-listen]
[handle-exn void] [tcp-close tcp-close]
[tcp-listen tcp-listen] [tcp-accept tcp-accept]
[tcp-close tcp-close] [tcp-accept/enable-break tcp-accept/enable-break])
[tcp-accept tcp-accept] (let ([l (tcp-listen port-number 5 #t)]
[tcp-accept/enable-break tcp-accept/enable-break]) [can-break? (break-enabled)])
(let ([l (tcp-listen port-number 5 #t)] (dynamic-wind
[can-break? (break-enabled)]) void
(dynamic-wind (lambda ()
void ;; All connections should use the same parameterization,
(lambda () ;; to facilitate transferring continuations from one
;; All connections should use the same parameterization, ;; connection to another:
;; to facilitate transferring continuations from one (let ([paramz (current-parameterization)])
;; connection to another: ;; Loop to handle connections:
(let ([paramz (current-parameterization)]) (let loop ()
;; Loop to handle connections: (with-handlers ([exn:fail:network? handle-exn])
(let loop () ;; Make a custodian for the next session:
(with-handlers ([exn:fail:network? handle-exn]) (let ([c (make-custodian)])
;; Make a custodian for the next session: (parameterize ([current-custodian c])
(let ([c (make-custodian)]) ;; disable breaks during session set-up...
(parameterize ([current-custodian c]) (parameterize-break #f
;; disable breaks during session set-up... ;; ... but enable breaks while blocked on an accept:
(parameterize-break #f (let-values ([(r w) ((if can-break?
;; ... but enable breaks while blocked on an accept: tcp-accept/enable-break
(let-values ([(r w) ((if can-break? tcp-accept)
tcp-accept/enable-break l)])
tcp-accept) ;; Handler thread:
l)]) (let ([t (thread (lambda ()
;; Handler thread: ;; First, install the parameterization
(let ([t (thread (lambda () ;; used for all connections:
;; First, install the parameterization (call-with-parameterization
;; used for all connections: paramz
(call-with-parameterization (lambda ()
paramz ;; Install this connection's custodian
(lambda () ;; for this thread in the shared
;; Install this connection's custodian ;; parameterization:
;; for this thread in the shared (current-custodian c)
;; parameterization: ;; Enable breaking:
(current-custodian c) (when can-break?
;; Enable breaking: (break-enabled #t))
(when can-break? ;; Call the handler
(break-enabled #t)) (handler r w)))))])
;; Call the handler ;; Clean-up and timeout thread:
(handler r w)))))]) (thread (lambda ()
;; Clean-up and timeout thread: (sync/timeout connection-timeout t)
(thread (lambda () (when (thread-running? t)
(sync/timeout connection-timeout t) ;; Only happens if connection-timeout is not #f
(when (thread-running? t) (break-thread t))
;; Only happens if connection-timeout is not #f (sync/timeout connection-timeout t)
(break-thread t)) (custodian-shutdown-all c)))))))))
(sync/timeout connection-timeout t) (loop))))
(custodian-shutdown-all c))))))))) (lambda () (tcp-close l)))))
(loop))))
(lambda () (tcp-close l))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Couroutine ;; Couroutine
@ -127,74 +122,73 @@
;; 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)
#;(printf "2. starting coroutine~n") (let ([can-stop-lock (coroutine-object-can-stop-lock w)]
(let ((can-stop-lock (coroutine-object-can-stop-lock w)) [worker (coroutine-object-worker w)])
(worker (coroutine-object-worker w))) #;(printf "2. starting coroutine~n")
(thread-resume worker) (thread-resume worker)
(dynamic-wind (dynamic-wind
void void
;; Let the co-routine run... ;; Let the co-routine run...
(lambda () (lambda ()
(sync (choice-evt (wrap-evt (alarm-evt (+ timeout (current-inexact-milliseconds))) (sync (choice-evt (wrap-evt (alarm-evt (+ timeout (current-inexact-milliseconds)))
(lambda (x) (lambda (x)
#;(printf "2. alarm-evt~n") #;(printf "2. alarm-evt~n")
(semaphore-wait can-stop-lock) (semaphore-wait can-stop-lock)
(thread-suspend worker) (thread-suspend worker)
(semaphore-post can-stop-lock) (semaphore-post can-stop-lock)
#f)) #f))
(wrap-evt (coroutine-object-done-ch w) (wrap-evt (coroutine-object-done-ch w)
(lambda (res) (lambda (res)
#;(printf "2. coroutine-done-evt~n") #;(printf "2. coroutine-done-evt~n")
(set-coroutine-object-result! w res) (set-coroutine-object-result! w res)
(coroutine-kill w) (coroutine-kill w)
#t)) #t))
(wrap-evt (coroutine-object-ex-ch w) (wrap-evt (coroutine-object-ex-ch w)
(lambda (exn) (lambda (exn)
#;(printf "2. ex-evt~n") #;(printf "2. ex-evt~n")
(coroutine-kill w) (coroutine-kill w)
(raise exn)))))) (raise exn))))))
;; In case we escape through a break: ;; In case we escape through a break:
(lambda () (lambda ()
(when (thread-running? worker) (when (thread-running? worker)
(semaphore-wait can-stop-lock) (semaphore-wait can-stop-lock)
(thread-suspend worker) (thread-suspend worker)
(semaphore-post can-stop-lock))))) (semaphore-post can-stop-lock)))))
#t)) #t))
;; coroutine-result : X-coroutine-object -> X ;; coroutine-result : X-coroutine-object -> X
(define (coroutine-result w) (define (coroutine-result w)
@ -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))))