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                 #:once-only)
  13   (:export #:rwlock #:make-rwlock #:read-lock #:read-unlock #:write-lock #:write-unlock #:with-read-lock #:with-write-lock #:with-rwlock-protect))
  14
  15 (in-package #:lw2.rwlock)
  16
  17 (declaim (inline make-rwlock rwlock-readers rwlock-draining-readers))
  18
  19 (defstruct rwlock
  20   (readers 0 :type sb-ext:word)
  21   (draining-readers 0 :type (signed-byte 64))
  22   (write-mutex (make-mutex))
  23   (read-waitqueue-mutex (make-mutex))
  24   (read-waitqueue (make-waitqueue))
  25   (write-waitqueue-mutex (make-mutex))
  26   (write-waitqueue (make-waitqueue)))
  27
  28 (defmacro with-rwlock-accessors ((rwlock) &body body)
  29   `(with-accessors ,(loop for var in '(readers draining-readers write-mutex read-waitqueue-mutex read-waitqueue write-waitqueue-mutex write-waitqueue)
  30                        collect `(,var ,(find-symbol (format nil "~A-~A" 'rwlock var) '#:lw2.rwlock)))
  31        ,rwlock ,@body))
  32
  33 ;;; States:
  34 ;;; Readers running
  35 ;;; Readers draining
  36 ;;; Writer running
  37
  38 (declaim (inline read-lock read-unlock))
  39
  40 (defun read-lock-slowpath (rwlock)
  41   (with-rwlock-accessors (rwlock)
  42     (with-mutex (read-waitqueue-mutex)
  43       (loop until (evenp (atomic-incf readers 0))
  44          do (or (condition-wait read-waitqueue read-waitqueue-mutex) (error "Waitqueue error"))))
  45     (values nil)))
  46
  47 (defun read-lock (rwlock)
  48   (with-rwlock-accessors (rwlock)
  49     (let ((orig-readers (atomic-incf readers 2)))
  50       (when (oddp orig-readers)
  51         (read-lock-slowpath rwlock)))
  52     (values nil)))
  53
  54 (defun read-unlock-slowpath (rwlock)
  55   (with-rwlock-accessors (rwlock)
  56     (with-mutex (write-waitqueue-mutex)
  57       (decf (the (signed-byte 61) draining-readers))
  58       (when (= draining-readers 0)
  59         (condition-notify write-waitqueue)))
  60     (values nil)))
  61
  62 (defun read-unlock (rwlock)
  63   (with-rwlock-accessors (rwlock)
  64     (let ((orig-readers (atomic-decf readers 2)))
  65       (when (oddp orig-readers)
  66         (read-unlock-slowpath rwlock)))
  67     (values nil)))
  68
  69 (defun write-lock (rwlock)
  70   (with-rwlock-accessors (rwlock)
  71     (grab-mutex write-mutex)
  72     (let ((orig-readers (atomic-incf readers 1)))
  73       (unless (= orig-readers 0)
  74         (with-mutex (write-waitqueue-mutex)
  75           (incf (the (signed-byte 61) draining-readers) (the (signed-byte 61) (ash orig-readers -1)))
  76           (loop until (= draining-readers 0)
  77              do (or (condition-wait write-waitqueue write-waitqueue-mutex) (error "Waitqueue error"))))))
  78     (values nil)))
  79
  80 (defun write-unlock (rwlock)
  81   (with-rwlock-accessors (rwlock)
  82     (with-mutex (read-waitqueue-mutex)
  83       (atomic-decf readers 1)
  84       (condition-broadcast read-waitqueue))
  85     (release-mutex write-mutex)
  86     (values nil)))
  87
  88 (defmacro with-rwlock ((rwlock disposition) &body body)
  89   (multiple-value-bind (lock unlock) (ecase disposition
  90                                        (:read (values 'read-lock 'read-unlock))
  91                                        (:write (values 'write-lock 'write-unlock)))
  92     `(without-interrupts
  93          (allow-with-interrupts
  94           (,lock ,rwlock)
  95           (unwind-protect
  96                (with-interrupts ,@body)
  97             (,unlock ,rwlock))))))
  98
  99 (defmacro with-read-lock ((rwlock &key upgrade-fn) &body body)
 100   (if upgrade-fn
 101       (with-gensyms (upgraded)
 102         `(let ((,upgraded nil))
 103            (flet ((,upgrade-fn ()
 104                     (without-interrupts
 105                         (allow-with-interrupts
 106                          (read-unlock ,rwlock)
 107                          (write-lock ,rwlock)
 108                          (setf ,upgraded t)))))
 109              (read-lock ,rwlock)
 110              (unwind-protect
 111                   (with-interrupts ,@body)
 112                (if (not ,upgraded)
 113                    (read-unlock ,rwlock)
 114                    (write-unlock ,rwlock))))))
 115       `(with-rwlock (,rwlock :read) ,@body)))
 116
 117 (defmacro with-write-lock ((rwlock) &body body)
 118   `(with-rwlock (,rwlock :write) ,@body))
 119
 120 (defmacro with-rwlock-protect (rwlock predicate-form write-form &body read-forms)
 121   "
 122 Protect READ-FORMS from being evaluated when PREDICATE-FORM returns false.
 123 RWLOCK will be locked in read mode. If PREDICATE-FORM returns false, RWLOCK will
 124 be upgraded to write mode and WRITE-FORM will be evaluated. WRITE-FORM should
 125 ensure that PREDICATE-FORM will return true. PREDICATE-FORM may be evaluated
 126 more than once. Returns the values returned by READ-FORMS."
 127   (once-only (rwlock)
 128     (with-gensyms (predicate-fn write-fn read-fn)
 129       `(flet ((,predicate-fn () ,predicate-form)
 130               (,write-fn () ,write-form)
 131               (,read-fn () ,@read-forms))
 132          (declare (dynamic-extent #',predicate-fn #',write-fn #',read-fn))
 133          (with-read-lock (,rwlock :upgrade-fn upgrade-lock)
 134            (unless (,predicate-fn)
 135              (upgrade-lock)
 136              (unless (,predicate-fn)
 137                (,write-fn)))
 138            (,read-fn))))))