Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

implement ATOMIC-PUSH and ATOMIC-POP

  • Loading branch information...
commit af3fdb98f2b8718dbb69eba5db56dee369b142c7 1 parent 76db27f
@nikodemus nikodemus authored
View
2  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
View
10 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
View
2  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"
View
4 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))
View
31 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))))))
View
20 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))))))
Please sign in to comment.
Something went wrong with that request. Please try again.