SICP/ex-3_46-49.scm

(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 - exchange without deadlocks\n")

(define (make-account-and-serializer balance number)
  (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)
            ((eq? m 'number) number)
            (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)))
    (if (< (account1 'number) (account2 'number))
      ((serializer1 (serializer2 exchange)) account1 account2)
      ((serializer2 (serializer1 exchange)) account1 account2))))

(define a (make-account-and-serializer 100 1))
(define b (make-account-and-serializer 40 2))
(serialized-exchange a b)
(assert (a 'balance) 40)

; Assuming number(a) = 1 and number(b) = 2 the new procedure forces the lock
; for a to be taken before the one for b. This means the process that gets a
; first is able to complete because the second process cannot lock b.

(display "\nex-3.49\n")
(display "[answered]")

; If we have a procedure that takes and account and then executes exchanges for
; a list of other accounts related to that account. In a situation where two
; accounts reference each other we might again run into a deadlock. That is a bad
; example, but I cannot think of a better one right now.