Make the R/W locks somewhat more fair

8 files changed, 76 insertions, 37 deletions

diff --git a/.gitignore b/.gitignore
index 074e3ae..a551058 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,3 +2,4 @@
 /data.db
 /ocicl
 *.fasl
+*~
diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml
index e2f455c..f30fd61 100644
--- a/.pre-commit-config.yaml
+++ b/.pre-commit-config.yaml
@@ -9,11 +9,6 @@ repos:
     entry: ocicl lint
     pass_filenames: true
     files: \.(lisp|asd)$
-  - id: run-testsuite
-    name: run-testsuite
-    language: system
-    entry: ./run-tests.sh
-    pass_filenames: false
 - repo: https://github.com/fsfe/reuse-tool
   rev: v6.1.2
   hooks:
diff --git a/README.md b/README.md
index 22acd03..725382b 100644
--- a/README.md
+++ b/README.md
@@ -2,7 +2,7 @@
 
 A shitty small telegram bot written in Common Lisp.
 
-For running the (very few) tests and other repository maintaining things, run `./run_tests.sh`.  For having an example
+For running the (very few) tests and other repository maintaining things, run `./run-tests.sh`.  For having an example
 way how to launch, see `./launch.sh`.
 
 # Licensing
diff --git a/REUSE.toml b/REUSE.toml
index d2a4142..9d2b746 100644
--- a/REUSE.toml
+++ b/REUSE.toml
@@ -9,7 +9,7 @@ version = 1
 
 [[annotations]]
   label = "Docs or something"
-  path = ["README.md"]
+  path = ["README.md", "TODO.org"]
   SPDX-License-Identifier = "EUPL-1.2"
   SPDX-FileCopyrightText = " 2025 Uko Kokņevičs <perkontevs@gmail.com>"
 
diff --git a/TODO.org b/TODO.org
new file mode 100644
index 0000000..d37a824
--- /dev/null
+++ b/TODO.org
@@ -0,0 +1,4 @@
+* TODO See if I can rely on alexandria more
+* TODO See if I can rely on uiop more
+* TODO See if I can rely on serapeum more
+* TODO Use function-cache to memoize stuff like bot-id, bot-username, get-my-name etc
diff --git a/launch.sh b/launch.sh
index 795db47..f0cd9a9 100755
--- a/launch.sh
+++ b/launch.sh
@@ -5,7 +5,7 @@
 set -eu
 
 # Note this still has the debugger and such things enabled, at this point it makes life easier for me :).  For a more
-# hands-off auto-restarting approach, consider disabling all the fancy SBCL things (similar to ./run_tests.sh) and
+# hands-off auto-restarting approach, consider disabling all the fancy SBCL things (similar to ./run-tests.sh) and
 # putting it in a shell while true loop.
 
 exec sbcl \
diff --git a/src/rw-lock.lisp b/src/rw-lock.lisp
index bd2606c..dc8850d 100644
--- a/src/rw-lock.lisp
+++ b/src/rw-lock.lisp
@@ -3,7 +3,7 @@
 (defpackage :ukkoclot/src/rw-lock
   (:documentation "Implementation of a shared/read-write lock.")
   (:use :c2cl :bt2 :iterate)
-  (:import-from :alexandria :with-gensyms)
+  (: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)
@@ -22,20 +22,22 @@
 (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))
+  (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*))))
@@ -44,38 +46,51 @@
   (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")))
+   :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 unlocked readers has-writer) 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)))
+                           (acquire-lock lock :wait wait)))
+               (incf waiting-readers)
                (with-local-interrupts
                  (when (if wait
                            (iter
-                             (unless has-writer
+                             (unless active-writer
                                (return t))
-                             (condition-wait unlocked lock))
-                           (not has-writer))
-                   (incf readers)
+                             (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 unlocked readers has-writer) rw-lock
+  (with-slots (lock active-readers active-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))))
+      (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)
@@ -95,32 +110,34 @@
 (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
+  (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 (> readers 0) has-writer)
+                             (unless (or (> active-readers 0) active-writer)
                                (return t))
-                             (condition-wait unlocked lock))
-                           (and (zerop readers) (not has-writer)))
-                   (setf has-writer 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 unlocked readers has-writer) rw-lock
+  (with-slots (lock active-readers active-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)))
+      (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)
diff --git a/test/rw-lock.lisp b/test/rw-lock.lisp
index fdb60bd..834d0fd 100644
--- a/test/rw-lock.lisp
+++ b/test/rw-lock.lisp
@@ -2,8 +2,8 @@
 ;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
 (defpackage :ukkoclot/test/rw-lock
   (:documentation "Test-suite for :ukkoclot/src/rw-lock.")
-  (:use :c2cl :fiveam :ukkoclot/src/rw-lock)
-  (:import-from :bt2 :with-timeout))
+  (:use :c2cl :fiveam :iterate :ukkoclot/src/rw-lock)
+  (:import-from :bt2 :join-thread :make-thread :with-timeout))
 (in-package :ukkoclot/test/rw-lock)
 
 (def-suite :ukkoclot/rw-lock)
@@ -69,6 +69,28 @@
     (is-false (acquire-read-lock lock :wait nil))
     (is (rw-lock-p (release-write-lock lock)))))
 
+(test read&write-locks.contention
+  (let ((lock (make-rw-lock))
+        (value 0)
+        reader-threads
+        writer-threads)
+    (flet ((reader-fn () (with-read-lock (lock)
+                           (sleep (random 0.1))
+                           value))
+           (writer-fn () (with-write-lock (lock)
+                           (incf value)
+                           (sleep (random 0.1))
+                           (incf value))))
+      (iter (repeat 100)
+            (push (make-thread #'reader-fn) reader-threads)
+            (sleep (random 0.02))
+            (push (make-thread #'writer-fn) writer-threads)))
+    (iter (for writer-thread in writer-threads)
+          (join-thread writer-thread))
+    (is (every #'evenp
+         (iter (for reader-thread in reader-threads)
+               (collect (join-thread reader-thread)))))))
+
 (test with-read-lock.simple
   (let ((lock (make-rw-lock)))
     (with-read-lock (lock)