chickadee » srfi-18 » mutex-lock!

If the mutex is currently locked, the current thread waits until the mutex is unlocked, or until the timeout is reached if timeout is supplied. If the timeout is reached, mutex-lock! returns #f. Otherwise, the state of the mutex is changed as follows:

• if thread is #f the mutex becomes locked/not-owned,
• otherwise, let T be thread (or the current thread if thread is not supplied),
  • if T is terminated the mutex becomes unlocked/abandoned,
  • otherwise mutex becomes locked/owned with T as the owner.

After changing the state of the mutex, an "abandoned mutex exception" is raised if the mutex was unlocked/abandoned before the state change, otherwise mutex-lock! returns #t. It is not an error if the mutex is owned by the current thread (but the current thread will have to wait).

    ; an implementation of a mailbox object of depth one; this
    ; implementation does not behave well in the presence of forced
    ; thread terminations using thread-terminate! (deadlock can occur
    ; if a thread is terminated in the middle of a put! or get! operation)
 
    (define (make-empty-mailbox)
      (let ((put-mutex (make-mutex)) ; allow put! operation
            (get-mutex (make-mutex))
            (cell #f))
 
        (define (put! obj)
          (mutex-lock! put-mutex #f #f) ; prevent put! operation
          (set! cell obj)
          (mutex-unlock! get-mutex)) ; allow get! operation
 
        (define (get!)
          (mutex-lock! get-mutex #f #f) ; wait until object in mailbox
          (let ((result cell))
            (set! cell #f) ; prevent space leaks
            (mutex-unlock! put-mutex) ; allow put! operation
            result))
 
        (mutex-lock! get-mutex #f #f) ; prevent get! operation
 
        (lambda (msg)
          (case msg
            ((put!) put!)
            ((get!) get!)
            (else (error "unknown message"))))))
 
    (define (mailbox-put! m obj) ((m 'put!) obj))
    (define (mailbox-get! m) ((m 'get!)))
 
    ; an alternate implementation of thread-sleep!
 
    (define (sleep! timeout)
      (let ((m (make-mutex)))
        (mutex-lock! m #f #f)
        (mutex-lock! m timeout #f)))
 
    ; a procedure that waits for one of two mutexes to unlock
 
    (define (lock-one-of! mutex1 mutex2)
      ; this procedure assumes that neither mutex1 or mutex2
      ; are owned by the current thread
      (let ((ct (current-thread))
            (done-mutex (make-mutex)))
        (mutex-lock! done-mutex #f #f)
        (let ((t1 (thread-start!
                   (make-thread
                    (lambda ()
                      (mutex-lock! mutex1 #f ct)
                      (mutex-unlock! done-mutex)))))
              (t2 (thread-start!
                   (make-thread
                    (lambda ()
                      (mutex-lock! mutex2 #f ct)
                      (mutex-unlock! done-mutex))))))
          (mutex-lock! done-mutex #f #f)
          (thread-terminate! t1)
          (thread-terminate! t2)
          (if (eq? (mutex-state mutex1) ct)
              (begin
                (if (eq? (mutex-state mutex2) ct)
                    (mutex-unlock! mutex2)) ; don't lock both
                mutex1)
              mutex2))))