Read-Write Locks

doc/reference/misc.md

@@ -1292,6 +1292,77 @@ limit: 0/3
 ```
 :::
 
+## Read/Write Locks
+
+The `:std/misc/rwlock` include an implementation of read/write locks.
+
+The implementation queues additional readers when there are writers
+waiting, so that no new readers will acquire the lock until all
+writers are done.  This ensures that writers cannot be starved, which
+is a very important property for read/write locks.
+
+::: tip To use bindings from this module:
+```scheme
+(import :std/misc/rwlock)
+```
+:::
+
+### make-rwlock
+```scheme
+(make-rwlock [name 'rwlock]) -> rwlock
+```
+
+Creates a (named) read-write lock.
+
+### rwlock?
+```scheme
+(rwlock? obj) -> bool
+```
+
+Type predicate for rwlocks.
+
+### rwlock-read-lock!
+```scheme
+(rwlock-read-lock! rwlock)
+```
+
+Acquires a read lock on `rwlock`; multiple readers can acquire the read lock simultaneously.
+
+### rwlock-read-unlock!
+```scheme
+(rwlock-read-unlock! rwlock)
+```
+
+Releases a read lock on `rwlock`.
+
+### rwlock-write-lock!
+```scheme
+(rwlock-write-lock! rwlock)
+```
+
+Acquires an exclusive write lock on `rwlock`.
+
+### rwlock-write-unlock!
+```scheme
+(rwlock-write-unlock! rwlock)
+```
+
+Release an exclusive write lock on `rwlock`.
+
+### with-read-lock
+```scheme
+(with-read-lock rwlock proc)
+```
+
+Evaluates `proc` while holding a read lock on `rwlock` and returns the result.
+
+### with-write-lock
+```scheme
+(with-write-lock rwlock proc)
+```
+
+Evaluates `proc` while holding a write lock on `rwlock` and returns the result.
+
 
 ## Deques
 ::: tip To use the bindings from this module:

src/std/build-deps

@@ -877,6 +877,7 @@
    std/misc/symbol
    std/sort
    std/srfi/1))
+ (std/misc/rwlock "misc/rwlock" (gerbil/core gerbil/gambit/threads std/sugar))
  (std/protobuf/io
   "protobuf/io"
   (gerbil/core

src/std/build-spec.ss

@@ -279,6 +279,7 @@
     "misc/hash"
     "misc/path"
     "misc/symbol"
+    "misc/rwlock"
     ;; :std/protobuf
     "protobuf/io"
     "protobuf/macros"

src/std/misc/rwlock-test.ss

@@ -0,0 +1,103 @@
+;;; -*- Gerbil -*-
+;;; © vyzo
+;;; read-write lock test
+(import :gerbil/gambit/threads
+        :gerbil/gambit/os
+        :std/test
+        :std/iter
+        ./rwlock
+        ./barrier)
+(export rwlock-test)
+
+(def rwlock-test
+  (test-suite "read/write locks"
+    (test-case "many readers"
+      (let* ((readers 100)
+             (threads [])
+             (barrier (make-barrier readers))
+             (rwlock (make-rwlock))
+             (wait-time .01)
+             (start (current-time)))
+        (for (i (in-range readers))
+          (let (thread (spawn (lambda ()
+                                (rwlock-read-lock! rwlock)
+                                (barrier-post! barrier)
+                                ;; wait till everyone has read locked
+                                (barrier-wait! barrier)
+                                (thread-sleep! wait-time)
+                                (rwlock-read-unlock! rwlock))))
+            (set! threads (cons thread threads))))
+        (for (thread threads)
+          (check (thread-join! thread) => #!void))
+        (let (end (current-time))
+          ;; if it successfully parrelized the reader access it must have taken
+          ;; at most  wait-time with some fuzz.
+          (check (- (time->seconds end) (time->seconds start))
+                 ? (lambda (dt) (<= dt (* 1.2 wait-time)))))))
+    (test-case "many writers"
+      (let* ((writers 100)
+             (threads [])
+             (barrier (make-barrier writers))
+             (rwlock (make-rwlock))
+             (wait-time .01)
+             (start (current-time)))
+        (for (i (in-range writers))
+          (let (thread (spawn (lambda ()
+                                (barrier-post! barrier)
+                                ;; wait till everyone has started
+                                (barrier-wait! barrier)
+                                ;; lock
+                                (rwlock-write-lock! rwlock)
+                                ;; wait a little and unlock
+                                (thread-sleep! wait-time)
+                                (rwlock-write-unlock! rwlock))))
+            (set! threads (cons thread threads))))
+        (for (thread threads)
+          (check (thread-join! thread) => #!void))
+        (let (end (current-time))
+          ;; if it successfully serialized the writer access it must have taken
+          ;; at least writers * wait-time.
+          (check (- (time->seconds end) (time->seconds start))
+                 ? (lambda (dt) (>= dt (* writers wait-time)))))))
+    (test-case "many readers and one writer"
+      (let* ((readers 100)
+             (reader-threads [])
+             (writer-thread #f)
+             (rwlock (make-rwlock))
+             (reader-wait-time .05)
+             (writer-wait-time .1)
+             (start (current-time)))
+        ;; spawn half the readers before the writer and the other half after
+        (for (i (in-range (/ readers 2)))
+          (let (thread (spawn (lambda ()
+                                (rwlock-read-lock! rwlock)
+                                (thread-sleep! reader-wait-time)
+                                (rwlock-read-unlock! rwlock))))
+            (set! reader-threads (cons thread reader-threads))))
+        (set! writer-thread
+          (spawn (lambda ()
+                   (rwlock-write-lock! rwlock)
+                   (thread-sleep! writer-wait-time)
+                   (rwlock-write-unlock! rwlock))))
+        (for (i (in-range (/ readers 2)))
+          (let (thread (spawn (lambda ()
+                                (rwlock-read-lock! rwlock)
+                                (thread-sleep! reader-wait-time)
+                                (rwlock-read-unlock! rwlock))))
+            (set! reader-threads (cons thread reader-threads))))
+        ;; wait for the writer
+        (check (thread-join! writer-thread) => #!void)
+        (let (end (current-time))
+          ;; it must have taken about reader-wait-time + writer-wait-time (with some fuzz)
+          (check (- (time->seconds end) (time->seconds start))
+                 ? (lambda (dt) (and (>= dt (+ reader-wait-time writer-wait-time))
+                                <= dt (* 1.2 (+ reader-wait-time writer-wait-time))))))
+        ;; wait for the readers
+        (for (thread reader-threads)
+          (check (thread-join! thread) => #!void))
+        (let (end (current-time))
+          ;; it must have taken at most 2*reader-wait-time + writer-wait-time, with some
+          ;; fuzee
+          (check (- (time->seconds end) (time->seconds start))
+                 ? (lambda (dt) (and (>= dt (+ (* 2 reader-wait-time) writer-wait-time))
+                                <= dt (* 1.2 (+ (* 2 reader-wait-time) writer-wait-time))))))))))

src/std/misc/rwlock.ss

@@ -0,0 +1,110 @@
+;;; -*- Gerbil -*-
+;;; © vyzo
+;;; read-write locks
+(import :gerbil/gambit/threads
+        :std/sugar)
+(export make-rwlock
+        rwlock?
+        rwlock-read-lock!
+        rwlock-read-unlock!
+        rwlock-write-lock!
+        rwlock-write-unlock!
+        with-read-lock
+        with-write-lock)
+(declare (not safe))
+
+(defstruct rwlock (mx rcv wcv readers writer writers-waiting)
+  final: #t unchecked: #t
+  constructor: :init!)
+
+(defmethod {:init! rwlock}
+  (lambda (self (name 'rwlock))
+    (let ((mx (make-mutex name))
+          (rcv (make-condition-variable (make-name name "-read-lock")))
+          (wcv (make-condition-variable (make-name name "-write-lock"))))
+      (set! (&rwlock-mx self) mx)
+      (set! (&rwlock-rcv self) rcv)
+      (set! (&rwlock-wcv self) wcv)
+      (set! (&rwlock-readers self) 0)
+      (set! (&rwlock-writer self) #f)
+      (set! (&rwlock-writers-waiting self) 0))))
+
+(def (make-name base suffix)
+  (string->symbol
+   (string-append
+    (symbol->string base) suffix)))
+
+(def (rwlock-read-lock! rw)
+  (with ((rwlock mx rcv) rw)
+    (let lp ()
+      (mutex-lock! mx)
+      (if (or (&rwlock-writer rw) (fx> (&rwlock-writers-waiting rw) 0))
+        (begin
+          (mutex-unlock! mx rcv)
+          (lp))
+        (begin
+          (set! (&rwlock-readers rw) (fx+ (&rwlock-readers rw) 1))
+          (mutex-unlock! mx))))))
+
+(def (rwlock-read-unlock! rw)
+  (with ((rwlock mx _ wcv) rw)
+    (mutex-lock! mx)
+    (let* ((readers (&rwlock-readers rw))
+           (readers-1 (fx- readers 1)))
+      (unless (fx> readers 0)
+        (mutex-unlock! mx)
+        (error "rwlock is not read locked" rw))
+      (set! (&rwlock-readers rw) readers-1)
+      (when (and (fx= readers-1 0) (fx> (&rwlock-writers-waiting rw) 0))
+        (condition-variable-signal! wcv))
+      (mutex-unlock! mx))))
+
+(def (rwlock-write-lock! rw)
+  (with ((rwlock mx _ wcv) rw)
+    (let lp ((waiting? #f))
+      (mutex-lock! mx)
+      (cond
+       ((or (fx> (&rwlock-readers rw) 0) (&rwlock-writer rw))
+        (unless waiting?
+          (set! (&rwlock-writers-waiting rw) (fx+ (&rwlock-writers-waiting rw) 1)))
+        (mutex-unlock! mx wcv)
+        (lp #t))
+       (else
+        (when waiting?
+          (set! (&rwlock-writers-waiting rw) (fx- (&rwlock-writers-waiting rw) 1)))
+        (set! (&rwlock-writer rw) (current-thread))
+        (mutex-unlock! mx))))))
+
+(def (rwlock-write-unlock! rw)
+  (with ((rwlock mx rcv wcv) rw)
+    (mutex-lock! mx)
+    (unless (&rwlock-writer rw)
+      (mutex-unlock! mx)
+      (error "rwlock is not write locked" rw))
+    (set! (&rwlock-writer rw) #f)
+    (if (fx> (&rwlock-writers-waiting rw) 0)
+      (condition-variable-signal! wcv)
+      (condition-variable-broadcast! rcv))
+    (mutex-unlock! mx)))
+
+(defrule (with-rwlock rw proc lock! unlock!)
+  (let (handler (current-exception-handler))
+    (with-exception-handler
+     (lambda (e)
+       (with-catch void
+         (lambda ()
+           (unlock! rw)
+           (handler e)))
+       ;; if the handler returns here the state is inconsistent -- we need to bail
+       (##thread-end-with-uncaught-exception! e))
+     (lambda ()
+       (lock! rw)
+       (let (result (proc))
+         (unlock! rw)
+         result)))))
+
+(def (with-read-lock rw proc)
+  (with-rwlock rw proc rwlock-read-lock! rwlock-read-unlock!))
+
+(def (with-write-lock rw proc)
+  (with-rwlock rw proc rwlock-write-lock! rwlock-write-unlock!))