1 files changed, 136 insertions, 0 deletions

diff --git a/src/rw-lock.lisp b/src/rw-lock.lisp
new file mode 100644
index 0000000..b32d3d0
--- /dev/null
+++ b/src/rw-lock.lisp
@@ -0,0 +1,136 @@
+;; 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)
+      (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)
+      (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)))))))