Make the R/W locks somewhat more fair

1 files changed, 44 insertions, 27 deletions

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)