105 lines
3.1 KiB
Scheme
105 lines
3.1 KiB
Scheme
; -----------------------
|
|
; --- Read/Write-Lock ---
|
|
; -----------------------
|
|
|
|
; Locks for a DNS-Server based on the RFCs: 1034 / 1035
|
|
|
|
; This file is part of the Scheme Untergrund Networking package
|
|
|
|
; Copyright (c) 2005/2006 by Norbert Freudemann
|
|
; <nofreude@informatik.uni-tuebingen.de>
|
|
; For copyright information, see the file COPYING which comes with
|
|
; the distribution.
|
|
|
|
|
|
; Simple locks for the dns-server database. The idea behind this sort of
|
|
; lock is to permit multiple threads to read the data secured by the lock.
|
|
; If a thread tries to write, it'll block all other access to the data
|
|
; and do it's work isolated. (One write to block them all... ;-)
|
|
|
|
; Interface:
|
|
|
|
; (make-r/w-lock) : creates an r/w-lock
|
|
|
|
; (obtain-R/w-lock r/w-lock)
|
|
; (obtain-r/W-lock r/w-lock)
|
|
|
|
; (release-R/w-lock r/w-lock)
|
|
; (release-r/W-lock r/w-lock)
|
|
|
|
; (with-R/w-lock rwlock thunk)
|
|
; (with-r/W-lock rwlock thunk)
|
|
|
|
|
|
(define-record-type r/w-lock :r/w-lock
|
|
(really-make-r/w-lock write-flag read-count write-lock mutex-lock)
|
|
r/w-lock?
|
|
(write-flag get-r/w-lock-write-flag set-r/w-lock-write-flag!)
|
|
(read-count get-r/w-lock-read-count set-r/w-lock-read-count!)
|
|
(write-lock get-r/w-lock-write-lock)
|
|
(mutex-lock get-r/w-lock-mutex-lock))
|
|
|
|
(define (make-r/w-lock)
|
|
(really-make-r/w-lock #f 0 (make-lock) (make-lock)))
|
|
|
|
(define (obtain-R/w-lock r/w-lock)
|
|
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
|
|
(let loop ()
|
|
(obtain-lock mutex-lock)
|
|
; Is there is a thread writing?
|
|
(if (get-r/w-lock-write-flag r/w-lock)
|
|
(begin
|
|
(release-lock mutex-lock)
|
|
; Just wait for some time and try again...
|
|
; TODO?: Do that with locks
|
|
(relinquish-timeslice)
|
|
(loop))
|
|
(begin
|
|
(set-r/w-lock-read-count!
|
|
r/w-lock
|
|
(+ 1 (get-r/w-lock-read-count r/w-lock)))
|
|
(release-lock mutex-lock))))))
|
|
|
|
(define (release-R/w-lock r/w-lock)
|
|
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
|
|
(obtain-lock mutex-lock)
|
|
(set-r/w-lock-read-count!
|
|
r/w-lock (- (get-r/w-lock-read-count r/w-lock) 1))
|
|
(release-lock mutex-lock)))
|
|
|
|
(define (obtain-r/W-lock r/w-lock)
|
|
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
|
|
(write-lock (get-r/w-lock-write-lock r/w-lock)))
|
|
; Maybe wait here for another write-thread:
|
|
(obtain-lock write-lock)
|
|
(let loop ()
|
|
(obtain-lock mutex-lock)
|
|
(set-r/w-lock-write-flag! r/w-lock #t)
|
|
(if (= 0 (get-r/w-lock-read-count r/w-lock))
|
|
(release-lock mutex-lock)
|
|
(begin
|
|
(release-lock mutex-lock)
|
|
; Wait until the reads finish...
|
|
; TODO?: Do that with locks
|
|
(relinquish-timeslice)
|
|
(loop))))))
|
|
|
|
(define (release-r/W-lock r/w-lock)
|
|
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
|
|
(write-lock (get-r/w-lock-write-lock r/w-lock)))
|
|
(obtain-lock mutex-lock)
|
|
(set-r/w-lock-write-flag! r/w-lock #f)
|
|
(release-lock mutex-lock)
|
|
(release-lock write-lock)))
|
|
|
|
(define (with-R/w-lock rwlock thunk)
|
|
(obtain-R/w-lock rwlock)
|
|
(let ((value (thunk)))
|
|
(release-R/w-lock rwlock)
|
|
value))
|
|
|
|
(define (with-r/W-lock rwlock thunk)
|
|
(obtain-r/W-lock rwlock)
|
|
(let ((value (thunk)))
|
|
(release-r/W-lock rwlock)
|
|
value)) |