Suppress warnings about possible slot name conflicts with slots from SB-PCL.
[sbcl.git] / 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))))))))