Steel Bank Common Lisp

The branch "master" has been updated in SBCL:
       via  126b9cfb25799ca41210c1a1658de30e1ff372e7 (commit)
      from  522a3c95b9b7a044ff0ab8df1ca29460ef2ad3a7 (commit)

- Log -----------------------------------------------------------------
commit 126b9cfb25799ca41210c1a1658de30e1ff372e7
Author: Nikodemus Siivola <nikodemus@...>
Date:   Wed May 16 00:53:51 2012 +0300

    implement ATOMIC-UPDATE
    
      Nicer than having to write explicit CAS loops.
    
      Also improve COMPARE-AND-SWAP docstring, and remove the EXPERIMENTAL label
      from it.
---
 NEWS                          |    2 ++
 doc/manual/threading.texinfo  |   14 ++++++++++----
 package-data-list.lisp-expr   |    1 +
 src/code/cas.lisp             |   15 +++++++++------
 src/code/late-extensions.lisp |   40 ++++++++++++++++++++++++++++++++++++++++
 tests/threads.pure.lisp       |   13 ++++++++++++-
 6 files changed, 74 insertions(+), 11 deletions(-)

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)))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL