From: Nikodemus Siivola Date: Tue, 15 May 2012 21:53:51 +0000 (+0300) Subject: implement ATOMIC-UPDATE X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=126b9cfb25799ca41210c1a1658de30e1ff372e7;p=sbcl.git implement ATOMIC-UPDATE Nicer than having to write explicit CAS loops. Also improve COMPARE-AND-SWAP docstring, and remove the EXPERIMENTAL label from it. --- diff --git a/NEWS b/NEWS index ba2ca03..0acdd06 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.57: + * enhancement: SB-EXT:ATOMIC-UPDATE makes it easy to perform non-destructive + updates of CAS-able places (similar to Clojure's swap!). * bug fix: potential for infinite recursion during compilation of CLOS slot typechecks when dependency graph had loops. (lp#1001799) diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index 0f01ba6..1ea5e9a 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -104,17 +104,23 @@ prints @code{0} and not @code{1} as of 0.9.6. @comment node-name, next, previous, up @section Atomic Operations -SBCL provides a few special purpose atomic operations, particularly -useful for implementing lockless algorithms. +Following atomic operations are particularly useful for implementing +lockless algorithms. @include macro-sb-ext-atomic-decf.texinfo @include macro-sb-ext-atomic-incf.texinfo +@include macro-sb-ext-atomic-update.texinfo @include macro-sb-ext-compare-and-swap.texinfo @unnumberedsubsec CAS Protocol -Our @code{compare-and-swap} is user-extensible using a protocol similar -to @code{setf}: +Our @code{compare-and-swap} is user-extensible using a protocol +similar to @code{setf}, allowing users to add CAS support to new +places via eg. @code{defcas}. + +At the same time, new atomic operations can be built on top of CAS +using @code{get-cas-expansion}. See @code{atomic-update} for an +example. @include macro-sb-ext-cas.texinfo @include macro-sb-ext-define-cas-expander.texinfo diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index dde04ce..7fe92da 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -610,6 +610,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; Other atomic operations and types related to them "ATOMIC-INCF" "ATOMIC-DECF" + "ATOMIC-UPDATE" "WORD" "MOST-POSITIVE-WORD" diff --git a/src/code/cas.lisp b/src/code/cas.lisp index 04f6aa2..63ff0d9 100644 --- a/src/code/cas.lisp +++ b/src/code/cas.lisp @@ -207,7 +207,8 @@ EXPERIMENTAL: Interface subject to change." Two values are considered to match if they are EQ. Returns the previous value of PLACE: if the returned value is EQ to OLD, the swap was carried out. -PLACE must be an accessor form whose CAR is one of the following: +PLACE must be an CAS-able place. Built-in CAS-able places are accessor forms +whose CAR is one of the following: CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS, @@ -218,13 +219,15 @@ other then FIXNUM or T. In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is -returned and NEW is assigned to the slot. - -Additionally, the results are unspecified if there is an applicable method on -either SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or +returned and NEW is assigned to the slot. Additionally, the results are +unspecified if there is an applicable method on either +SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or SB-MOP:SLOT-BOUNDP-USING-CLASS. -EXPERIMENTAL: Interface subject to change." +Additionally, the PLACE can be a anything for which a CAS-expansion has been +specified using DEFCAS, DEFINE-CAS-EXPANDER, or for which a CAS-function has +been defined. (See SB-EXT:CAS for more information.) +" `(cas ,place ,old ,new)) ;;; Out-of-line definitions for various primitive cas functions. diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index d18939b..7228897 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -365,3 +365,43 @@ returns NIL each time." ,(/ 1.0 internal-time-units-per-second)) 0))))) ,@body)))) + +(defmacro atomic-update (place update-fn &rest arguments &environment env) + #!+sb-doc + "Updates PLACE atomically to the value returned by calling function +designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE. + +PLACE may be read and UPDATE-FN evaluated and called multiple times before the +update succeeds: atomicity in this context means that value of place did not +change between the time it was read, and the time it was replaced with the +computed value. + +PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP. + +Examples: + + ;;; Conses T to the head of FOO-LIST. + (defstruct foo list) + (defvar *foo* (make-foo)) + (atomic-update (foo-list *foo*) #'cons t) + + (let ((x (cons :count 0))) + (mapc #'sb-thread:join-thread + (loop repeat 1000 + collect (sb-thread:make-thread + (lambda () + (loop repeat 1000 + do (atomic-update (cdr x) #'1+) + (sleep 0.00001)))))) + ;; Guaranteed to be (:COUNT . 1000000) -- if you replace + ;; atomic update with (INCF (CDR X)) above, the result becomes + ;; unpredictable. + x) +" + (multiple-value-bind (vars vals old new cas-form read-form) + (get-cas-expansion place env) + `(let* (,@(mapcar 'list vars vals) + (,old ,read-form)) + (loop for ,new = (funcall ,update-fn ,@arguments ,old) + until (eq ,old (setf ,old ,cas-form)) + finally (return ,new))))) diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index 118422c..e785e73 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -14,12 +14,23 @@ (in-package :cl-user) (defpackage :thread-test - (:use :cl :sb-thread)) + (:use :cl :sb-thread :sb-ext)) (in-package :thread-test) (use-package :test-util) +(with-test (:name atomic-update) + (let ((x (cons :count 0))) + (mapc #'sb-thread:join-thread + (loop repeat 1000 + collect (sb-thread:make-thread + (lambda () + (loop repeat 1000 + do (atomic-update (cdr x) #'1+) + (sleep 0.00001)))))) + (assert (equal x '(:count . 1000000))))) + (with-test (:name mutex-owner) ;; Make sure basics are sane on unithreaded ports as well (let ((mutex (make-mutex)))