src/rwlock.lisp

   1 (uiop:define-package #:lw2.rwlock
   2   (:use #:cl)
   3   (:import-from #:sb-thread
   4                 #:make-mutex #:with-mutex #:grab-mutex #:release-mutex
   5                 #:make-waitqueue #:condition-notify #:condition-broadcast #:condition-wait)
   6   (:import-from #:sb-ext
   7                 #:atomic-incf #:atomic-decf)
   8   (:import-from #:sb-sys
   9                 #:without-interrupts #:allow-with-interrupts #:with-interrupts)
  10   (:import-from #:alexandria
  11                 #:with-gensyms)
  12   (:export #:rwlock #:make-rwlock #:read-lock #:read-unlock #:write-lock #:write-unlock #:with-read-lock #:with-write-lock))
  13
  14 (in-package #:lw2.rwlock)
  15
  16 (declaim (inline make-rwlock rwlock-readers rwlock-draining-readers))
  17
  18 (defstruct rwlock
  19   (readers 0 :type sb-ext:word)
  20   (draining-readers 0 :type (signed-byte 64))
  21   (write-mutex (make-mutex))
  22   (read-waitqueue-mutex (make-mutex))
  23   (read-waitqueue (make-waitqueue))
  24   (write-waitqueue-mutex (make-mutex))
  25   (write-waitqueue (make-waitqueue)))
  26
  27 (defmacro with-rwlock-accessors ((rwlock) &body body)
  28   `(with-accessors ,(loop for var in '(readers draining-readers write-mutex read-waitqueue-mutex read-waitqueue write-waitqueue-mutex write-waitqueue)
  29                        collect `(,var ,(find-symbol (format nil "~A-~A" 'rwlock var) '#:lw2.rwlock)))
  30        ,rwlock ,@body))
  31
  32 ;;; States:
  33 ;;; Readers running
  34 ;;; Readers draining
  35 ;;; Writer running
  36
  37 (declaim (inline read-lock read-unlock))
  38
  39 (defun read-lock-slowpath (rwlock)
  40   (with-rwlock-accessors (rwlock)
  41     (with-mutex (read-waitqueue-mutex)
  42       (loop until (evenp (atomic-incf readers 0))
  43          do (or (condition-wait read-waitqueue read-waitqueue-mutex) (error "Waitqueue error"))))
  44     (values nil)))
  45
  46 (defun read-lock (rwlock)
  47   (with-rwlock-accessors (rwlock)
  48     (let ((orig-readers (atomic-incf readers 2)))
  49       (when (oddp orig-readers)
  50         (read-lock-slowpath rwlock)))
  51     (values nil)))
  52
  53 (defun read-unlock-slowpath (rwlock)
  54   (with-rwlock-accessors (rwlock)
  55     (with-mutex (write-waitqueue-mutex)
  56       (decf (the (signed-byte 61) draining-readers))
  57       (when (= draining-readers 0)
  58         (condition-notify write-waitqueue)))
  59     (values nil)))
  60
  61 (defun read-unlock (rwlock)
  62   (with-rwlock-accessors (rwlock)
  63     (let ((orig-readers (atomic-decf readers 2)))
  64       (when (oddp orig-readers)
  65         (read-unlock-slowpath rwlock)))
  66     (values nil)))
  67
  68 (defun write-lock (rwlock)
  69   (with-rwlock-accessors (rwlock)
  70     (grab-mutex write-mutex)
  71     (let ((orig-readers (atomic-incf readers 1)))
  72       (unless (= orig-readers 0)
  73         (with-mutex (write-waitqueue-mutex)
  74           (incf (the (signed-byte 61) draining-readers) (the (signed-byte 61) (ash orig-readers -1)))
  75           (loop until (= draining-readers 0)
  76              do (or (condition-wait write-waitqueue write-waitqueue-mutex) (error "Waitqueue error"))))))
  77     (values nil)))
  78
  79 (defun write-unlock (rwlock)
  80   (with-rwlock-accessors (rwlock)
  81     (with-mutex (read-waitqueue-mutex)
  82       (atomic-decf readers 1)
  83       (condition-broadcast read-waitqueue))
  84     (release-mutex write-mutex)
  85     (values nil)))
  86
  87 (defmacro with-rwlock ((rwlock disposition) &body body)
  88   (multiple-value-bind (lock unlock) (ecase disposition
  89                                        (:read (values 'read-lock 'read-unlock))
  90                                        (:write (values 'write-lock 'write-unlock)))
  91     `(without-interrupts
  92          (allow-with-interrupts
  93           (,lock ,rwlock)
  94           (unwind-protect
  95                (with-interrupts ,@body)
  96             (,unlock ,rwlock))))))
  97
  98 (defmacro with-read-lock ((rwlock &key upgrade-fn) &body body)
  99   (if upgrade-fn
 100       (with-gensyms (upgraded)
 101         `(let ((,upgraded nil))
 102            (flet ((,upgrade-fn ()
 103                     (without-interrupts
 104                         (allow-with-interrupts
 105                          (read-unlock ,rwlock)
 106                          (write-lock ,rwlock)
 107                          (setf ,upgraded t)))))
 108              (read-lock ,rwlock)
 109              (unwind-protect
 110                   (with-interrupts ,@body)
 111                (if (not ,upgraded)
 112                    (read-unlock ,rwlock)
 113                    (write-unlock ,rwlock))))))
 114       `(with-rwlock (,rwlock :read) ,@body)))
 115
 116 (defmacro with-write-lock ((rwlock) &body body)
 117   `(with-rwlock (,rwlock :write) ,@body))