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
|
;; 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 :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: Get rid of broadcasting for writers, instead have separate condvars
;; TODO: Make it a bit more fair, 50% chance of waking up writers or readers
;; 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)
(unlocked nil :type condition-variable :read-only t)
(readers 0 :type integer)
(has-writer nil :type boolean))
(defvar *counter-lock* (make-lock :name "rw-lock::*counter-lock*"))
(defvar *counter* 0)
(defun gen-name ()
(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")
:unlocked (make-condition-variable :name #f"{name}'s internal unlocked")))
(defun acquire-read-lock (rw-lock &key (wait t))
;; TODO: timeout
(check-type rw-lock rw-lock)
(with-slots (lock unlocked readers has-writer) rw-lock
(let ((lock-acquired))
(without-interrupts
(unwind-protect
(when (setf lock-acquired
(allow-with-interrupts
(acquire-lock lock :wait wait)))
(with-local-interrupts
(when (if wait
(iter
(unless has-writer
(return t))
(condition-wait unlocked lock))
(not has-writer))
(incf readers)
t)))
(when lock-acquired
(release-lock lock)))))))
(defun release-read-lock (rw-lock)
(check-type rw-lock rw-lock)
(with-slots (lock unlocked readers has-writer) rw-lock
(with-lock-held (lock)
(assert (> readers 0) nil "Trying to release a read lock that's not taken!")
(decf readers)
(when (zerop readers)
(condition-broadcast unlocked))))
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 unlocked readers has-writer) rw-lock
(let ((lock-acquired))
(without-interrupts
(unwind-protect
(when (setf lock-acquired
(allow-with-interrupts
(acquire-lock lock :wait wait)))
(with-local-interrupts
(when (if wait
(iter
(unless (or (> readers 0) has-writer)
(return t))
(condition-wait unlocked lock))
(and (zerop readers) (not has-writer)))
(setf has-writer t)
t)))
(when lock-acquired
(release-lock lock)))))))
(defun release-write-lock (rw-lock)
(check-type rw-lock rw-lock)
(with-slots (lock unlocked readers has-writer) rw-lock
(with-lock-held (lock)
(assert has-writer nil "Trying to release a write lock that's not taken!")
(setf has-writer nil)
(condition-broadcast unlocked)))
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)))))))
|
