From: Nikodemus Siivola Date: Mon, 8 Oct 2012 07:09:53 +0000 (+0300) Subject: sb-concurrency: frlocks X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2f9585060d5fe2c525955d80f34123761ded80fe;p=sbcl.git sb-concurrency: frlocks --- diff --git a/NEWS b/NEWS index 23dbf39..c51ad01 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,7 @@ changes relative to sbcl-1.1.1: (NT 5.0) is no longer being maintained. * notice: Starting with this version, SBCL on Windows no longer supports building with disabled thread support. + * enhancement: frlocks have been added to SB-CONCURRENCY contrib module. * enhancement: New feature sb-dynamic-core allows the runtime to be rebuilt or relocated without requiring changes to the core file on all linkage table platforms. Required on Windows. diff --git a/contrib/sb-concurrency/frlock.lisp b/contrib/sb-concurrency/frlock.lisp new file mode 100644 index 0000000..864e168 --- /dev/null +++ b/contrib/sb-concurrency/frlock.lisp @@ -0,0 +1,179 @@ +;;;; -*- Lisp -*- +;;;; +;;;; FRLocks for SBCL +;;;; +;;;; frlock is a "fast read lock", which allows readers to gain unlocked access +;;;; to values, and provides post-read verification. Readers which intersected +;;;; with writers need to retry. frlock is very efficient when there are many +;;;; readers and writes are both fast and relatively scarce. It is, however, +;;;; unsuitable when readers and writers need exclusion, such as with SBCL's +;;;; current hash-table implementation. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package :sb-concurrency) + +(defstruct (frlock (:constructor %make-frlock (name)) + (:predicate nil) + (:copier nil)) + "FRlock, aka Fast Read Lock. + +Fast Read Locks allow multiple readers and one potential writer to operate in +parallel while providing for consistency for readers and mutual exclusion for +writers. + +Readers gain entry to protected regions without waiting, but need to retry if +a writer operated inside the region while they were reading. This makes frlocks +very efficient when readers are much more common than writers. + +FRlocks are NOT suitable when it is not safe at all for readers and writers to +operate on the same data in parallel: they provide consistency, not exclusion +between readers and writers. Hence using an frlock to eg. protect an SBCL +hash-table is unsafe. If multiple readers operating in parallel with a writer +would be safe but inconsistent without a lock, frlocks are suitable. + +The recommended interface to use is FRLOCK-READ and FRLOCK-WRITE, but those +needing it can also use a lower-level interface. + +Example: + + ;; Values returned by FOO are always consistent so that + ;; the third value is the sum of the two first ones. + (let ((a 0) + (b 0) + (c 0) + (lk (make-frlock))) + (defun foo () + (frlock-read (lk) a b c)) + (defun bar (x y) + (frlock-write (lk) + (setf a x + b y + c (+ x y))))) +" + (mutex (make-mutex :name "FRLock mutex") :type mutex :read-only t) + ;; Using FIXNUM counters makes sure we don't need to cons a bignum + ;; for the return value, ever. + (pre-counter 0 :type (and unsigned-byte fixnum)) + (post-counter 0 :type (and unsigned-byte fixnum)) + ;; On 32bit platforms a fixnum can roll over pretty easily, so we also use + ;; an epoch marker to keep track of that. + (epoch (list t) :type cons) + (name nil)) + +(declaim (inline make-frlock)) +(defun make-frlock (&key name) + "Returns a new FRLOCK with NAME." + (%make-frlock name)) + +(declaim (inline frlock-read-begin)) +(defun frlock-read-begin (frlock) + "Start a read sequence on FRLOCK. Returns a read-token and an epoch to be +validated later. + +Using FRLOCK-READ instead is recommended." + (barrier (:read)) + (values (frlock-post-counter frlock) + (frlock-epoch frlock))) + +(declaim (inline frlock-read-end)) +(defun frlock-read-end (frlock) + "Ends a read sequence on FRLOCK. Returns a token and an epoch. If the token +and epoch are EQL to the read-token and epoch returned by FRLOCK-READ-BEGIN, +the values read under the FRLOCK are consistent and can be used: if the values +differ, the values are inconsistent and the read must be restated. + +Using FRLOCK-READ instead is recommended. + +Example: + + (multiple-value-bind (t0 e0) (frlock-read-begin *fr*) + (let ((a (get-a)) + (b (get-b))) + (multiple-value-bind (t1 e1) (frlock-read-end *fr*) + (if (and (eql t0 t1) (eql e0 e1)) + (list :a a :b b) + :aborted)))) +" + (barrier (:read)) + (values (frlock-pre-counter frlock) + (frlock-epoch frlock))) + +(defmacro frlock-read ((frlock) &body value-forms) + "Evaluates VALUE-FORMS under FRLOCK till it obtains a consistent +set, and returns that as multiple values." + (once-only ((frlock frlock)) + (with-unique-names (t0 t1 e0 e1) + (let ((syms (make-gensym-list (length value-forms)))) + `(loop + (multiple-value-bind (,t0 ,e0) (frlock-read-begin ,frlock) + (let ,(mapcar 'list syms value-forms) + (barrier (:compiler)) + (multiple-value-bind (,t1 ,e1) (frlock-read-end ,frlock) + (when (and (eql ,t1 ,t0) (eql ,e1 ,e0)) + (return (values ,@syms))))))))))) + +;;; Actual implementation. +(defun %%grab-frlock-write-lock (frlock wait-p timeout) + (when (grab-mutex (frlock-mutex frlock) :waitp wait-p :timeout timeout) + (let ((new (logand most-positive-fixnum (1+ (frlock-pre-counter frlock))))) + ;; Here's our roll-over protection: if a reader has been unlucky enough + ;; to stand inside the lock long enough for the counter to go from 0 to + ;; 0, they will still be holding on to the old epoch. While it is + ;; extremely unlikely, it isn't quite "not before heath death of the + ;; universe" stuff: a 30 bit counter can roll over in a couple of + ;; seconds -- and a thread can easily be interrupted by eg. a timer for + ;; that long, so a pathological system could be have a thread in a + ;; danger-zone every second. Run that system for a year, and it would + ;; have a 1 in 3 chance of hitting the incipient bug. Adding an epoch + ;; makes sure that isn't going to happen. + (when (zerop new) + (setf (frlock-epoch frlock) (list t))) + (setf (frlock-pre-counter frlock) new)) + (barrier (:write)) + t)) + +;;; Interrupt-mangling free entry point for FRLOCK-WRITE. +(declaim (inline %grab-frlock-write-lock)) +(defun %grab-frlock-write-lock (frlock &key (wait-p t) timeout) + (%%grab-frlock-write-lock frlock wait-p timeout)) + +;;; Normal entry-point. +(declaim (inline grab-frlock-write-lock)) +(defun grab-frlock-write-lock (frlock &key (wait-p t) timeout) + "Acquires FRLOCK for writing, invalidating existing and future read-tokens +for the duration. Returns T on success, and NIL if the lock wasn't acquired +due to eg. a timeout. Using FRLOCK-WRITE instead is recommended." + (without-interrupts + (allow-with-interrupts (%%grab-frlock-write-lock frlock wait-p timeout)))) + +(declaim (inline release-frlock-write-lock)) +(defun release-frlock-write-lock (frlock) + "Releases FRLOCK after writing, allowing valid read-tokens to be acquired again. +Signals an error if the current thread doesn't hold FRLOCK for writing. Using FRLOCK-WRITE +instead is recommended." + (setf (frlock-post-counter frlock) + (logand most-positive-fixnum (1+ (frlock-post-counter frlock)))) + (release-mutex (frlock-mutex frlock) :if-not-owner :error) + (barrier (:write))) + +(defmacro frlock-write ((frlock &key (wait-p t) timeout) &body body) + "Executes BODY while holding FRLOCK for writing." + (once-only ((frlock frlock)) + (with-unique-names (got-it) + `(without-interrupts + (let (,got-it) + (unwind-protect + (when (setf ,got-it (allow-with-interrupts + (%grab-frlock-write-lock ,frlock :timeout ,timeout + :wait-p ,wait-p))) + (with-local-interrupts ,@body)) + (when ,got-it + (release-frlock-write-lock ,frlock)))))))) diff --git a/contrib/sb-concurrency/package.lisp b/contrib/sb-concurrency/package.lisp index 7e6c6bd..942ce61 100644 --- a/contrib/sb-concurrency/package.lisp +++ b/contrib/sb-concurrency/package.lisp @@ -1,5 +1,16 @@ +;;;; -*- Lisp -*- +;;;; +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + (defpackage :sb-concurrency - (:use :cl :sb-thread :sb-int) + (:use :cl :sb-thread :sb-int :sb-ext :sb-sys) (:export ;; MAILBOX "LIST-MAILBOX-MESSAGES" @@ -34,4 +45,15 @@ "MAKE-GATE" "OPEN-GATE" "WAIT-ON-GATE" + + ;; FRLOCK + "MAKE-FRLOCK" + "FRLOCK" + "FRLOCK-NAME" + "FRLOCK-WRITE" + "FRLOCK-READ" + "FRLOCK-READ-BEGIN" + "FRLOCK-READ-END" + "GRAB-FRLOCK-WRITE-LOCK" + "RELEASE-FRLOCK-WRITE-LOCK" )) \ No newline at end of file diff --git a/contrib/sb-concurrency/sb-concurrency.asd b/contrib/sb-concurrency/sb-concurrency.asd index b692132..ba901c8 100644 --- a/contrib/sb-concurrency/sb-concurrency.asd +++ b/contrib/sb-concurrency/sb-concurrency.asd @@ -13,6 +13,7 @@ (asdf:defsystem :sb-concurrency :components ((:file "package") + (:file "frlock" :depends-on ("package")) (:file "queue" :depends-on ("package")) (:file "mailbox" :depends-on ("package" "queue")) (:file "gate" :depends-on ("package")))) @@ -24,6 +25,7 @@ :components ((:file "package") (:file "test-utils" :depends-on ("package")) + (:file "test-frlock" :depends-on ("package" "test-utils")) (:file "test-queue" :depends-on ("package" "test-utils")) (:file "test-mailbox" :depends-on ("package" "test-utils")) (:file "test-gate" :depends-on ("package" "test-utils")))))) diff --git a/contrib/sb-concurrency/sb-concurrency.texinfo b/contrib/sb-concurrency/sb-concurrency.texinfo index e61538e..8c609b9 100644 --- a/contrib/sb-concurrency/sb-concurrency.texinfo +++ b/contrib/sb-concurrency/sb-concurrency.texinfo @@ -74,3 +74,22 @@ multiple threads must wait for a single event before proceeding. @include fun-sb-concurrency-make-gate.texinfo @include fun-sb-concurrency-open-gate.texinfo @include fun-sb-concurrency-wait-on-gate.texinfo + +@page +@anchor{Section sb-concurrency:frlock} +@subsection Frlocks, aka Fast Read Locks +@cindex Frlock +@cindex Fast Read Lock + +@include struct-sb-concurrency-frlock.texinfo + +@include macro-sb-concurrency-frlock-read.texinfo +@include macro-sb-concurrency-frlock-write.texinfo + +@include fun-sb-concurrency-make-frlock.texinfo +@include fun-sb-concurrency-frlock-name.texinfo + +@include fun-sb-concurrency-frlock-read-begin.texinfo +@include fun-sb-concurrency-frlock-read-end.texinfo +@include fun-sb-concurrency-grab-frlock-write-lock.texinfo +@include fun-sb-concurrency-release-frlock-write-lock.texinfo diff --git a/contrib/sb-concurrency/tests/test-frlock.lisp b/contrib/sb-concurrency/tests/test-frlock.lisp new file mode 100644 index 0000000..466ce8a --- /dev/null +++ b/contrib/sb-concurrency/tests/test-frlock.lisp @@ -0,0 +1,79 @@ +;;;; -*- Lisp -*- +;;;; +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package :sb-concurrency-test) + +(defun test-frlocks (&key (reader-count 100) (read-count 1000000) + (outer-read-pause 0) (inner-read-pause 0) + (writer-count 10) (write-count 10000) + (outer-write-pause 0.0001) (inner-write-pause 0)) + (let ((rw (make-frlock)) + (a 0) + (b 0) + (c 0) + (run! nil) + (w-e! (cons :write-oops nil)) + (r-e! (cons :read-oops nil))) + (flet ((maybe-pause (pause &optional value) + (if (eq t pause) + (sb-thread:thread-yield) + (when (> pause 0) + (sleep (random pause)))) + value)) + (mapc #'join-thread + (nconc + (loop repeat reader-count + collect + (make-thread + (lambda () + (loop until run! do (thread-yield)) + (handler-case + (loop repeat read-count + do (multiple-value-bind (a b c) + (frlock-read (rw) + a b (maybe-pause inner-read-pause c)) + (maybe-pause outer-read-pause) + (unless (eql c (+ a b)) + (sb-ext:atomic-update (cdr r-e!) #'cons + (list a b c))))) + (error (e) + (sb-ext:atomic-update (cdr r-e!) #'cons e)))))) + (loop repeat writer-count + collect (make-thread + (lambda () + (loop until run! do (thread-yield)) + (handler-case + (loop repeat write-count + do (frlock-write (rw) + (let* ((a_ (random 10000)) + (b_ (random 10000)) + (c_ (+ a_ b_))) + (setf a a_ + b b_ + c (+ a b)) + (maybe-pause inner-write-pause) + (unless (and (eql c c_) + (eql b b_) + (eql a a_)) + (sb-ext:atomic-update (cdr w-e!) #'cons + (list a a_ b b_ c c_))))) + (maybe-pause outer-write-pause)) + (error (e) + (sb-ext:atomic-update (cdr w-e!) #'cons e)))))) + (progn + (setf run! t) + nil)))) + (values (cdr w-e!) (cdr r-e!)))) + +(deftest frlock.1 + (test-frlocks) + nil + nil)