57 lines
1.6 KiB
Scheme
57 lines
1.6 KiB
Scheme
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
; Locks (= semaphores)
|
||
|
|
|
||
|
|
; Each lock has:
|
||
|
|
; The owning thread's uid, or #f if not locked. The uid can be used
|
||
|
|
; to aid debugging without introducing the overhead of a weak pointer
|
||
|
|
; to the actual thread (a non-weak pointer would introduce an unfortunate
|
||
|
|
; circularity involving the locks and finalizers of ports).
|
||
|
|
; A queue of waiting threads
|
||
|
|
|
||
|
|
(define-record-type lock :lock
|
||
|
|
(really-make-lock owner-uid queue uid)
|
||
|
|
lock?
|
||
|
|
(owner-uid lock-owner-uid set-lock-owner-uid!)
|
||
|
|
(queue lock-queue)
|
||
|
|
(uid lock-uid)) ; for debugging
|
||
|
|
|
||
|
|
(define *lock-uid* 0)
|
||
|
|
|
||
|
|
(define (make-lock)
|
||
|
|
(let ((uid *lock-uid*))
|
||
|
|
(set! *lock-uid* (+ uid 1))
|
||
|
|
(really-make-lock #f (make-thread-queue) uid)))
|
||
|
|
|
||
|
|
(define (obtain-lock lock)
|
||
|
|
(with-interrupts-inhibited
|
||
|
|
(lambda ()
|
||
|
|
(if (lock-owner-uid lock)
|
||
|
|
(begin
|
||
|
|
(enqueue-thread! (lock-queue lock) (current-thread))
|
||
|
|
(block))
|
||
|
|
(set-lock-owner-uid! lock (thread-uid (current-thread)))))))
|
||
|
|
|
||
|
|
(define (maybe-obtain-lock lock)
|
||
|
|
(with-interrupts-inhibited
|
||
|
|
(lambda ()
|
||
|
|
(if (lock-owner-uid lock)
|
||
|
|
#f
|
||
|
|
(begin
|
||
|
|
(set-lock-owner-uid! lock (thread-uid (current-thread)))
|
||
|
|
#t)))))
|
||
|
|
|
||
|
|
; Returns #t if the lock has no new owner.
|
||
|
|
|
||
|
|
(define (release-lock lock)
|
||
|
|
(with-interrupts-inhibited
|
||
|
|
(lambda ()
|
||
|
|
(let ((queue (lock-queue lock)))
|
||
|
|
(if (thread-queue-empty? queue)
|
||
|
|
(begin
|
||
|
|
(set-lock-owner-uid! lock #f)
|
||
|
|
#t)
|
||
|
|
(let ((next (dequeue-thread! queue)))
|
||
|
|
(set-lock-owner-uid! lock (thread-uid next))
|
||
|
|
(make-ready next)
|
||
|
|
#f))))))
|