scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

revised concurrent-lookup

This commit is contained in:
cresh 2002-05-07 09:48:53 +00:00
parent a766574fd1
commit 5c72a6dad2
1 changed files with 19 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
dns.scm
View File

@ -802,93 +802,33 @@
;; lookup-queue record for concurrent-lookup
(define-record lookup-queue
lock
cond-lock
queue)
;; Lock-Conditions
(define-record lock-condition
lock
waiting-locks)
(define (wait-lock-condition lock-cond)
(let ((waiting-lock (make-lock)))
(obtain-lock waiting-lock)
(set-lock-condition:waiting-locks
lock-cond
(cons waiting-lock
(lock-condition:waiting-locks lock-cond)))
(let ((lock (lock-condition:lock lock-cond)))
(release-lock lock)
(obtain-lock waiting-lock)
(obtain-lock lock))))
(define (signal-lock-condition lock-cond)
(let ((waiting-locks (lock-condition:waiting-locks lock-cond)))
(if (not (null? waiting-locks))
(begin
(set-lock-condition:waiting-locks lock-cond
(cdr waiting-locks))
(release-lock (car waiting-locks))))))
(define (broadcast-lock-condition lock-cond)
(let ((waiting-locks (lock-condition:waiting-locks lock-cond)))
(set-lock-condition:waiting-locks lock-cond '())
(let loop ((waiting-locks waiting-locks))
(if (not (null? waiting-locks))
(begin
(release-lock (car waiting-locks))
(loop (cdr waiting-locks)))))))
;; with-lock
(define (with-lock lock thunk)
(obtain-lock lock)
(let ((value (thunk)))
(release-lock lock)
value))
;; concurrent-lookup ;; concurrent-lookup
;; starts a <lookup>-lookup to all nameservers in (dns-find-nameserver-list) ;; starts a <lookup>-lookup to all nameservers in (dns-find-nameserver-list)
(define (concurrent-lookup lookup name) (define (concurrent-lookup lookup name)
(let* ((return 'not-terminated-yet) (let* ((return 'no-value)
(lock (make-lock)) (lock (make-lock))
(ccl (make-lookup-queue lock (make-lock-condition lock '()) (make-queue)))) (queue (make-queue)))
(obtain-lock lock)
(spawn
(lambda ()
(display "consumer started \n")
(with-lock lock
(lambda ()
(let loop ()
(let ((queue (lookup-queue:queue ccl)))
(if (queue-empty? queue)
(begin
(wait-lock-condition (lookup-queue:cond-lock ccl))
(loop))
(let ((value (dequeue! queue)))
(set! return value)
value))))))))
(spawn (lambda () (spawn (lambda ()
(for-each (lambda (nameserver) (for-each (lambda (nameserver)
(spawn (spawn
(lambda () (lambda ()
(display nameserver)(display " started\n") (display nameserver)(display " started\n")
(with-lock lock (let* ((result (apply lookup (list name nameserver))))
(lambda () (enqueue! queue result)
(let* ((result (apply lookup (list name nameserver)))) (display nameserver)(display " ")(display result)(newline)
(enqueue! (lookup-queue:queue ccl) result) (release-lock lock)))))
(display nameserver)(display " ")(display result)(newline) (dns-find-nameserver-list))))
(broadcast-lock-condition (lookup-queue:cond-lock ccl))))))))
(dns-find-nameserver-list))))
;; ### active waiting ? (display "Consumer started\n")
(let loop () (let loop ()
(if (not (eq? return 'not-terminated-yet)) (obtain-lock lock)
return (let ((result (dequeue! queue)))
(loop))))) (if result
result
(loop))))))
;; checks the arguments of the dns-lookup-* functions. ;; checks the arguments of the dns-lookup-* functions.
;; if a nameserver-name is given and not a nameserver-ip ;; if a nameserver-name is given and not a nameserver-ip