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.ss

@@ -0,0 +1,101 @@
+;;; -*- 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 cv readers writer writers-waiting)
+  final: #t unchecked: #t
+  constructor: :init!)
+
+(defmethod {:init! rwlock}
+  (lambda (self (name 'rwlock))
+    (let ((mx (make-mutex name))
+          (cv (make-condition-variable name)))
+      (set! (&rwlock-mx self) mx)
+      (set! (&rwlock-cv self) cv)
+      (set! (&rwlock-readers self) 0)
+      (set! (&rwlock-writer self) #f)
+      (set! (&rwlock-writers-waiting self) 0))))
+
+(def (rwlock-read-lock! rw)
+  (with ((rwlock mx cv) rw)
+    (mutex-lock! mx)
+    (let lp ()
+      (if (or (&rwlock-writer rw) (fx> (&rwlock-writers-waiting rw) 0))
+        (begin
+          (mutex-unlock! mx cv)
+          (lp))
+        (begin
+          (set! (&rwlock-readers rw) (fx+ (&rwlock-readers rw) 1))
+          (mutex-unlock! mx))))))
+
+(def (rwlock-read-unlock! rw)
+  (with ((rwlock mx cv) 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-broadcast! cv))
+      (mutex-unlock! mx))))
+
+(def (rwlock-write-lock! rw)
+  (with ((rwlock mx cv) rw)
+    (mutex-lock! mx)
+    (let lp ((waiting? #f))
+      (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 cv)
+        (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 cv) rw)
+    (mutex-lock! mx)
+    (unless (&rwlock-writer rw)
+      (mutex-unlock! mx)
+      (error "rwlock is not write locked" rw))
+    (set! (&rwlock-writer rw) #f)
+    (condition-variable-broadcast! cv)
+    (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!))