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 --- src/rw-lock.lisp | 71 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 44 insertions(+), 27 deletions(-) (limited to 'src') 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) -- cgit v1.2.3