109 lines
3.4 KiB
Racket
109 lines
3.4 KiB
Racket
;; 3.43: In isolation, the exchange procedure permutes two balances,
|
|
;; leaving the third untouched. If all exchange procedures are run
|
|
;; sequentially, then as above, each call of the procedure permutes
|
|
;; two balances. So an arbitrarily long sequence of serialised calls
|
|
;; can only ever permute balances.
|
|
|
|
#lang sicp
|
|
|
|
(#%require rebellion/concurrency/lock)
|
|
|
|
(define (make-mutex-semaphore n)
|
|
(let ((l (make-lock))
|
|
(counter 0))
|
|
(letrec ((try-acquire!
|
|
(lambda ()
|
|
(lock!
|
|
l
|
|
(lambda ()
|
|
(cond ((< counter n)
|
|
(set! counter (+ counter 1))
|
|
#t)
|
|
(else
|
|
#f))))))
|
|
(try-release!
|
|
(lambda ()
|
|
(lock!
|
|
l
|
|
(lambda ()
|
|
(set! counter (- counter 1)))))))
|
|
(lambda (arg)
|
|
(cond ((eq? arg 'acquire!)
|
|
(letrec ((acquire-iter
|
|
(lambda ()
|
|
(if (not (try-acquire!)) (acquire-iter)))))
|
|
(acquire-iter)))
|
|
((eq? arg 'release!)
|
|
(letrec ((release-iter
|
|
(lambda ()
|
|
(if (not (try-release!)) (release-iter)))))
|
|
(release-iter)))
|
|
(else
|
|
(error "mutex-semaphore: invalid argument")))))))
|
|
|
|
(#%require rebellion/concurrency/atomic/boolean)
|
|
|
|
(define (make-atomic-semaphore n)
|
|
(define (make-atomics i)
|
|
(if (= i 0)
|
|
'()
|
|
(cons (make-atomic-boolean #f)
|
|
(make-atomics (- i 1)))))
|
|
(define (try-acquire-one! atomic)
|
|
(atomic-boolean-compare-and-set! atomic #f #t))
|
|
(define (try-release-one! atomic)
|
|
(atomic-boolean-compare-and-set! atomic #t #f))
|
|
(define (until-success op l)
|
|
(if (pair? l)
|
|
(if (not (op (car l)))
|
|
(until-success op (cdr l)))))
|
|
(let ((atomics (make-atomics n)))
|
|
(lambda (arg)
|
|
(cond ((eq? arg 'acquire!)
|
|
(until-success try-acquire-one! atomics))
|
|
((eq? arg 'release!)
|
|
(until-success try-release-one! atomics))
|
|
((eq? arg 'atomics)
|
|
atomics)
|
|
(else
|
|
(error "atomic-semaphore: invalid argument"))))))
|
|
|
|
(#%require (only racket/base module+ thread thread-wait displayln sleep))
|
|
|
|
(module+ test
|
|
(define mutex-semaphore (make-mutex-semaphore 3))
|
|
(define atomic-semaphore (make-atomic-semaphore 3))
|
|
|
|
(#%require racket/trace)
|
|
|
|
(define (for-each f l)
|
|
(if (not (null? l))
|
|
(begin (f (car l))
|
|
(for-each f (cdr l)))))
|
|
|
|
(define (build-threads proc params)
|
|
(if (null? params)
|
|
'()
|
|
(cons (apply proc (car params))
|
|
(build-threads proc (cdr params)))))
|
|
|
|
(define (worker-proc name semaphore delay-time)
|
|
(thread
|
|
(lambda ()
|
|
(semaphore 'acquire!)
|
|
(displayln (list "Acquire" name))
|
|
(sleep delay-time)
|
|
(semaphore 'release!)
|
|
(displayln (list "Release" name)))))
|
|
|
|
(define (test-semaphore semaphore)
|
|
(let* ((worker-params `(("one" ,semaphore 2)
|
|
("two" ,semaphore 5)
|
|
("three" ,semaphore 3)
|
|
("four" ,semaphore 7)))
|
|
(threads (build-threads worker-proc worker-params)))
|
|
(for-each thread-wait threads)))
|
|
|
|
(test-semaphore atomic-semaphore)
|
|
(test-semaphore mutex-semaphore))
|