Add missing file for exercise 3.43
This commit is contained in:
parent
c6ccffce8a
commit
1d4447ad2b
|
@ -0,0 +1,108 @@
|
|||
;; 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))
|
Loading…
Reference in New Issue