1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Locks (= semaphores)
; Each lock has:
; The owning thread, or #f if not locked. We use the owning thread instead
; of #t as an aid to debugging.
; A queue of waiting threads
(define-synchronized-record-type lock :lock
(really-make-lock owner queue uid)
(owner)
lock?
(owner lock-owner set-lock-owner!)
(queue lock-queue)
(uid lock-uid)) ; for debugging
(define lock-uid (list 0))
(define (next-uid)
(atomically
(let ((uid (provisional-car lock-uid)))
(provisional-set-car! lock-uid (+ uid 1))
uid)))
(define (make-lock)
(really-make-lock #f (make-queue) (next-uid)))
(define (obtain-lock lock)
(with-new-proposal (lose)
(or (cond ((lock-owner lock)
(maybe-commit-and-block-on-queue (lock-queue lock)))
(else
(set-lock-owner! lock (current-thread))
(maybe-commit)))
(lose))))
; Returns #T if the lock is obtained and #F if not. Doesn't block.
(define (maybe-obtain-lock lock)
(with-new-proposal (lose)
(cond ((lock-owner lock) ; no need to commit - we have only done
#f) ; a single read
(else
(set-lock-owner! lock (current-thread))
(or (maybe-commit)
(lose))))))
; Returns #t if the lock has no new owner.
(define (release-lock lock)
(with-new-proposal (lose)
(let ((next (maybe-dequeue-thread! (lock-queue lock))))
(cond (next
(set-lock-owner! lock next)
(or (maybe-commit-and-make-ready next)
(lose)))
(else
(set-lock-owner! lock #f)
(or (maybe-commit)
(lose)))))))
(define (with-lock lock thunk)
(dynamic-wind
(lambda () (obtain-lock lock))
thunk
(lambda () (release-lock lock))))
|
