Nicer than having to write explicit CAS loops.
Also improve COMPARE-AND-SWAP docstring, and remove the EXPERIMENTAL label
from it.
;;;; -*- 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)
@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
;; Other atomic operations and types related to them
"ATOMIC-INCF"
"ATOMIC-DECF"
+ "ATOMIC-UPDATE"
"WORD"
"MOST-POSITIVE-WORD"
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,
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.
,(/ 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)))))
(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)))
projects / sbcl.git / commitdiff