Try a different implementation of reader/writer lock

benchmarks/rwlbench2.lisp

@@ -0,0 +1,102 @@
+(defpackage :sbcl-lock-bench
+  (:use :cl :sb-thread)
+  (:shadow #:spinlock #:with-spinlock)
+  (:export :compare-locks))
+
+(in-package :sbcl-lock-bench)
+
+(defparameter *time-wasting-iterations-read* 100)
+(defparameter *time-wasting-iterations-write* 150)
+
+;;; spinlock
+(defstruct (spinlock)
+  (state 0 :type sb-ext:word)) ; 0 = unlocked, 1 = locked
+
+(defun spin-lock (lock)
+  (declare (optimize (speed 3) (safety 0)))
+  (loop (if (eql 0 (sb-ext:cas (spinlock-state lock) 0 1))
+            (return t)
+            (sb-thread:thread-yield))))
+
+(declaim (inline spin-unlock))
+(defun spin-unlock (lock)
+  (declare (optimize (speed 3) (safety 0)))
+  (setf (spinlock-state lock) 0))
+
+(defmacro with-spinlock ((lock) &body body)
+  `(progn
+     (spin-lock ,lock)
+     (unwind-protect (progn ,@body)
+       (spin-unlock ,lock))))
+
+(defun run-spinlock-worker (lock operations write-percent)
+  (let* ((my-random-state (make-random-state t))
+         (r (random 100 my-random-state)))
+    (dotimes (i (the fixnum operations))
+      ;; readers and writers use the same lock mechanism
+      (with-spinlock (lock)
+        (if (< r write-percent)
+            (loop repeat *time-wasting-iterations-write*)
+            (loop repeat *time-wasting-iterations-read*))
+        ;; and do some some work inside the lock
+        (setq r (random 100 my-random-state))))))
+
+;;; spinlock-based rwlock
+(defmacro with-rwlock-read ((lock) &body body)
+  `(progn (rwspinlock-rdlock ,lock)
+          (multiple-value-prog1 (progn ,@body) (rwspinlock-rdunlock ,lock))))
+
+(defmacro with-rwlock-write ((lock) &body body)
+  `(progn (rwspinlock-wrlock ,lock)
+          (multiple-value-prog1 (progn ,@body) (rwspinlock-wrunlock ,lock))))
+
+(defun run-rwlock-worker (lock operations write-percent)
+  (let* ((my-random-state (make-random-state t))
+        (r (random 100 my-random-state)))
+    (dotimes (i (the fixnum operations))
+      (if (< r write-percent)
+          (with-rwlock-write (lock)
+            (loop repeat *time-wasting-iterations-write*)
+            (setq r (random 100 my-random-state)))
+          (with-rwlock-read (lock)
+            (loop repeat *time-wasting-iterations-read*)
+            (setq r (random 100 my-random-state)))))))
+
+;; runner
+(defun execute-bench (lock-type operations threads write-percent)
+  (let ((threads-list '())
+        (start-time (get-internal-real-time))
+        (lock (if (eq lock-type :rwlock)
+                  (sb-thread::make-rw-spinlock)
+                  (make-spinlock))))
+
+    (dotimes (i threads)
+      (push (sb-thread:make-thread
+             (lambda ()
+               (if (eq lock-type :rwlock)
+                   (run-rwlock-worker lock operations write-percent)
+                   (run-spinlock-worker lock operations write-percent))))
+            threads-list))
+
+    (mapc #'sb-thread:join-thread threads-list)
+
+    (let* ((end-time (get-internal-real-time))
+           (elapsed (/ (- end-time start-time) internal-time-units-per-second)))
+      elapsed)))
+
+(defun compare-locks (&key (threads 4) (ops-per-thread 100000))
+  (format t "~%================================================~%")
+  (format t "Comparing spinlock-based RWLOCK vs MUTEX~%")
+  (format t "Threads: ~D | Ops/Thread: ~D~%" threads ops-per-thread)
+  (format t "================================================~%~%")
+  (format t "~10A | ~15A | ~15A | ~A~%" "Write %" "RW-Lock Time" "Mutex Time" "Speedup (RW / Mutex)")
+  (format t "------------------------------------------------------------------~%")
+
+  (dolist (pct '(0 1 2 3 5 10 20 30 40 50 60 70 80 90 100))
+    (let ((rw-time (execute-bench :rwlock ops-per-thread threads pct))
+          (mutex-time (execute-bench :mutex ops-per-thread threads pct)))
+      (format t "~10D | ~14,3Fs | ~14,3Fs | ~,2Fx~%"
+              pct
+              rw-time
+              mutex-time
+              (/ mutex-time rw-time))))) ; Speedup > 1.0x means RWLock was faster

src/code/rwlock.lisp

@@ -11,7 +11,11 @@
 
 (in-package "SB-THREAD")
 
-(export '(MAKE-RWLOCK RWLOCK-RDLOCK RWLOCK-WRLOCK RWLOCK-UNLOCK))
+(export '(make-rwlock rwlock-rdlock rwlock-wrlock rwlock-unlock
+          make-rw-spinlock rwspinlock-rdlock rwspinlock-rdunlock
+          rwspinlock-wrlock rwspinlock-wrunlock))
+
+(defmacro my-kernel-thread-id () `(thread-os-tid *current-thread*))
 
 ;;; This design is inspired by that of Bionic libc with adjustments for the fact that SBCL
 ;;; lacks 32-bit integer raw slots on 64-bit machines, and removal of timeouts
@@ -112,7 +116,8 @@
 
 (defun rwlock-rdlock (lock)
   (with-pinned-objects (lock)
-    (or (rwlock-tryrdlock lock) (%rwlock-rdlock lock))))
+    (or (rwlock-tryrdlock lock) (%rwlock-rdlock lock)))
+  t)
 
 (defun rwlock-trywrlock (lock)
   (do ((old (rwlock-state lock)))
@@ -141,7 +146,8 @@
 
 (defun rwlock-wrlock (lock)
   (with-pinned-objects (lock)
-    (or (rwlock-trywrlock lock) (%rwlock-wrlock lock))))
+    (or (rwlock-trywrlock lock) (%rwlock-wrlock lock)))
+  t)
 
 (defun rwlock-unlock (lock)
   (declare (type rwlock lock))
@@ -172,3 +178,59 @@
             (#.PENDING-WRITERS-FLAG
              (futex-wake (&rwlock-writer-wake-word lock) 1))))))))
   t)
+
+(defstruct (rw-spinlock (:constructor make-rw-spinlock))
+  ;; Bits 0-31: Reader count, or #xFFFFFFFF if a writer holds the lock
+  ;; Bits 32-63: Writers waiting to acquire the lock
+  (state 0 :type sb-ext:word))
+
+(defconstant +reader-mask+ #xFFFFFFFF)
+(defconstant +writer-shift+ 32)
+
+(defun rwspinlock-rdlock (lock)
+  (declare (optimize (speed 3) (safety 0)))
+  (loop
+    (let ((state (rw-spinlock-state lock)))
+      ;; The max reader count is capped to #xFFFFFFFE,
+      ;; because exactly #xFFFFFFFF equals one writer.
+      (cond ((< state (1- +reader-mask+))
+             ;; No writer holds the lock, and no writers are waiting for the lock.
+             (when (eql state (sb-ext:cas (rw-spinlock-state lock) state (1+ state)))
+               (return t)))
+            ((and (= (logand state +reader-mask+) (1- +reader-mask+))
+                  (zerop (ash state (- +writer-shift+))))
+             (bug "Too many readers"))))
+   (thread-yield)))
+
+(declaim (inline rwspinlock-rdunlock))
+(defun rwspinlock-rdunlock (lock)
+  (declare (optimize (speed 3) (safety 0)))
+  (sb-ext:atomic-decf (rw-spinlock-state lock))
+  t)
+
+(defun rwspinlock-wrlock (lock)
+  (declare (optimize (speed 3) (safety 0)))
+  (symbol-macrolet ((writer-increment (ash 1 +writer-shift+)))
+    ;; Step 1: Announce a new writer by incrementing the high half of the state bits.
+    ;; After doing this, no additional readers can take the lock.
+    (sb-ext:atomic-incf (rw-spinlock-state lock) writer-increment)
+    ;; Step 2: Wait for 0 contenders and then try to take the lock as a writer
+    (loop
+     (let ((current (rw-spinlock-state lock)))
+       (when (zerop (logand current +reader-mask+))
+         ;; Try to set active reader count to #xFFFFFFFF which means 1 active writer,
+         ;; and also decrement the waiting writer count.
+         (let ((new-state (logior +reader-mask+ (- current writer-increment))))
+           (when (eql current (sb-ext:cas (rw-spinlock-state lock) current new-state))
+             (return t)))))
+     (thread-yield))))
+
+(declaim (inline rwspinlock-wrunlock))
+(defun rwspinlock-wrunlock (lock)
+  (declare (optimize (speed 3) (safety 0)))
+  (let ((disp (ash (+ sb-vm:instance-slots-offset sb-vm:instance-data-start) sb-vm:word-shift)))
+    ;; Clear the the low 32 state bits (assuming little-endian)
+    (with-pinned-objects (lock)
+      (setf (sap-ref-32 (int-sap (get-lisp-obj-address lock))
+                        (- disp sb-vm:instance-pointer-lowtag))
+            0))))