contrib/sb-concurrency/frlock.lisp

   1 ;;;; -*-  Lisp -*-
   2 ;;;;
   3 ;;;; FRLocks for SBCL
   4 ;;;;
   5 ;;;; frlock is a "fast read lock", which allows readers to gain unlocked access
   6 ;;;; to values, and provides post-read verification. Readers which intersected
   7 ;;;; with writers need to retry. frlock is very efficient when there are many
   8 ;;;; readers and writes are both fast and relatively scarce. It is, however,
   9 ;;;; unsuitable when readers and writers need exclusion, such as with SBCL's
  10 ;;;; current hash-table implementation.
  11
  12 ;;;; This software is part of the SBCL system. See the README file for
  13 ;;;; more information.
  14 ;;;;
  15 ;;;; This software is derived from the CMU CL system, which was
  16 ;;;; written at Carnegie Mellon University and released into the
  17 ;;;; public domain. The software is in the public domain and is
  18 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  19 ;;;; files for more information.
  20
  21 (in-package :sb-concurrency)
  22
  23 (defstruct (frlock (:constructor %make-frlock (name))
  24                    (:predicate nil)
  25                    (:copier nil))
  26   "FRlock, aka Fast Read Lock.
  27
  28 Fast Read Locks allow multiple readers and one potential writer to operate in
  29 parallel while providing for consistency for readers and mutual exclusion for
  30 writers.
  31
  32 Readers gain entry to protected regions without waiting, but need to retry if
  33 a writer operated inside the region while they were reading. This makes frlocks
  34 very efficient when readers are much more common than writers.
  35
  36 FRlocks are NOT suitable when it is not safe at all for readers and writers to
  37 operate on the same data in parallel: they provide consistency, not exclusion
  38 between readers and writers. Hence using an frlock to eg. protect an SBCL
  39 hash-table is unsafe. If multiple readers operating in parallel with a writer
  40 would be safe but inconsistent without a lock, frlocks are suitable.
  41
  42 The recommended interface to use is FRLOCK-READ and FRLOCK-WRITE, but those
  43 needing it can also use a lower-level interface.
  44
  45 Example:
  46
  47   ;; Values returned by FOO are always consistent so that
  48   ;; the third value is the sum of the two first ones.
  49   (let ((a 0)
  50         (b 0)
  51         (c 0)
  52         (lk (make-frlock)))
  53     (defun foo ()
  54        (frlock-read (lk) a b c))
  55     (defun bar (x y)
  56        (frlock-write (lk)
  57          (setf a x
  58                b y
  59                c (+ x y)))))
  60 "
  61   (mutex (make-mutex :name "FRLock mutex") :type mutex :read-only t)
  62   ;; Using FIXNUM counters makes sure we don't need to cons a bignum
  63   ;; for the return value, ever.
  64   (pre-counter 0 :type (and unsigned-byte fixnum))
  65   (post-counter 0 :type (and unsigned-byte fixnum))
  66   ;; On 32bit platforms a fixnum can roll over pretty easily, so we also use
  67   ;; an epoch marker to keep track of that.
  68   (epoch (list t) :type cons)
  69   (name nil))
  70
  71 (setf (documentation 'frlock-name 'function)
  72       "Name of an FRLOCK. SETFable.")
  73
  74 (declaim (inline make-frlock))
  75 (defun make-frlock (&key name)
  76   "Returns a new FRLOCK with NAME."
  77   (%make-frlock name))
  78
  79 (declaim (inline frlock-read-begin))
  80 (defun frlock-read-begin (frlock)
  81   "Start a read sequence on FRLOCK. Returns a read-token and an epoch to be
  82 validated later.
  83
  84 Using FRLOCK-READ instead is recommended."
  85   (barrier (:read))
  86   (values (frlock-post-counter frlock)
  87           (frlock-epoch frlock)))
  88
  89 (declaim (inline frlock-read-end))
  90 (defun frlock-read-end (frlock)
  91   "Ends a read sequence on FRLOCK. Returns a token and an epoch. If the token
  92 and epoch are EQL to the read-token and epoch returned by FRLOCK-READ-BEGIN,
  93 the values read under the FRLOCK are consistent and can be used: if the values
  94 differ, the values are inconsistent and the read must be restated.
  95
  96 Using FRLOCK-READ instead is recommended.
  97
  98 Example:
  99
 100   (multiple-value-bind (t0 e0) (frlock-read-begin *fr*)
 101     (let ((a (get-a))
 102           (b (get-b)))
 103       (multiple-value-bind (t1 e1) (frlock-read-end *fr*)
 104         (if (and (eql t0 t1) (eql e0 e1))
 105             (list :a a :b b)
 106             :aborted))))
 107 "
 108   (barrier (:read))
 109   (values (frlock-pre-counter frlock)
 110           (frlock-epoch frlock)))
 111
 112 (defmacro frlock-read ((frlock) &body value-forms)
 113   "Evaluates VALUE-FORMS under FRLOCK till it obtains a consistent
 114 set, and returns that as multiple values."
 115   (once-only ((frlock frlock))
 116     (with-unique-names (t0 t1 e0 e1)
 117       (let ((syms (make-gensym-list (length value-forms))))
 118         `(loop
 119            (multiple-value-bind (,t0 ,e0) (frlock-read-begin ,frlock)
 120              (let ,(mapcar 'list syms value-forms)
 121                (barrier (:compiler))
 122                (multiple-value-bind (,t1 ,e1) (frlock-read-end ,frlock)
 123                 (when (and (eql ,t1 ,t0) (eql ,e1 ,e0))
 124                   (return (values ,@syms)))))))))))
 125
 126 ;;; Actual implementation.
 127 (defun %%grab-frlock-write-lock (frlock wait-p timeout)
 128   (when (grab-mutex (frlock-mutex frlock) :waitp wait-p :timeout timeout)
 129     (let ((new (logand most-positive-fixnum (1+ (frlock-pre-counter frlock)))))
 130       ;; Here's our roll-over protection: if a reader has been unlucky enough
 131       ;; to stand inside the lock long enough for the counter to go from 0 to
 132       ;; 0, they will still be holding on to the old epoch. While it is
 133       ;; extremely unlikely, it isn't quite "not before heath death of the
 134       ;; universe" stuff: a 30 bit counter can roll over in a couple of
 135       ;; seconds -- and a thread can easily be interrupted by eg. a timer for
 136       ;; that long, so a pathological system could be have a thread in a
 137       ;; danger-zone every second. Run that system for a year, and it would
 138       ;; have a 1 in 3 chance of hitting the incipient bug. Adding an epoch
 139       ;; makes sure that isn't going to happen.
 140       (when (zerop new)
 141         (setf (frlock-epoch frlock) (list t)))
 142       (setf (frlock-pre-counter frlock) new))
 143     (barrier (:write))
 144     t))
 145
 146 ;;; Interrupt-mangling free entry point for FRLOCK-WRITE.
 147 (declaim (inline %grab-frlock-write-lock))
 148 (defun %grab-frlock-write-lock (frlock &key (wait-p t) timeout)
 149   (%%grab-frlock-write-lock frlock wait-p timeout))
 150
 151 ;;; Normal entry-point.
 152 (declaim (inline grab-frlock-write-lock))
 153 (defun grab-frlock-write-lock (frlock &key (wait-p t) timeout)
 154   "Acquires FRLOCK for writing, invalidating existing and future read-tokens
 155 for the duration. Returns T on success, and NIL if the lock wasn't acquired
 156 due to eg. a timeout. Using FRLOCK-WRITE instead is recommended."
 157   (without-interrupts
 158     (allow-with-interrupts (%%grab-frlock-write-lock frlock wait-p timeout))))
 159
 160 (declaim (inline release-frlock-write-lock))
 161 (defun release-frlock-write-lock (frlock)
 162   "Releases FRLOCK after writing, allowing valid read-tokens to be acquired again.
 163 Signals an error if the current thread doesn't hold FRLOCK for writing. Using FRLOCK-WRITE
 164 instead is recommended."
 165   (setf (frlock-post-counter frlock)
 166         (logand most-positive-fixnum (1+ (frlock-post-counter frlock))))
 167   (release-mutex (frlock-mutex frlock) :if-not-owner :error)
 168   (barrier (:write)))
 169
 170 (defmacro frlock-write ((frlock &key (wait-p t) timeout) &body body)
 171   "Executes BODY while holding FRLOCK for writing."
 172   (once-only ((frlock frlock))
 173     (with-unique-names (got-it)
 174       `(without-interrupts
 175          (let (,got-it)
 176            (unwind-protect
 177                 (when (setf ,got-it (allow-with-interrupts
 178                                       (%grab-frlock-write-lock ,frlock :timeout ,timeout
 179                                                                       :wait-p ,wait-p)))
 180                   (with-local-interrupts ,@body))
 181              (when ,got-it
 182                (release-frlock-write-lock ,frlock))))))))