From 81e69b85c8bcd9ab8da04c01bc30aaea129b7ff9 Mon Sep 17 00:00:00 2001 From: Uko Kokņevičs Date: Sun, 19 Oct 2025 10:12:04 +0300 Subject: Make the R/W locks somewhat more fair --- .gitignore | 1 + .pre-commit-config.yaml | 5 ---- README.md | 2 +- REUSE.toml | 2 +- TODO.org | 4 +++ launch.sh | 2 +- src/rw-lock.lisp | 71 ++++++++++++++++++++++++++++++------------------- test/rw-lock.lisp | 26 ++++++++++++++++-- 8 files changed, 76 insertions(+), 37 deletions(-) create mode 100644 TODO.org 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 " 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 (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) -- cgit v1.2.3