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 (declaim (inline make-frlock))
  72 (defun make-frlock (&key name)
  73   "Returns a new FRLOCK with NAME."
  74   (%make-frlock name))
  75
  76 (declaim (inline frlock-read-begin))
  77 (defun frlock-read-begin (frlock)
  78   "Start a read sequence on FRLOCK. Returns a read-token and an epoch to be
  79 validated later.
  80
  81 Using FRLOCK-READ instead is recommended."
  82   (barrier (:read))
  83   (values (frlock-post-counter frlock)
  84           (frlock-epoch frlock)))
  85
  86 (declaim (inline frlock-read-end))
  87 (defun frlock-read-end (frlock)
  88   "Ends a read sequence on FRLOCK. Returns a token and an epoch. If the token
  89 and epoch are EQL to the read-token and epoch returned by FRLOCK-READ-BEGIN,
  90 the values read under the FRLOCK are consistent and can be used: if the values
  91 differ, the values are inconsistent and the read must be restated.
  92
  93 Using FRLOCK-READ instead is recommended.
  94
  95 Example:
  96
  97   (multiple-value-bind (t0 e0) (frlock-read-begin *fr*)
  98     (let ((a (get-a))
  99           (b (get-b)))
 100       (multiple-value-bind (t1 e1) (frlock-read-end *fr*)
 101         (if (and (eql t0 t1) (eql e0 e1))
 102             (list :a a :b b)
 103             :aborted))))
 104 "
 105   (barrier (:read))
 106   (values (frlock-pre-counter frlock)
 107           (frlock-epoch frlock)))
 108
 109 (defmacro frlock-read ((frlock) &body value-forms)
 110   "Evaluates VALUE-FORMS under FRLOCK till it obtains a consistent
 111 set, and returns that as multiple values."
 112   (once-only ((frlock frlock))
 113     (with-unique-names (t0 t1 e0 e1)
 114       (let ((syms (make-gensym-list (length value-forms))))
 115         `(loop
 116            (multiple-value-bind (,t0 ,e0) (frlock-read-begin ,frlock)
 117              (let ,(mapcar 'list syms value-forms)
 118                (barrier (:compiler))
 119                (multiple-value-bind (,t1 ,e1) (frlock-read-end ,frlock)
 120                 (when (and (eql ,t1 ,t0) (eql ,e1 ,e0))
 121                   (return (values ,@syms)))))))))))
 122
 123 ;;; Actual implementation.
 124 (defun %%grab-frlock-write-lock (frlock wait-p timeout)
 125   (when (grab-mutex (frlock-mutex frlock) :waitp wait-p :timeout timeout)
 126     (let ((new (logand most-positive-fixnum (1+ (frlock-pre-counter frlock)))))
 127       ;; Here's our roll-over protection: if a reader has been unlucky enough
 128       ;; to stand inside the lock long enough for the counter to go from 0 to
 129       ;; 0, they will still be holding on to the old epoch. While it is
 130       ;; extremely unlikely, it isn't quite "not before heath death of the
 131       ;; universe" stuff: a 30 bit counter can roll over in a couple of
 132       ;; seconds -- and a thread can easily be interrupted by eg. a timer for
 133       ;; that long, so a pathological system could be have a thread in a
 134       ;; danger-zone every second. Run that system for a year, and it would
 135       ;; have a 1 in 3 chance of hitting the incipient bug. Adding an epoch
 136       ;; makes sure that isn't going to happen.
 137       (when (zerop new)
 138         (setf (frlock-epoch frlock) (list t)))
 139       (setf (frlock-pre-counter frlock) new))
 140     (barrier (:write))
 141     t))
 142
 143 ;;; Interrupt-mangling free entry point for FRLOCK-WRITE.
 144 (declaim (inline %grab-frlock-write-lock))
 145 (defun %grab-frlock-write-lock (frlock &key (wait-p t) timeout)
 146   (%%grab-frlock-write-lock frlock wait-p timeout))
 147
 148 ;;; Normal entry-point.
 149 (declaim (inline grab-frlock-write-lock))
 150 (defun grab-frlock-write-lock (frlock &key (wait-p t) timeout)
 151   "Acquires FRLOCK for writing, invalidating existing and future read-tokens
 152 for the duration. Returns T on success, and NIL if the lock wasn't acquired
 153 due to eg. a timeout. Using FRLOCK-WRITE instead is recommended."
 154   (without-interrupts
 155     (allow-with-interrupts (%%grab-frlock-write-lock frlock wait-p timeout))))
 156
 157 (declaim (inline release-frlock-write-lock))
 158 (defun release-frlock-write-lock (frlock)
 159   "Releases FRLOCK after writing, allowing valid read-tokens to be acquired again.
 160 Signals an error if the current thread doesn't hold FRLOCK for writing. Using FRLOCK-WRITE
 161 instead is recommended."
 162   (setf (frlock-post-counter frlock)
 163         (logand most-positive-fixnum (1+ (frlock-post-counter frlock))))
 164   (release-mutex (frlock-mutex frlock) :if-not-owner :error)
 165   (barrier (:write)))
 166
 167 (defmacro frlock-write ((frlock &key (wait-p t) timeout) &body body)
 168   "Executes BODY while holding FRLOCK for writing."
 169   (once-only ((frlock frlock))
 170     (with-unique-names (got-it)
 171       `(without-interrupts
 172          (let (,got-it)
 173            (unwind-protect
 174                 (when (setf ,got-it (allow-with-interrupts
 175                                       (%grab-frlock-write-lock ,frlock :timeout ,timeout
 176                                                                       :wait-p ,wait-p)))
 177                   (with-local-interrupts ,@body))
 178              (when ,got-it
 179                (release-frlock-write-lock ,frlock))))))))