From 09babc46d92c4a1b85d619a4935459f7d6125c03 Mon Sep 17 00:00:00 2001 From: Uko Kokņevičs Date: Sun, 19 Oct 2025 07:30:03 +0300 Subject: Add a read-write lock & a testsuite --- .pre-commit-config.yaml | 5 ++ ocicl.csv | 4 ++ run-tests.sh | 12 +++++ src/rw-lock.lisp | 136 ++++++++++++++++++++++++++++++++++++++++++++++++ test/all.lisp | 28 ++++++++++ test/rw-lock.lisp | 79 ++++++++++++++++++++++++++++ ukkoclot.asd | 4 +- 7 files changed, 267 insertions(+), 1 deletion(-) create mode 100755 run-tests.sh create mode 100644 src/rw-lock.lisp create mode 100644 test/all.lisp create mode 100644 test/rw-lock.lisp diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index f30fd61..e2f455c 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -9,6 +9,11 @@ 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/ocicl.csv b/ocicl.csv index ecc65f6..44ae424 100644 --- a/ocicl.csv +++ b/ocicl.csv @@ -36,6 +36,7 @@ fast-http, ghcr.io/ocicl/fast-http@sha256:44e98b5239c0ded4921dc0b04ae272cff00583 fast-http-test, ghcr.io/ocicl/fast-http@sha256:44e98b5239c0ded4921dc0b04ae272cff00583d93797a657543db782979eb50c, fast-http-20240503-2232fc9/fast-http-test.asd fast-io, ghcr.io/ocicl/fast-io@sha256:7ba35a0eddf00b3c25656b3c5a93e95460f6cb8f807afbc04ef4f50076d95aff, fast-io-20240503-a4c5ad6/fast-io.asd fast-io-test, ghcr.io/ocicl/fast-io@sha256:7ba35a0eddf00b3c25656b3c5a93e95460f6cb8f807afbc04ef4f50076d95aff, fast-io-20240503-a4c5ad6/fast-io-test.asd +fiveam, ghcr.io/ocicl/fiveam@sha256:e283043dc8d31e8df2b214465cf5a06ea07bdbea10e600a40e17aaf9518226ac, fiveam-20240928-e43d6c8/fiveam.asd flexi-streams, ghcr.io/ocicl/flexi-streams@sha256:95005b06a8a95c82780c75ead53810bcb273d07fcf5fe76b527f1856df9923f2, flexi-streams-20240503-4951d57/flexi-streams.asd flexi-streams-test, ghcr.io/ocicl/flexi-streams@sha256:95005b06a8a95c82780c75ead53810bcb273d07fcf5fe76b527f1856df9923f2, flexi-streams-20240503-4951d57/flexi-streams-test.asd float-features, ghcr.io/ocicl/float-features@sha256:64922efd92a08670cf8292ea56dfff29c577d36d8a7f7576cea0c031805c52d2, float-features-20250813-cd5dab0/float-features.asd @@ -60,6 +61,7 @@ log4cl-examples, ghcr.io/ocicl/log4cl@sha256:bd33f6e5ad346892e852492e7101bc18d26 log4cl.log4slime, ghcr.io/ocicl/log4cl@sha256:bd33f6e5ad346892e852492e7101bc18d263f9ef2ba6192178568d1b20337112, log4cl-20240503-fe3da51/log4cl.log4slime.asd log4cl.log4sly, ghcr.io/ocicl/log4cl@sha256:bd33f6e5ad346892e852492e7101bc18d263f9ef2ba6192178568d1b20337112, log4cl-20240503-fe3da51/log4cl.log4sly.asd multilang-documentation-utils, ghcr.io/ocicl/documentation-utils@sha256:b2a1b3f3bcd1a738af85ae2b0168d408c177661eab6d6bbebb254e394d983f54, documentation-utils-20230511-98630dd/multilang-documentation-utils.asd +net.didierverna.asdf-flv, ghcr.io/ocicl/net.didierverna.asdf-flv@sha256:e5cd087d41cf24302a92d9bac426a925f8868b554be2414c0f012c961e3ddb8c, asdf-flv-20240503-3f1de41/net.didierverna.asdf-flv.asd parse-declarations-1.0, ghcr.io/ocicl/parse-declarations-1.0@sha256:9305fa9624205b16fd1fc51cb1cc4282a18e50eee9ac75b66a14f6f2c5df9518, parse-declarations-20240503-549aebb/parse-declarations-1.0.asd parse-number, ghcr.io/ocicl/parse-number@sha256:11f3f9f512871e1f96cea6b8260aa3610e34e8fd7272bbcdb210fd3c5dd8025c, parse-number-20240503-cb9e487/parse-number.asd proc-parse, ghcr.io/ocicl/proc-parse@sha256:0880f9acb35eb9efbe1f77a981e36e84e8f29a22b14f680c7686eb381fa87bd6, proc-parse-20240503-3afe2b7/proc-parse.asd @@ -89,6 +91,8 @@ trivia.ppcre, ghcr.io/ocicl/trivia@sha256:51db74757bc31ceaf3a643914a8ffa87825799 trivia.quasiquote, ghcr.io/ocicl/trivia@sha256:51db74757bc31ceaf3a643914a8ffa87825799097dea4912650e6ac62bed5209, trivia-20240904-4383dd8/trivia.quasiquote.asd trivia.test, ghcr.io/ocicl/trivia@sha256:51db74757bc31ceaf3a643914a8ffa87825799097dea4912650e6ac62bed5209, trivia-20240904-4383dd8/trivia.test.asd trivia.trivial, ghcr.io/ocicl/trivia@sha256:51db74757bc31ceaf3a643914a8ffa87825799097dea4912650e6ac62bed5209, trivia-20240904-4383dd8/trivia.trivial.asd +trivial-backtrace, ghcr.io/ocicl/trivial-backtrace@sha256:89a3138695bb767c50001402fad60dacfc1e867e4e3d3579cc6f636d3e29a51c, trivial-backtrace-20240503-7f90b4a/trivial-backtrace.asd +trivial-backtrace-test, ghcr.io/ocicl/trivial-backtrace@sha256:89a3138695bb767c50001402fad60dacfc1e867e4e3d3579cc6f636d3e29a51c, trivial-backtrace-20240503-7f90b4a/trivial-backtrace-test.asd trivial-cltl2, ghcr.io/ocicl/trivial-cltl2@sha256:69470b4f6469314799074b9d944050dc4bcb67d5cbb2ba32c7a8899bb492f04e, trivial-cltl2-20230809-2ada872/trivial-cltl2.asd trivial-features, ghcr.io/ocicl/trivial-features@sha256:e278e24d39060fc7d3715531b16ddd9ab7f93f22ade53e436c0b86dbae3aa065, trivial-features-1.0/trivial-features.asd trivial-features-tests, ghcr.io/ocicl/trivial-features@sha256:e278e24d39060fc7d3715531b16ddd9ab7f93f22ade53e436c0b86dbae3aa065, trivial-features-1.0/trivial-features-tests.asd diff --git a/run-tests.sh b/run-tests.sh new file mode 100755 index 0000000..f8338b3 --- /dev/null +++ b/run-tests.sh @@ -0,0 +1,12 @@ +#!/bin/sh +# SPDX-License-Identifier: EUPL-1.2 +# SPDX-FileCopyrightText: 2025 Uko Kokņevičs + +set -eu + +exec sbcl \ + --disable-ldb --lose-on-corruption \ + --noinform --noprint --non-interactive \ + --eval '(asdf:load-system :ukkoclot/test/all)' \ + --eval '(setf ukkoclot/test/all:*should-quit* t)' \ + --eval '(asdf:test-system :ukkoclot)' 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 +(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))))))) diff --git a/test/all.lisp b/test/all.lisp new file mode 100644 index 0000000..b0a731b --- /dev/null +++ b/test/all.lisp @@ -0,0 +1,28 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs +(defpackage :ukkoclot/test/all + (:documentation "Main test runner package.") + (:use :c2cl :fiveam + :ukkoclot/test/rw-lock) + (:import-from :bt2 :with-timeout) + (:import-from :uiop) + (:export #:*should-quit* #:run-tests)) +(in-package :ukkoclot/test/all) + +(defvar *should-quit* nil + "Bind as true if `run-tests' should exit the process with 0 or 1. + +Useful for CI.") + +;; TODO: Maybe I should signal on failure instead :thinking: +(defun run-tests () + "Run all tests" + (with-timeout (100) + (let ((status (run-all-tests))) + (when *should-quit* + (format t "~2&BTW Ignore the fatal ERROR condition below") + (cond + (status (format t "~&!GREAT SUCCESS!~2%") + (uiop:quit 0)) + (t (format t "~&!!! TESTS R FUCKED MATE !!!~2%") + (uiop:quit 1))))))) diff --git a/test/rw-lock.lisp b/test/rw-lock.lisp new file mode 100644 index 0000000..4460398 --- /dev/null +++ b/test/rw-lock.lisp @@ -0,0 +1,79 @@ +;; SPDX-License-Identifier: EUPL-1.2 +;; 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)) +(in-package :ukkoclot/test/rw-lock) + +(def-suite :ukkoclot/rw-lock) +(in-suite :ukkoclot/rw-lock) + +(test rw-lock.typep + (is (typep (make-rw-lock) 'rw-lock))) + +(test rw-lock-p + (is (rw-lock-p (make-rw-lock)))) + +(test acquire-read-lock.no-contention + (with-timeout (5) + (let ((lock (make-rw-lock))) + (is-true (acquire-read-lock lock :wait t)) + (is (rw-lock-p (release-read-lock lock))) + (is-true (acquire-read-lock lock :wait nil)) + (is (rw-lock-p (release-read-lock lock)))))) + +(test acquire-read-lock.multiple + (with-timeout (5) + (let ((lock (make-rw-lock))) + (is-true (acquire-read-lock lock :wait t)) + (is-true (acquire-read-lock lock :wait nil)) + (is-true (acquire-read-lock lock :wait t)) + (is (rw-lock-p (release-read-lock lock))) + (is (rw-lock-p (release-read-lock lock))) + (is (rw-lock-p (release-read-lock lock)))))) + +(test acquire-write-lock.no-contention + (let ((lock (make-rw-lock))) + (is-true (acquire-write-lock lock :wait nil)) + (is (rw-lock-p (release-write-lock lock))) + (is-true (acquire-write-lock lock :wait nil)) + (is (rw-lock-p (release-write-lock lock))))) + +(test acquire-write-lock.contention + (let ((lock (make-rw-lock))) + (is-true (acquire-write-lock lock :wait nil)) + (is-false (acquire-write-lock lock :wait nil)) + (is (rw-lock-p (release-write-lock lock))))) + +(test acquire-read&write-lock.contention + (let ((lock (make-rw-lock))) + (is-true (acquire-read-lock lock :wait nil)) + (is-true (acquire-read-lock lock :wait nil)) + (is-false (acquire-write-lock lock :wait nil)) + (is (rw-lock-p (release-read-lock lock))) + (is (rw-lock-p (release-read-lock lock))) + (is-true (acquire-write-lock lock :wait nil)) + (is-false (acquire-read-lock lock :wait nil)) + (is (rw-lock-p (release-write-lock lock))))) + +(test with-read-lock.simple + (let ((lock (make-rw-lock))) + (with-read-lock (lock) + (is-true (acquire-read-lock lock :wait nil)) + (is (rw-lock-p (release-read-lock lock))) + (is-false (acquire-write-lock lock :wait nil))) + (is-true (acquire-read-lock lock :wait nil)) + (is (rw-lock-p (release-read-lock lock))) + (is-true (acquire-write-lock lock :wait nil)) + (is (rw-lock-p (release-write-lock lock))))) + +(test with-write-lock.simple + (let ((lock (make-rw-lock))) + (with-write-lock (lock) + (is-false (acquire-read-lock lock :wait nil)) + (is-false (acquire-write-lock lock :wait nil))) + (is-true (acquire-read-lock lock :wait nil)) + (is (rw-lock-p (release-read-lock lock))) + (is-true (acquire-write-lock lock :wait nil)) + (is (rw-lock-p (release-write-lock lock))))) diff --git a/ukkoclot.asd b/ukkoclot.asd index fd7f14e..339a208 100644 --- a/ukkoclot.asd +++ b/ukkoclot.asd @@ -11,11 +11,13 @@ :description "ukkoclot: Ukko's shitty telegram bot" :long-description #.(uiop:read-file-string (uiop:subpathname *load-pathname* "README.md")) :depends-on (:ukkoclot/src/main) - ;; TODO: :in-order-to ((test-op (test-op ukkoclot-test))) + :in-order-to ((test-op (load-op :ukkoclot/test/all))) + :perform (test-op (o c) (symbol-call :ukkoclot/test/all :run-tests))) (register-system-packages :ukkoclot/src/config '(:conf)) (register-system-packages :ukkoclot/src/main '(:ukkoclot)) +(register-system-packages :bordeaux-threads '(:bt2)) (register-system-packages :closer-mop '(:c2cl)) (register-system-packages :dexador '(:dex)) (register-system-packages :log4cl '(:log)) -- cgit v1.2.3