171 lines
4.3 KiB
Scheme
171 lines
4.3 KiB
Scheme
(load "util.scm")
|
|
|
|
(define (make-serializer)
|
|
(let ((mutex (make-mutex)))
|
|
(lambda (p)
|
|
(define (serialized-p . args)
|
|
(mutex 'acquire)
|
|
(let ((val (apply p args)))
|
|
(mutex 'release)
|
|
val))
|
|
serialized-p)))
|
|
|
|
(define (make-mutex)
|
|
(let ((cell (list false)))
|
|
(define (the-mutex m)
|
|
(cond ((eq? m 'acquire)
|
|
(if (test-and-set! cell)
|
|
(the-mutex 'acquire))) ; retry
|
|
((eq? m 'release) (clear! cell))))
|
|
the-mutex))
|
|
|
|
(define (clear! cell)
|
|
(set-car! cell false))
|
|
|
|
(define (test-and-set! cell)
|
|
(without-interrupts
|
|
(lambda ()
|
|
(if (car cell)
|
|
true
|
|
(begin (set-car! cell true)
|
|
false)))))
|
|
|
|
(display "\nex-3.46\n")
|
|
(display "[answered]\n")
|
|
; See page 207 in 2020 BuJo.
|
|
|
|
(display "\nex-3.47 - semaphore\n")
|
|
|
|
(define (make-semaphore max-count)
|
|
(if (< max-count 1)
|
|
(error "semaphore count must be at least 1")
|
|
(let ((mutex-acquire (make-mutex))
|
|
(mutex-release (make-mutex))
|
|
(count 0))
|
|
(define (acquire)
|
|
(mutex-acquire 'acquire)
|
|
(if (< count max-count)
|
|
(begin
|
|
(mutex-release 'acquire)
|
|
(set! count (+ count 1))
|
|
(mutex-release 'release)
|
|
(mutex-acquire 'release)
|
|
'ok)
|
|
(begin
|
|
(mutex-acquire 'release)
|
|
(acquire))))
|
|
(define (release)
|
|
(mutex-release 'acquire)
|
|
(set! count (- count 1))
|
|
(mutex-release 'release))
|
|
(define (the-semaphore s)
|
|
(cond
|
|
((eq? s 'acquire) (acquire))
|
|
((eq? s 'release) (release))
|
|
((eq? s 'count) count)
|
|
((eq? s 'remaining) (- max-count count))
|
|
(else "operation not supported" s)))
|
|
the-semaphore)))
|
|
|
|
(define s (make-semaphore 3))
|
|
(assert (s 'count) 0)
|
|
(s 'acquire)
|
|
(s 'acquire)
|
|
(s 'acquire)
|
|
(assert (s 'remaining) 0)
|
|
(s 'release)
|
|
(s 'acquire)
|
|
(s 'release)
|
|
(s 'release)
|
|
(s 'release)
|
|
(assert (s 'remaining) 3)
|
|
|
|
(define (make-semaphore max-count)
|
|
(if (< max-count 1)
|
|
(error "semaphore count must be at least 1")
|
|
(let ((cell (list #f))
|
|
(count 0))
|
|
(define (acquire)
|
|
(if (test-and-set! cell)
|
|
(acquire)
|
|
(if (< count max-count)
|
|
(begin
|
|
(set! count (+ count 1))
|
|
(clear! cell)
|
|
'ok)
|
|
(begin
|
|
(clear! cell)
|
|
(acquire)))))
|
|
(define (release)
|
|
(if (test-and-set! cell)
|
|
(release)
|
|
(begin
|
|
(set! count (- count 1))
|
|
(clear! cell))))
|
|
(define (the-semaphore s)
|
|
(cond
|
|
((eq? s 'acquire) (acquire))
|
|
((eq? s 'release) (release))
|
|
((eq? s 'count) count)
|
|
((eq? s 'remaining) (- max-count count))
|
|
(else "operation not supported" s)))
|
|
the-semaphore)))
|
|
|
|
(define s (make-semaphore 3))
|
|
(assert (s 'count) 0)
|
|
(s 'acquire)
|
|
(s 'acquire)
|
|
(s 'acquire)
|
|
(assert (s 'remaining) 0)
|
|
(s 'release)
|
|
(s 'acquire)
|
|
(s 'release)
|
|
(s 'release)
|
|
(s 'release)
|
|
(assert (s 'remaining) 3)
|
|
|
|
(display "\nex-3.48\n")
|
|
|
|
(define (make-account-and-serializer balance)
|
|
(define (withdraw amount)
|
|
(if (>= balance amount)
|
|
(begin (set! balance (- balance amount))
|
|
balance)
|
|
"Insufficient funds"))
|
|
(define (deposit amount)
|
|
(set! balance (+ balance amount))
|
|
balance)
|
|
(let ((balance-serializer (make-serializer)))
|
|
(define (dispatch m)
|
|
(cond ((eq? m 'withdraw) withdraw)
|
|
((eq? m 'deposit) deposit)
|
|
((eq? m 'balance) balance)
|
|
((eq? m 'serializer) balance-serializer)
|
|
(else (error "Unknown request -- MAKE-ACCOUNT"
|
|
m))))
|
|
dispatch))
|
|
|
|
(define (deposit account amount)
|
|
(let ((s (account 'serializer))
|
|
(d (account 'deposit)))
|
|
((s d) amount)))
|
|
|
|
(define (exchange account1 account2)
|
|
(let ((difference (- (account1 'balance)
|
|
(account2 'balance))))
|
|
((account1 'withdraw) difference)
|
|
((account2 'deposit) difference)))
|
|
|
|
(define (serialized-exchange account1 account2)
|
|
(let ((serializer1 (account1 'serializer))
|
|
(serializer2 (account2 'serializer)))
|
|
((serializer1 (serializer2 exchange))
|
|
account1
|
|
account2)))
|
|
|
|
(define a (make-account-and-serializer 100))
|
|
(define b (make-account-and-serializer 40))
|
|
(serialized-exchange a b)
|
|
(assert (a 'balance) 40)
|
|
|