;;; -*- Mode: Scheme -*-

;;;; Recursive Mutices (Mutexes?) for Scheme48
;;;; (Not an example of the stubber; just needed by unix-fd.scm.)

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; This differs from Scheme48's built-in LOCKS structure in that a
;;; thread may safely lock a mutex that it already has locked.  Also,
;;; this implementation signals an error if a thread attempts to unlock
;;; a mutex that it does not own, unlike Scheme48's code.

;;; Bug: This does not deal with mutex held by a completed thread.

(define-synchronized-record-type recursive-mutex <recursive-mutex>
    (%make-recursive-mutex owner depth queue)
    (owner)
    recursive-mutex?
  (owner recursive-mutex.owner set-recursive-mutex.owner!)
  (depth recursive-mutex.depth set-recursive-mutex.depth!)
  (queue recursive-mutex.queue))

(define (make-recursive-mutex)
  (%make-recursive-mutex #f 0 (make-queue)))

(define (recursive-mutex/lock mutex)
  (with-new-proposal (retry)
    (let ()
      (define (attempt-lock)
        (if (maybe-commit)
            (set-recursive-mutex.depth!
             mutex
             (+ 1 (recursive-mutex.depth mutex)))
            (retry)))
      (let ((owner (recursive-mutex.owner mutex)))
        (cond ((eq? owner (current-thread))
               (attempt-lock))
              ((eq? owner #f)
               (set-recursive-mutex.owner! mutex (current-thread))
               (attempt-lock))
              (else
               (if (not (maybe-commit-and-block-on-queue
                         (recursive-mutex.queue mutex)))
                   (retry))))))))

(define (recursive-mutex/unlock mutex)
  (with-new-proposal (retry)
    (if (not (eq? (recursive-mutex.owner mutex) (current-thread)))
        (begin
          (maybe-commit)
          (error "Can't unlock someone else's mutex:" mutex)))
    (let ((depth* (+ -1 (recursive-mutex.depth mutex))))
      (if (zero? depth*)
          (cond ((maybe-dequeue-thread! (recursive-mutex.queue mutex))
                 => (lambda (thread)
                      (set-recursive-mutex.owner! mutex thread)
                      (set-recursive-mutex.depth! mutex 1)
                      (if (not (maybe-commit-and-make-ready thread))
                          (retry))))
                (else
                 (set-recursive-mutex.owner! mutex #f)
                 (set-recursive-mutex.depth! mutex 0)
                 (if (not (maybe-commit))
                     (retry))))
          (begin
            (set-recursive-mutex.depth! mutex depth*)
            (if (not (maybe-commit))
                (error "Mutex modified by non-owner:" mutex)))))))

(define (with-recursive-mutex-locked mutex procedure)
  (let ((already? #f))
    (dynamic-wind
      (lambda ()
        (if already?
            (error "Re-entering mutex-locked region."))
        (set! already? #t)
        (recursive-mutex/lock mutex))
      procedure
      (lambda ()
        (recursive-mutex/unlock mutex)))))