implement ATOMIC-PUSH and ATOMIC-POP

diff --git a/NEWS b/NEWS
index 6fc3407..2d4b7c9 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes relative to sbcl-1.0.58:
   * enhancement: New variable, sb-ext:*disassemble-annotate* for controlling
     source annotation of DISASSEMBLE output. Defaults to T.
+  * enhancement: SB-EXT:ATOMIC-PUSH and SB-EXT:ATOMIC-POP allow atomic operations
+    on list heads.
   * optimization: CL:SORT and CL:STABLE-SORT of lists are faster and use fewer
     comparisons, particularly on almost-sorted inputs.
   * bug fix: Reading floats with large exponents no longer takes too much time

diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo
index 1ea5e9a..7365510 100644 (file)
--- a/doc/manual/threading.texinfo
+++ b/doc/manual/threading.texinfo
@@ -109,6 +109,8 @@ lockless algorithms.
 
 @include macro-sb-ext-atomic-decf.texinfo
 @include macro-sb-ext-atomic-incf.texinfo
+@include macro-sb-ext-atomic-pop.texinfo
+@include macro-sb-ext-atomic-push.texinfo
 @include macro-sb-ext-atomic-update.texinfo
 @include macro-sb-ext-compare-and-swap.texinfo
 
@@ -119,8 +121,9 @@ 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.
+using @code{get-cas-expansion}. See @code{atomic-update},
+@code{atomic-push}, and €@code{atomic-pop} for example of how to do
+this.
 
 @include macro-sb-ext-cas.texinfo
 @include macro-sb-ext-define-cas-expander.texinfo
@@ -287,7 +290,8 @@ following functions and macros also serve as @code{:memory} barriers:
 
 @itemize
 @item
-@code{sb-ext:atomic-decf} and @code{sb-ext:atomic-incf}.
+@code{sb-ext:atomic-decf}, @code{sb-ext:atomic-incf}, @code{sb-ext:atomic-push},
+and @code{sb-ext:atomic-pop}.
 @item
 @code{sb-ext:compare-and-swap}.
 @item

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 42e5b84..bad7f20 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -613,6 +613,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "ATOMIC-INCF"
                "ATOMIC-DECF"
                "ATOMIC-UPDATE"
+               "ATOMIC-PUSH"
+               "ATOMIC-POP"
                "WORD"
                "MOST-POSITIVE-WORD"
 

diff --git a/src/code/cas.lisp b/src/code/cas.lisp
index 84f4c43..72e5800 100644 (file)
--- a/src/code/cas.lisp
+++ b/src/code/cas.lisp
@@ -80,9 +80,9 @@ Example:
           ,new))))
 
 EXPERIMENTAL: Interface subject to change."
-  (flet ((invalid-place ()
-           (error "Invalid place to CAS: ~S" place)))
     (let ((expanded (sb!xc:macroexpand place environment)))
+      (flet ((invalid-place ()
+           (error "Invalid place to CAS: ~S -> ~S" place expanded)))
       (unless (consp expanded)
         ;; FIXME: Allow (CAS *FOO* <OLD> <NEW>), maybe?
         (invalid-place))

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 7228897..48ee190 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -405,3 +405,34 @@ Examples:
        (loop for ,new = (funcall ,update-fn ,@arguments ,old)
              until (eq ,old (setf ,old ,cas-form))
              finally (return ,new)))))
+
+(defmacro atomic-push (obj place &environment env)
+  #!+sb-doc
+  "Like PUSH, but atomic. PLACE may be read multiple times before
+the operation completes -- the write does not occur until such time
+that no other thread modified PLACE between the read and the write.
+
+Works on all CASable places."
+  (multiple-value-bind (vars vals old new cas-form read-form)
+      (get-cas-expansion place env)
+    `(let* (,@(mapcar 'list vars vals)
+            (,old ,read-form)
+            (,new (cons ,obj ,old)))
+       (loop until (eq ,old (setf ,old ,cas-form))
+             do (setf (cdr ,new) ,old)
+             finally (return ,new)))))
+
+(defmacro atomic-pop (place &environment env)
+  #!+sb-doc
+  "Like POP, but atomic. PLACE may be read multiple times before
+the operation completes -- the write does not occur until such time
+that no other thread modified PLACE between the read and the write.
+
+Works on all CASable places."
+  (multiple-value-bind (vars vals old new cas-form read-form)
+      (get-cas-expansion place env)
+    `(let* (,@(mapcar 'list vars vals))
+       (loop for ,old = ,read-form
+             for ,new = (cdr ,old)
+             until (eq ,old (setf ,old ,cas-form))
+             finally (return (car ,old))))))

diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
index 6ec6547..1bbecf9 100644 (file)
--- a/tests/compare-and-swap.impure.lisp
+++ b/tests/compare-and-swap.impure.lisp
@@ -412,6 +412,7 @@
       (assert (eq :bar
                   (eval `(let (,@(mapcar 'list vars vals))
                       ,read-form)))))))
+
 (let ((foo (cons :foo nil)))
   (defun cas-foo (old new)
     (cas (cdr foo) old new)))
@@ -425,3 +426,22 @@
     (assert (not (cas bar nil :ok)))
     (assert (eq :ok (cas bar :ok nil)))
     (assert (not (cas bar nil t)))))
+
+(with-test (:name atomic-push
+            :skipped-on '(not :sb-thread))
+  (let ((store (cons nil nil))
+        (n 100000))
+    (symbol-macrolet ((x (car store))
+                      (y (cdr store)))
+      (dotimes (i n)
+        (push i y))
+      (mapc #'sb-thread:join-thread
+            (loop repeat 1000
+                  collect (sb-thread:make-thread
+                           (lambda ()
+                             (loop for z = (atomic-pop y)
+                                   while z
+                                   do (atomic-push z x)
+                                      (sleep 0.00001))))))
+      (assert (not y))
+      (assert (eql n (length x))))))