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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/src/rw-lock
(:documentation "Implementation of a shared/read-write lock.")
(:use :c2cl :bt2 :iterate)
(:import-from :alexandria :whichever :with-gensyms)
(:import-from :com.dieggsy.f-string :enable-f-strings)
(:import-from :sb-sys
:allow-with-interrupts :with-local-interrupts :without-interrupts)
(:export
#:rw-lock
#:rw-lock-p
#:make-rw-lock
#:acquire-read-lock
#:release-read-lock
#:with-read-lock
#:acquire-write-lock
#:release-write-lock
#:with-write-lock))
(in-package :ukkoclot/src/rw-lock)
(eval-when (:compile-toplevel :load-toplevel :execute)
(enable-f-strings))
;; TODO: Use atomic-integer in best-case for read locks to decrease contention
(defstruct (rw-lock (:constructor make-rw-lock%))
(lock nil :type lock :read-only t)
(reader-cv nil :type condition-variable :read-only t)
(writer-cv nil :type condition-variable :read-only t)
(waiting-readers 0 :type (integer 0))
(waiting-writers 0 :type (integer 0))
(active-readers 0 :type (integer 0))
(active-writer nil :type boolean))
(defvar *counter-lock* (make-lock :name "rw-lock::*counter-lock*"))
(defvar *counter* 0)
(defun gen-name ()
"Generate a name for a rw-lock"
(format nil "Read-Write Lock ~A"
(with-lock-held (*counter-lock*)
(incf *counter*))))
(defun make-rw-lock (&key (name (gen-name)))
(check-type name string)
(make-rw-lock%
:lock (make-lock :name #f"{name}'s internal lock")
:reader-cv (make-condition-variable :name #f"{name}'s internal reader-cv")
:writer-cv (make-condition-variable :name #f"{name}'s internal writer-cv")))
(defun wakeup-waiters (rw-lock)
;; NOTE: RW-LOCK-LOCK HAS TO BE TAKEN!
(declare (type rw-lock rw-lock))
(with-slots (reader-cv writer-cv waiting-readers waiting-writers) rw-lock
(cond
((zerop waiting-readers) (condition-notify writer-cv))
((zerop waiting-writers) (condition-broadcast reader-cv))
(t (whichever (condition-notify writer-cv)
(condition-broadcast reader-cv))))))
(defun acquire-read-lock (rw-lock &key (wait t))
;; TODO: timeout
(check-type rw-lock rw-lock)
(with-slots (lock reader-cv active-readers active-writer waiting-readers) rw-lock
(let ((lock-acquired))
(without-interrupts
(unwind-protect
(when (setf lock-acquired
(allow-with-interrupts
(acquire-lock lock :wait wait)))
(incf waiting-readers)
(with-local-interrupts
(when (if wait
(iter
(unless active-writer
(return t))
(condition-wait reader-cv lock))
(not active-writer))
(incf active-readers)
t)))
(when lock-acquired
(decf waiting-readers)
(release-lock lock)))))))
(defun release-read-lock (rw-lock)
(check-type rw-lock rw-lock)
(with-slots (lock active-readers active-writer) rw-lock
(with-lock-held (lock)
(assert (> active-readers 0) nil "Trying to release a read lock that's not taken!")
(decf active-readers)
(when (zerop active-readers)
(wakeup-waiters rw-lock))))
rw-lock)
(defmacro with-read-lock ((rw-lock) &body body)
;; TODO: timeout
(with-gensyms (lock-acquired lock-value)
`(let ((,lock-acquired)
(,lock-value ,rw-lock))
(without-interrupts
(unwind-protect
(when (setf ,lock-acquired
(allow-with-interrupts
(acquire-read-lock ,lock-value)))
(with-local-interrupts ,@body))
(when ,lock-acquired
(release-read-lock ,lock-value)))))))
(defun acquire-write-lock (rw-lock &key (wait t))
;; TODO: timeout
(check-type rw-lock rw-lock)
(with-slots (lock writer-cv active-readers active-writer waiting-writers) rw-lock
(let ((lock-acquired))
(without-interrupts
(unwind-protect
(when (setf lock-acquired
(allow-with-interrupts
(acquire-lock lock :wait wait)))
(incf waiting-writers)
(with-local-interrupts
(when (if wait
(iter
(unless (or (> active-readers 0) active-writer)
(return t))
(condition-wait writer-cv lock))
(and (zerop active-readers) (not active-writer)))
(setf active-writer t)
t)))
(when lock-acquired
(decf waiting-writers)
(release-lock lock)))))))
(defun release-write-lock (rw-lock)
(check-type rw-lock rw-lock)
(with-slots (lock active-readers active-writer) rw-lock
(with-lock-held (lock)
(assert active-writer nil "Trying to release a write lock that's not taken!")
(setf active-writer nil)
(wakeup-waiters rw-lock)))
rw-lock)
(defmacro with-write-lock ((rw-lock) &body body)
;; TODO: timeout
(with-gensyms (lock-acquired lock-value)
`(let ((,lock-acquired)
(,lock-value ,rw-lock))
(without-interrupts
(unwind-protect
(when (setf ,lock-acquired
(allow-with-interrupts
(acquire-write-lock ,lock-value)))
(with-local-interrupts ,@body))
(when ,lock-acquired
(release-write-lock ,lock-value)))))))
|
